diff mbox series

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

Message ID 20190812090252.GA22718@adacore.com
State New
Headers show
Series [Ada] Missing check on outbound parameter of a non-null access type | expand

Commit Message

Pierre-Marie de Rodat Aug. 12, 2019, 9:02 a.m. UTC 
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.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
diff mbox series

Patch

--- gcc/ada/exp_ch6.adb
+++ 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;
 

--- /dev/null
new file mode 100644
+++ 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;