[Ada] Additional fixes for Default_Initial_Condition

gcc/ada/

	* exp_aggr.adb (Build_Array_Aggr_Code.Gen_Assign): Move
	generation of the call for DIC check past the optional
	generation of calls to controlled Initialize procedures.
	* exp_ch3.adb
	(Build_Array_Init_Proc.Init_One_Dimension.Possible_DIC_Call):
	Suppress generation of a DIC call when the array component type
	is controlled.  The call will now be generated later inside the
	array's DI (Deep_Initialize) procedure.
	* exp_ch7.adb
	(Make_Deep_Array_Body.Build_Initialize_Statements): Generate a
	DIC call (when needed by the array component type) after any
	call to the component type's controlled Initialize procedure, or
	generate the DIC call by itself if there's no Initialize to
	call.
	* sem_aggr.adb (Resolve_Record_Aggregate.Add_Association):
	Simplify condition to only test Is_Box_Init_By_Default (previous
	condition was overkill, as well as incorrect in some cases).
	* sem_elab.adb (Active_Scenarios.Output_Call): For
	Default_Initial_Condition, suppress call to
	Output_Verification_Call when the subprogram is a partial DIC
	procedure.

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 30f6dd95e7cb2bc1c0b8e8cd7aaa5170d825ac83..d7e5470b717a08c4883e4ca4498452c717a988e1 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1865,21 +1865,6 @@ package body Exp_Aggr is
                    Typ               => Ctype,
                    With_Default_Init => True));
 
-               --  If Default_Initial_Condition applies to the component type,
-               --  add a DIC check after the component is default-initialized.
-               --  It will be analyzed and resolved before the code for
-               --  initialization of other components.
-
-               --  Theoretically this might also be needed for cases where
-               --  the component type doesn't have an init proc (such as for
-               --  Default_Value cases), but those should be uncommon, and for
-               --  now we only support the init proc case. ???
-
-               if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
-                  Append_To (Stmts,
-                    Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
-               end if;
-
                --  If the component type has invariants, add an invariant
                --  check after the component is default-initialized. It will
                --  be analyzed and resolved before the code for initialization
@@ -1910,6 +1895,22 @@ package body Exp_Aggr is
                   Append_To (Stmts, Init_Call);
                end if;
             end if;
+
+            --  If Default_Initial_Condition applies to the component type,
+            --  add a DIC check after the component is default-initialized,
+            --  as well as after an Initialize procedure is called, in the
+            --  case of components of a controlled type. It will be analyzed
+            --  and resolved before the code for initialization of other
+            --  components.
+
+            --  Theoretically this might also be needed for cases where Expr
+            --  is not empty, but a default init still applies, such as for
+            --  Default_Value cases, in which case we won't get here. ???
+
+            if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
+               Append_To (Stmts,
+                 Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
+            end if;
          end if;
 
          return Add_Loop_Actions (Stmts);

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index bbb7d5304bbf1ffdb13d5fa1078f36d5b898cfee..e46ede8506bfecf69c8103d8820d3baffe585082 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -697,6 +697,11 @@ package body Exp_Ch3 is
 
               and then not GNATprove_Mode
 
+              --  DIC checks for components of controlled types are done later
+              --  (see Exp_Ch7.Make_Deep_Array_Body).
+
+              and then not Is_Controlled (Comp_Type)
+
               and then Present (DIC_Procedure (Comp_Type))
 
               and then not Has_Null_Body (DIC_Procedure (Comp_Type))

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 55f714c0853fa8650bfecb834aa73426e42579a1..e06517c921377143e8867890b24f025b7f453f20 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -6848,22 +6848,49 @@ package body Exp_Ch7 is
 
          Init_Call := Build_Initialization_Call;
 
-         --  Only create finalization block if there is a non-trivial
-         --  call to initialization.
-
-         if Present (Init_Call)
-           and then Nkind (Init_Call) /= N_Null_Statement
+         --  Only create finalization block if there is a nontrivial call
+         --  to initialization or a Default_Initial_Condition check to be
+         --  performed.
+
+         if (Present (Init_Call)
+              and then Nkind (Init_Call) /= N_Null_Statement)
+           or else
+             (Has_DIC (Comp_Typ)
+               and then not GNATprove_Mode
+               and then Present (DIC_Procedure (Comp_Typ))
+               and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
          then
-            Init_Loop :=
-              Make_Block_Statement (Loc,
-                Handled_Statement_Sequence =>
-                  Make_Handled_Sequence_Of_Statements (Loc,
-                    Statements         => New_List (Init_Call),
-                    Exception_Handlers => New_List (
-                      Make_Exception_Handler (Loc,
-                        Exception_Choices => New_List (
-                          Make_Others_Choice (Loc)),
-                        Statements        => New_List (Final_Block)))));
+            declare
+               Init_Stmts : constant List_Id := New_List;
+
+            begin
+               if Present (Init_Call) then
+                  Append_To (Init_Stmts, Init_Call);
+               end if;
+
+               if Has_DIC (Comp_Typ)
+                 and then Present (DIC_Procedure (Comp_Typ))
+               then
+                  Append_To
+                    (Init_Stmts,
+                     Build_DIC_Call (Loc,
+                         Make_Indexed_Component (Loc,
+                           Prefix      => Make_Identifier (Loc, Name_V),
+                           Expressions => New_References_To (Index_List, Loc)),
+                         Comp_Typ));
+               end if;
+
+               Init_Loop :=
+                 Make_Block_Statement (Loc,
+                   Handled_Statement_Sequence =>
+                     Make_Handled_Sequence_Of_Statements (Loc,
+                       Statements         => Init_Stmts,
+                       Exception_Handlers => New_List (
+                         Make_Exception_Handler (Loc,
+                           Exception_Choices => New_List (
+                             Make_Others_Choice (Loc)),
+                           Statements        => New_List (Final_Block)))));
+            end;
 
             Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
               Make_Assignment_Statement (Loc,

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 3caa84f0cb0fcaa1ff06d7919f4aa92413270d19..0f546462b20201200d68b3b440155a7a6e8b70a8 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -3848,10 +3848,7 @@ package body Sem_Aggr is
          --  by default, then set flag on the new association to indicate that
          --  the original association was for such a box-initialized component.
 
-         if Resolve_Record_Aggregate.Is_Box_Present
-           and then not Is_Box_Present
-           and then Is_Box_Init_By_Default  -- ???
-         then
+         if Is_Box_Init_By_Default then
             Set_Was_Default_Init_Box_Association (Last (Assoc_List));
          end if;
       end Add_Association;

diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index d7a8bb0fd5e3f1a2f46c19224d0bcdafed934ad9..399aeb48444c233e02d5d82de1631ae77ba3b1cd 100644 (file)
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -2414,10 +2414,16 @@ package body Sem_Elab is
          --  Default_Initial_Condition
 
          elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
-            Output_Verification_Call
-              (Pred    => "Default_Initial_Condition",
-               Id      => First_Formal_Type (Subp_Id),
-               Id_Kind => "type");
+
+            --  Only do output for a normal DIC procedure, since partial DIC
+            --  procedures are subsidiary to those.
+
+            if not Is_Partial_DIC_Procedure (Subp_Id) then
+               Output_Verification_Call
+                 (Pred    => "Default_Initial_Condition",
+                  Id      => First_Formal_Type (Subp_Id),
+                  Id_Kind => "type");
+            end if;
 
          --  Entries