[Ada] Implement inheritance for Default_Initial_Condition and address other gaps

gcc/ada/

	* einfo.ads (Is_Partial_DIC_Procedure): New function.
	(Partial_DIC_Procedure): New procedure.
	* einfo.adb (Is_Partial_DIC_Procedure): New function to return
	whether a subprogram is a partial Default_Initial_Condition
	procedure by checking the name (to avoid adding a new field).
	(DIC_Procedure): Add a test that excludes partial DIC procedures
	from being returned.
	(Partial_DIC_Procedure): New procedure to return the partial DIC
	procedure of a type, if it has one (otherwise returns Empty).
	(Set_DIC_Procedure): Remove check for duplicate DIC procedures.
	* exp_aggr.adb (Gen_Assign): Generate a call to the type's DIC
	procedure in the case where an array component is default
	initialized (due to an association with a box).
	(Build_Record_Aggr_Code): For an extension aggregate, generate a
	call to the ancestor type's DIC procedure (if any) when the
	ancestor part is a subtype mark. For a record component
	association that was specified with a box (tested for by
	checking the new flag Was_Default_Init_Box_Association),
	generate a call to the component type's DIC procedure (if it has
	one).
	* exp_ch4.adb (Expand_N_Allocator): When the allocated object is
	default initialized and the designated type has a DIC aspect,
	generate a call to the DIC procedure.
	* exp_util.ads (Build_DIC_Call): Change the formal Obj_Id to
	name Obj_Name, and change its type from Entity_Id to Node_Id
	(and update comment).
	(Build_DIC_Procedure_Body): Add formal Partial_DIC, remove
	formal For_Freeze, and update comment accordingly.
	(Build_DIC_Procedure_Declaration): Add formal Partial_DIC and
	update comment.
	* exp_util.adb
	(Build_DIC_Call): Revised to use its Obj_Name (formerly Obj_Id)
	formal directly rather than calling New_Occurrence_Of on it, to
	allow arbitrary names to be passed rather than being limited to
	Entity_Ids.
	(Build_DIC_Procedure_Body): Call Add_Parent_DICs to generate
	checks for DICs associated with any parent types, implementing
	the required "additive" semantics for DICs. When building a DIC
	procedure body for a partial view (when Partial_DIC is True),
	call Add_Own_DIC when the type has its own DIC.  In the case of
	"full" DIC procedures, a call is generated to any partial DIC
	procedure of the type (unless the procedure has a null body),
	along with checks for any DICs inherited by the full view.
	(Build_DIC_Procedure_Declaration): Add handling for partial DIC
	procedures.  For the suffix of a regular DIC procedure's name,
	use "DIC" (instead of "Default_Initial_Condition"), and for the
	suffix of a partial DIC procedure's name, use "Partial_DIC".
	(Add_DIC_Check): Add the DIC pragma to the list of seen pragmas
	(Pragmas_Seen).
	(Add_Inherited_Tagged_DIC): Remove the formals Par_Typ,
	Deriv_Typ, and Obj_Id, and add formal Expr, which denotes DIC's
	expression. Remove the call to Replace_References (which is now
	done in Add_Inherited_DICs).
	(Add_Inherited_DICs): New procedure to locate a DIC pragma
	associated with a parent type, replace its references
	appropriately (such as any current instance references), and add
	a check for the DIC.
	(Add_Own_DIC): Add an Obj_Id formal to allow caller to pass the
	_init formal of the generated DIC procedure.
	(Add_Parent_DICs): New procedure to traverse a type's parents,
	looking for DICs associated with those and calling
	Add_Inherited_DICs to apply the appropriate DIC checks.
	(Is_Verifiable_DIC_Pragma): Treat pragmas that have an Empty
	first argument the same as a pragma without any arguments
	(returning False for that case).
	* exp_ch3.adb (Init_One_Dimension): Generate calls to the
	component's DIC procedure when needed.
	(Possible_DIC_Call): New function nested in Init_One_Dimension
	to build a call to the array component type's DIC-checking
	function when appropriate.
	(Build_Array_Init_Proc): The presence of a DIC on the component
	type is an additional condition for generating an init proc for
	an array type.
	(Build_Init_Statements): When the record component's type has a
	DIC, and the component declaration does not have an
	initialization expression, generate a call to the component
	type's DIC procedure.
	(Expand_N_Object_Declaration): Modify the call to Build_DIC_Call
	to pass a new occurrence of the object's defining id rather than
	the id itself.
	(Freeze_Type): Only build a type's DIC procedure (if it has one)
	for types that are not interfaces.
	* exp_spark.adb (Expand_SPARK_N_Freeze_Type): Remove From_Freeze
	actual and add a ??? comment.
	(Expand_SPARK_N_Object_Declaration): Modify call to
	Build_DIC_Call to pass a new occurrence of the object id rather
	than the object id itself.
	* sem_aggr.adb (Resolve_Record_Aggregate): Declare local flag
	Is_Box_Init_By_Default and set it in cases where the component
	association has a box and the component is being initialized by
	default (as opposed to initialized by an initialization
	expression associated with the component's declaration).
	(Add_Association): If the association has a box for a component
	initialized by default, the flag
	Was_Default_Init_Box_Association is set on the new component
	association (for later testing during expansion).
	(Get_Value): Reset Is_Box_Init_By_Default to False.
	* sem_ch3.adb (Build_Assertion_Bodies_For_Type): Rearrange code
	to build DIC procedure bodies for a (noninterface) type that
	Has_Own_DIC (for partial type views) or Has_DIC (for full type
	views) as appropriate.
	* sem_ch13.adb (Analyze_Aspect_Specifications,
	Aspect_Default_Initial_Condition): Add an extra argument to the
	DIC pragma to denote the type associated with the pragma (for
	use in Build_DIC_Procedure_Body).
	* sem_prag.adb (Analyze_Pragma): Allow two arguments for pragma
	Default_Initial_Condition.  If not already present, add an extra
	argument denoting the type that the pragma is associated with.
	* sem_util.adb (Propagate_DIC_Attributes): Retrieve any partial
	DIC procedure associated with the type and add it to the type's
	list of subprograms (Subprograms_For_Type).
	* sinfo.ads (Was_Default_Init_Box_Association): New flag on
	N_Component_Association nodes.  Add subprograms to get and set
	flag, as well as updating the documentation.
	* sinfo.adb (Was_Default_Init_Box_Association): New function to
	retrieve the corresponding flag (Flag14).
	(Set_Was_Default_Init_Box_Association): New procedure to set the
	corresponding flag (Flag14).

1 files changed, 50 insertions, 32 deletions

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f487f73..00834ce 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2312,13 +2312,6 @@ package body Sem_Ch3 is
 
          procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is
          begin
-            --  Preanalyze and resolve the Default_Initial_Condition assertion
-            --  expression at the end of the declarations to catch any errors.
-
-            if Has_DIC (Typ) then
-               Build_DIC_Procedure_Body (Typ);
-            end if;
-
             if Nkind (Context) = N_Package_Specification then
 
                --  Preanalyze and resolve the class-wide invariants of an
@@ -2341,32 +2334,57 @@ package body Sem_Ch3 is
                         Partial_Invariant => True);
                   end if;
 
-               --  Preanalyze and resolve the invariants of a private type
-               --  at the end of the visible declarations to catch potential
-               --  errors. Inherited class-wide invariants are not included
-               --  because they have already been resolved.
+               elsif Decls = Visible_Declarations (Context) then
+                  --  Preanalyze and resolve the invariants of a private type
+                  --  at the end of the visible declarations to catch potential
+                  --  errors. Inherited class-wide invariants are not included
+                  --  because they have already been resolved.
 
-               elsif Decls = Visible_Declarations (Context)
-                 and then Ekind (Typ) in E_Limited_Private_Type
-                                       | E_Private_Type
-                                       | E_Record_Type_With_Private
-                 and then Has_Own_Invariants (Typ)
-               then
-                  Build_Invariant_Procedure_Body
-                    (Typ               => Typ,
-                     Partial_Invariant => True);
-
-               --  Preanalyze and resolve the invariants of a private type's
-               --  full view at the end of the private declarations to catch
-               --  potential errors.
-
-               elsif Decls = Private_Declarations (Context)
-                 and then (not Is_Private_Type (Typ)
-                            or else Present (Underlying_Full_View (Typ)))
-                 and then Has_Private_Declaration (Typ)
-                 and then Has_Invariants (Typ)
-               then
-                  Build_Invariant_Procedure_Body (Typ);
+                  if Ekind (Typ) in E_Limited_Private_Type
+                                  | E_Private_Type
+                                  | E_Record_Type_With_Private
+                    and then Has_Own_Invariants (Typ)
+                  then
+                     Build_Invariant_Procedure_Body
+                       (Typ               => Typ,
+                        Partial_Invariant => True);
+                  end if;
+
+                  --  Preanalyze and resolve the Default_Initial_Condition
+                  --  assertion expression at the end of the declarations to
+                  --  catch any errors.
+
+                  if Ekind (Typ) in E_Limited_Private_Type
+                                  | E_Private_Type
+                                  | E_Record_Type_With_Private
+                     and then Has_Own_DIC (Typ)
+                  then
+                     Build_DIC_Procedure_Body
+                       (Typ         => Typ,
+                        Partial_DIC => True);
+                  end if;
+
+               elsif Decls = Private_Declarations (Context) then
+
+                  --  Preanalyze and resolve the invariants of a private type's
+                  --  full view at the end of the private declarations to catch
+                  --  potential errors.
+
+                  if (not Is_Private_Type (Typ)
+                       or else Present (Underlying_Full_View (Typ)))
+                    and then Has_Private_Declaration (Typ)
+                    and then Has_Invariants (Typ)
+                  then
+                     Build_Invariant_Procedure_Body (Typ);
+                  end if;
+
+                  if (not Is_Private_Type (Typ)
+                       or else Present (Underlying_Full_View (Typ)))
+                    and then Has_Private_Declaration (Typ)
+                    and then Has_DIC (Typ)
+                  then
+                     Build_DIC_Procedure_Body (Typ);
+                  end if;
                end if;
             end if;
          end Build_Assertion_Bodies_For_Type;