[Ada] Spurious constraint error on array of null-excluding components

This patch fixes an issue whereby the compiler would raise spurious runtime
errors when an array of null-excluding components was initialized with an
expression which required the secondary stack (such as with an concatination
operation) due to certain generated checks which were incorrected performed
on internal object declarations.

2018-05-28  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* exp_ch3.adb
	(Build_Initialization_Call): Add logic to pass the appropriate actual to match
	 new formal.
	(Init_Formals): Add new formal *_skip_null_excluding_check
	* exp_util.adb, exp_util.ads
	(Enclosing_Init_Proc): Added to fetch the enclosing Init_Proc from the current
	 scope.
	(Inside_Init_Proc): Refactored to use Enclosing_Init_Proc
	(Needs_Conditional_Null_Excluding_Check): Added to factorize the predicate
	 used to determine how to generate an Init_Proc for a given type.
	(Needs_Constant_Address): Minor reformatting
	* sem_res.adb
	(Resolve_Null): Add logic to generate a conditional check in certain cases

gcc/testsuite/

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

From-SVN: r260822

gcc/ada/ChangeLog

+2018-05-28  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch3.adb
+	(Build_Initialization_Call): Add logic to pass the appropriate actual to match
+	 new formal.
+	(Init_Formals): Add new formal *_skip_null_excluding_check
+	* exp_util.adb, exp_util.ads
+	(Enclosing_Init_Proc): Added to fetch the enclosing Init_Proc from the current
+	 scope.
+	(Inside_Init_Proc): Refactored to use Enclosing_Init_Proc
+	(Needs_Conditional_Null_Excluding_Check): Added to factorize the predicate
+	 used to determine how to generate an Init_Proc for a given type.
+	(Needs_Constant_Address): Minor reformatting
+	* sem_res.adb
+	(Resolve_Null): Add logic to generate a conditional check in certain cases
+
 2018-05-28  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_aggr.adb, gnatlink.adb, sem_ch6.adb, sem_res.adb, sem_util.adb:

gcc/ada/exp_ch3.adb

@@ -1550,6 +1550,29 @@ package body Exp_Ch3 is
          Decl  := Empty;
       end if;
 
+      --  Handle the optionally generated formal *_skip_null_excluding_checks
+
+      if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) then
+
+         --  Look at the associated node for the object we are referencing and
+         --  verify that we are expanding a call to an Init_Proc for an
+         --  internally generated object declaration before passing True and
+         --  skipping the relevant checks.
+
+         if Nkind (Id_Ref) in N_Has_Entity
+           and then Comes_From_Source (Associated_Node (Id_Ref))
+         then
+            Append_To (Args,
+              New_Occurrence_Of (Standard_True, Loc));
+
+         --  Otherwise, we pass False to perform null excluding checks
+
+         else
+            Append_To (Args,
+              New_Occurrence_Of (Standard_False, Loc));
+         end if;
+      end if;
+
       --  Add discriminant values if discriminants are present
 
       if Has_Discriminants (Full_Init_Type) then
@@ -8643,6 +8666,24 @@ package body Exp_Ch3 is
              Parameter_Type      => New_Occurrence_Of (Standard_String, Loc)));
       end if;
 
+      --  Due to certain edge cases such as arrays with null excluding
+      --  components being built with the secondary stack it becomes necessary
+      --  to add a formal to the Init_Proc which controls whether we raise
+      --  constraint errors on generated calls for internal object
+      --  declarations.
+
+      if Needs_Conditional_Null_Excluding_Check (Typ) then
+         Append_To (Formals,
+           Make_Parameter_Specification (Loc,
+             Defining_Identifier =>
+               Make_Defining_Identifier (Loc,
+                 New_External_Name (Chars
+                   (Component_Type (Typ)), "_skip_null_excluding_check")),
+             In_Present          => True,
+             Parameter_Type      =>
+               New_Occurrence_Of (Standard_Boolean, Loc)));
+      end if;
+
       return Formals;
 
    exception

gcc/ada/exp_util.adb

@@ -4751,6 +4751,26 @@ package body Exp_Util is
       return New_Exp;
    end Duplicate_Subexpr_Move_Checks;
 
+   -------------------------
+   -- Enclosing_Init_Proc --
+   -------------------------
+
+   function Enclosing_Init_Proc return Entity_Id is
+      S : Entity_Id;
+
+   begin
+      S := Current_Scope;
+      while Present (S) and then S /= Standard_Standard loop
+         if Is_Init_Proc (S) then
+            return S;
+         else
+            S := Scope (S);
+         end if;
+      end loop;
+
+      return Empty;
+   end Enclosing_Init_Proc;
+
    --------------------
    -- Ensure_Defined --
    --------------------
@@ -7534,19 +7554,10 @@ package body Exp_Util is
    ----------------------
 
    function Inside_Init_Proc return Boolean is
-      S : Entity_Id;
+      Proc : constant Entity_Id := Enclosing_Init_Proc;
 
    begin
-      S := Current_Scope;
-      while Present (S) and then S /= Standard_Standard loop
-         if Is_Init_Proc (S) then
-            return True;
-         else
-            S := Scope (S);
-         end if;
-      end loop;
-
-      return False;
+      return Proc /= Empty;
    end Inside_Init_Proc;
 
    ----------------------------
@@ -10430,6 +10441,72 @@ package body Exp_Util is
       end if;
    end May_Generate_Large_Temp;
 
+   --------------------------------------------
+   -- Needs_Conditional_Null_Excluding_Check --
+   --------------------------------------------
+
+   function Needs_Conditional_Null_Excluding_Check
+     (Typ : Entity_Id) return Boolean
+   is
+   begin
+      return Is_Array_Type (Typ)
+               and then Can_Never_Be_Null (Component_Type (Typ));
+   end Needs_Conditional_Null_Excluding_Check;
+
+   ----------------------------
+   -- Needs_Constant_Address --
+   ----------------------------
+
+   function Needs_Constant_Address
+     (Decl : Node_Id;
+      Typ  : Entity_Id) return Boolean
+   is
+   begin
+      --  If we have no initialization of any kind, then we don't need to place
+      --  any restrictions on the address clause, because the object will be
+      --  elaborated after the address clause is evaluated. This happens if the
+      --  declaration has no initial expression, or the type has no implicit
+      --  initialization, or the object is imported.
+
+      --  The same holds for all initialized scalar types and all access types.
+      --  Packed bit arrays of size up to 64 are represented using a modular
+      --  type with an initialization (to zero) and can be processed like other
+      --  initialized scalar types.
+
+      --  If the type is controlled, code to attach the object to a
+      --  finalization chain is generated at the point of declaration, and
+      --  therefore the elaboration of the object cannot be delayed: the
+      --  address expression must be a constant.
+
+      if No (Expression (Decl))
+        and then not Needs_Finalization (Typ)
+        and then
+          (not Has_Non_Null_Base_Init_Proc (Typ)
+            or else Is_Imported (Defining_Identifier (Decl)))
+      then
+         return False;
+
+      elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
+        or else Is_Access_Type (Typ)
+        or else
+          (Is_Bit_Packed_Array (Typ)
+            and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
+      then
+         return False;
+
+      else
+
+         --  Otherwise, we require the address clause to be constant because
+         --  the call to the initialization procedure (or the attach code) has
+         --  to happen at the point of the declaration.
+
+         --  Actually the IP call has been moved to the freeze actions anyway,
+         --  so maybe we can relax this restriction???
+
+         return True;
+      end if;
+   end Needs_Constant_Address;
+
    ------------------------
    -- Needs_Finalization --
    ------------------------
@@ -10519,60 +10596,6 @@ package body Exp_Util is
    end Needs_Finalization;
 
    ----------------------------
-   -- Needs_Constant_Address --
-   ----------------------------
-
-   function Needs_Constant_Address
-     (Decl : Node_Id;
-      Typ  : Entity_Id) return Boolean
-   is
-   begin
-      --  If we have no initialization of any kind, then we don't need to place
-      --  any restrictions on the address clause, because the object will be
-      --  elaborated after the address clause is evaluated. This happens if the
-      --  declaration has no initial expression, or the type has no implicit
-      --  initialization, or the object is imported.
-
-      --  The same holds for all initialized scalar types and all access types.
-      --  Packed bit arrays of size up to 64 are represented using a modular
-      --  type with an initialization (to zero) and can be processed like other
-      --  initialized scalar types.
-
-      --  If the type is controlled, code to attach the object to a
-      --  finalization chain is generated at the point of declaration, and
-      --  therefore the elaboration of the object cannot be delayed: the
-      --  address expression must be a constant.
-
-      if No (Expression (Decl))
-        and then not Needs_Finalization (Typ)
-        and then
-          (not Has_Non_Null_Base_Init_Proc (Typ)
-            or else Is_Imported (Defining_Identifier (Decl)))
-      then
-         return False;
-
-      elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
-        or else Is_Access_Type (Typ)
-        or else
-          (Is_Bit_Packed_Array (Typ)
-            and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
-      then
-         return False;
-
-      else
-
-         --  Otherwise, we require the address clause to be constant because
-         --  the call to the initialization procedure (or the attach code) has
-         --  to happen at the point of the declaration.
-
-         --  Actually the IP call has been moved to the freeze actions anyway,
-         --  so maybe we can relax this restriction???
-
-         return True;
-      end if;
-   end Needs_Constant_Address;
-
-   ----------------------------
    -- New_Class_Wide_Subtype --
    ----------------------------
 

gcc/ada/exp_util.ads

@@ -505,6 +505,11 @@ package Exp_Util is
    --  elaborated before the original expression Exp, so that there is no need
    --  to repeat the checks.
 
+   function Enclosing_Init_Proc return Entity_Id;
+   --  Obtain the entity associated with the enclosing type Init_Proc by
+   --  examining the current scope. If not inside an Init_Proc at the point of
+   --  call Empty will be returned.
+
    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id);
    --  This procedure ensures that type referenced by Typ is defined. For the
    --  case of a type other than an Itype, nothing needs to be done, since
@@ -916,6 +921,11 @@ package Exp_Util is
    --  caller has to check whether stack checking is actually enabled in order
    --  to guide the expansion (typically of a function call).
 
+   function Needs_Conditional_Null_Excluding_Check
+     (Typ : Entity_Id) return Boolean;
+   --  Check if a type meets certain properties that require it to have a
+   --  conditional null-excluding check within its Init_Proc.
+
    function Needs_Constant_Address
      (Decl : Node_Id;
       Typ  : Entity_Id) return Boolean;

gcc/ada/sem_res.adb

@@ -9116,23 +9116,52 @@ package body Sem_Res is
       end if;
 
       --  Ada 2005 (AI-231): Generate the null-excluding check in case of
-      --  assignment to a null-excluding object
+      --  assignment to a null-excluding object.
 
       if Ada_Version >= Ada_2005
         and then Can_Never_Be_Null (Typ)
         and then Nkind (Parent (N)) = N_Assignment_Statement
       then
-         if not Inside_Init_Proc then
-            Insert_Action
-              (Compile_Time_Constraint_Error (N,
-                 "(Ada 2005) null not allowed in null-excluding objects??"),
+         if Inside_Init_Proc then
+
+            --  Decide whether to generate an if_statement around our
+            --  null-excluding check to avoid them on certain internal object
+            --  declarations by looking at the type the current Init_Proc
+            --  belongs to.
+
+            --  Generate:
+            --    if T1b_skip_null_excluding_check then
+            --       [constraint_error "access check failed"]
+            --    end if;
+
+            if Needs_Conditional_Null_Excluding_Check
+                (Etype (First_Formal (Enclosing_Init_Proc)))
+            then
+               Insert_Action (N,
+                 Make_If_Statement (Loc,
+                   Condition       =>
+                     Make_Identifier (Loc,
+                       New_External_Name
+                         (Chars (Typ), "_skip_null_excluding_check")),
+                   Then_Statements =>
+                     New_List (
                        Make_Raise_Constraint_Error (Loc,
-                 Reason => CE_Access_Check_Failed));
+                         Reason => CE_Access_Check_Failed))));
+
+            --  Otherwise, simply create the check
+
             else
                Insert_Action (N,
                  Make_Raise_Constraint_Error (Loc,
                    Reason => CE_Access_Check_Failed));
             end if;
+         else
+            Insert_Action
+              (Compile_Time_Constraint_Error (N,
+                 "(Ada 2005) null not allowed in null-excluding objects??"),
+               Make_Raise_Constraint_Error (Loc,
+                 Reason => CE_Access_Check_Failed));
+         end if;
       end if;
 
       --  In a distributed context, null for a remote access to subprogram may

gcc/testsuite/ChangeLog

 2018-05-28  Justin Squirek  <squirek@adacore.com>
 
+	* gnat.dg/array31.adb: New testcase.
+
+2018-05-28  Justin Squirek  <squirek@adacore.com>
+
 	* gnat.dg/warn15-core-main.adb, gnat.dg/warn15-core.ads,
 	gnat.dg/warn15-interfaces.ads, gnat.dg/warn15.ads: New testcase.
 

gcc/testsuite/gnat.dg/array31.adb

+--  { dg-do run }
+
+procedure Array31 is
+
+   type Boolean_Access is access Boolean;
+
+   type Boolean_Access_Array is
+     array (Positive range <>) of not null Boolean_Access;
+
+   X : constant Boolean_Access_Array := (1 => new Boolean'(False));
+   Y : constant Boolean_Access_Array := X & X;
+
+begin
+   null;
+end;