[Ada] Missing check on outbound parameter of a non-null access type

This patch adds code to generate proper post-call 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  <schonberg@adacore.com>

gcc/ada/

	* 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.

gcc/testsuite/

	* gnat.dg/null_check.adb: New testcase.

From-SVN: r274306

4 files changed, 61 insertions, 3 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 74ceb50..c62e621 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,13 @@
 2019-08-12  Ed Schonberg  <schonberg@adacore.com>
 
+	* 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  <schonberg@adacore.com>
+
 	* sem_util.adb (Is_Expaned_Priority_Attribute): Check whether
 	call comes from a rewritten attribute before comparing name with
 	Get_Ceiling run-time subprogram.
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 4ba9d84..8d5a70db 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 9c1bd07..d5267a8 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
 2019-08-12  Ed Schonberg  <schonberg@adacore.com>
 
+	* gnat.dg/null_check.adb: New testcase.
+
+2019-08-12  Ed Schonberg  <schonberg@adacore.com>
+
 	* gnat.dg/renaming15.adb: New testcase.
 
 2019-08-12  Eric Botcazou  <ebotcazou@adacore.com>
diff --git a/gcc/testsuite/gnat.dg/null_check.adb b/gcc/testsuite/gnat.dg/null_check.adb
new file mode 100644
index 0000000..c335c06
--- /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;