diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 74ceb50653c..c62e621b96d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2019-08-12 Ed Schonberg + + * exp_ch6.adb (Expand_Actuals. Add_Call_By_Copy_Code): Add code + to generate proper checks when an actual for an in-out or out + parameter has a non-null access type. No constraints are + applied to an inbound access parameter, but on exit a not-null + check must be performed if the type of the actual requires it. + 2019-08-12 Ed Schonberg * sem_util.adb (Is_Expaned_Priority_Attribute): Check whether diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4ba9d84804b..8d5a70dbe97 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1406,6 +1406,16 @@ package body Exp_Ch6 is Init := New_Occurrence_Of (Var, Loc); end if; + -- Access types are passed in without checks, but if a copy-back is + -- required for a null-excluding check on an in-out or out parameter, + -- then the initial value is that of the actual. + + elsif Is_Access_Type (E_Formal) + and then Can_Never_Be_Null (Etype (Actual)) + and then not Can_Never_Be_Null (E_Formal) + then + Init := New_Occurrence_Of (Var, Loc); + else Init := Empty; end if; @@ -1544,6 +1554,19 @@ package body Exp_Ch6 is Type_Access_Level (E_Formal)))); else + if Is_Access_Type (E_Formal) + and then Can_Never_Be_Null (Etype (Actual)) + and then not Can_Never_Be_Null (E_Formal) + then + Append_To (Post_Call, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Temp, Loc), + Right_Opnd => Make_Null (Loc)), + Reason => CE_Access_Check_Failed)); + end if; + Append_To (Post_Call, Make_Assignment_Statement (Loc, Name => Lhs, @@ -1942,7 +1965,8 @@ package body Exp_Ch6 is Apply_Constraint_Check (Actual, E_Formal); -- Out parameter case. No constraint checks on access type - -- RM 6.4.1 (13) + -- RM 6.4.1 (13), but on return a null-excluding check may be + -- required (see below). elsif Is_Access_Type (E_Formal) then null; @@ -2049,11 +2073,14 @@ package body Exp_Ch6 is -- formal subtype are not the same, requiring a check. -- It is necessary to exclude tagged types because of "downward - -- conversion" errors. + -- conversion" errors, but null-excluding checks on return may be + -- required. elsif Is_Access_Type (E_Formal) - and then not Same_Type (E_Formal, E_Actual) and then not Is_Tagged_Type (Designated_Type (E_Formal)) + and then (not Same_Type (E_Formal, E_Actual) + or else (Can_Never_Be_Null (E_Actual) + and then not Can_Never_Be_Null (E_Formal))) then Add_Call_By_Copy_Code; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9c1bd07b3f9..d5267a84cfa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-12 Ed Schonberg + + * gnat.dg/null_check.adb: New testcase. + 2019-08-12 Ed Schonberg * gnat.dg/renaming15.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/null_check.adb b/gcc/testsuite/gnat.dg/null_check.adb new file mode 100644 index 00000000000..c335c067161 --- /dev/null +++ b/gcc/testsuite/gnat.dg/null_check.adb @@ -0,0 +1,19 @@ +-- { dg-do run } + +procedure Null_Check with SPARK_Mode is + type Int_Ptr is access Integer; + subtype Not_Null_Int_Ptr is not null Int_Ptr; + + procedure Set_To_Null (X : out Int_Ptr) with Global => null is + begin + X := null; + end Set_To_Null; + + X : Not_Null_Int_Ptr := new Integer'(12); +begin + Set_To_Null (X); + raise Program_Error; +exception + when Constraint_Error => + null; +end Null_Check;