diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 88fea2e818ce..2871f318b3e5 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -158,6 +158,7 @@ package Aspects is Aspect_Stream_Size, Aspect_String_Literal, Aspect_Subprogram_Variant, -- GNAT + Aspect_Super, -- GNAT Aspect_Suppress, Aspect_Synchronization, Aspect_Test_Case, -- GNAT @@ -518,6 +519,7 @@ package Aspects is Aspect_Stream_Size => Expression, Aspect_String_Literal => Name, Aspect_Subprogram_Variant => Expression, + Aspect_Super => Expression, Aspect_Suppress => Name, Aspect_Synchronization => Name, Aspect_Test_Case => Expression, @@ -626,6 +628,7 @@ package Aspects is Aspect_Stream_Size => True, Aspect_String_Literal => False, Aspect_Subprogram_Variant => False, + Aspect_Super => False, Aspect_Suppress => False, Aspect_Synchronization => False, Aspect_Test_Case => False, @@ -842,6 +845,7 @@ package Aspects is Aspect_Stream_Size => Name_Stream_Size, Aspect_String_Literal => Name_String_Literal, Aspect_Subprogram_Variant => Name_Subprogram_Variant, + Aspect_Super => Name_Super, Aspect_Suppress => Name_Suppress, Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, Aspect_Suppress_Initialization => Name_Suppress_Initialization, @@ -1124,6 +1128,7 @@ package Aspects is Aspect_SPARK_Mode => Never_Delay, Aspect_Static => Never_Delay, Aspect_Subprogram_Variant => Never_Delay, + Aspect_Super => Never_Delay, Aspect_Synchronization => Never_Delay, Aspect_Test_Case => Never_Delay, Aspect_Unimplemented => Never_Delay, @@ -1193,10 +1198,12 @@ package Aspects is -- Sem_Prag. Aspect_On_Body_Or_Stub_OK : constant array (Aspect_Id) of Boolean := - (Aspect_Refined_Depends => True, + (Aspect_Initialize => True, + Aspect_Refined_Depends => True, Aspect_Refined_Global => True, Aspect_Refined_Post => True, Aspect_SPARK_Mode => True, + Aspect_Super => True, Aspect_Warnings => True, others => False); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7fc104d173bc..a7255da90180 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Accessibility; use Accessibility; -with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -5113,310 +5112,57 @@ package body Exp_Attr is when Attribute_Make => declare - Params : List_Id; - Param : Node_Id; - Par : Node_Id; - Construct : Entity_Id; - Obj : Node_Id := Empty; - Make_Expr : Node_Id := N; - - Formal : Entity_Id; - Replace_Expr : Node_Id; - Init_Param : Node_Id; - Construct_Call : Node_Id; - Curr_Nam : Node_Id := Empty; - - function Replace_Formal_Ref - (N : Node_Id) return Traverse_Result; - - function Replace_Formal_Ref - (N : Node_Id) return Traverse_Result is - begin - if Is_Entity_Name (N) - and then Chars (Formal) = Chars (N) - then - Rewrite (N, - New_Copy_Tree (Replace_Expr)); - end if; - - return OK; - end Replace_Formal_Ref; - - procedure Search_And_Replace_Formal is new - Traverse_Proc (Replace_Formal_Ref); - + Constructor_Params : List_Id := New_Copy_List (Expressions (N)); + Constructor_Call : Node_Id; + Constructor_EWA : Node_Id; + Result_Decl : Node_Id; + Result_Id : constant Entity_Id := + Make_Temporary (Loc, 'D', N); begin - -- Remove side effects for constructor call - - Param := First (Expressions (N)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association then - Remove_Side_Effects (Explicit_Actual_Parameter (Param), - Check_Side_Effects => False); - else - Remove_Side_Effects (Param, Check_Side_Effects => False); - end if; - - Next (Param); - end loop; - - -- Construct the parameters list - - Params := New_Copy_List (Expressions (N)); - if Is_Empty_List (Params) then - Params := New_List; + if Is_Empty_List (Constructor_Params) then + Constructor_Params := New_List; end if; - -- Identify the enclosing parent for the non-copy cases + Result_Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Result_Id, + Object_Definition => + New_Occurrence_Of (Typ, Loc)); - Par := Parent (N); - if Nkind (Par) = N_Qualified_Expression then - Par := Parent (Par); - Make_Expr := Par; - end if; - if Nkind (Par) = N_Allocator then - Par := Parent (Par); - Curr_Nam := Make_Explicit_Dereference - (Loc, Prefix => Empty); - Obj := Curr_Nam; - end if; + -- Suppress default initialization for result object. + -- Default init (except for tag, if tagged) will instead be + -- performed in the constructor procedure. + + Mutate_Ekind (Result_Id, E_Variable); + Set_Suppress_Initialization (Result_Id); + + -- Build a prefixed-notation call declare - Base_Obj : Node_Id := Empty; - Typ_Comp : Entity_Id; - Agg_Comp : Entity_Id; - Comp_Nam : Node_Id := Empty; + Proc_Name : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Result_Id, Loc), + Selector_Name => Make_Identifier (Loc, + Chars (Constructor_Name (Typ)))); begin - while Nkind (Par) not in N_Object_Declaration - | N_Assignment_Statement - loop - if Nkind (Par) = N_Aggregate then - Typ_Comp := First_Entity (Etype (Par)); - Agg_Comp := First (Expressions (Par)); - loop - if No (Agg_Comp) then - return; - end if; + Set_Is_Prefixed_Call (Proc_Name); - if Agg_Comp = Make_Expr then - Comp_Nam := - Make_Selected_Component (Loc, - Prefix => Empty, - Selector_Name => - New_Occurrence_Of (Typ_Comp, Loc)); - - Make_Expr := Parent (Make_Expr); - Par := Parent (Par); - exit; - end if; - - Next_Entity (Typ_Comp); - Next (Agg_Comp); - end loop; - elsif Nkind (Par) = N_Component_Association then - Comp_Nam := - Make_Selected_Component (Loc, - Prefix => Empty, - Selector_Name => - Make_Identifier (Loc, - (Chars (First (Choices (Par)))))); - - Make_Expr := Parent (Parent (Make_Expr)); - Par := Parent (Parent (Par)); - else - declare - Temp : constant Entity_Id := - Make_Temporary (Loc, 'T', N); - begin - Rewrite (N, - Make_Expression_With_Actions (Loc, - Actions => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Typ, Loc), - Expression => - New_Copy_Tree (N))), - Expression => New_Occurrence_Of (Temp, Loc))); - Analyze_And_Resolve (N); - return; - end; - end if; - - if No (Curr_Nam) then - Curr_Nam := Comp_Nam; - Obj := Curr_Nam; - elsif Has_Prefix (Curr_Nam) then - Set_Prefix (Curr_Nam, Comp_Nam); - Curr_Nam := Comp_Nam; - end if; - end loop; - - Base_Obj := (case Nkind (Par) is - when N_Assignment_Statement => - New_Copy_Tree (Name (Par)), - when N_Object_Declaration => - New_Occurrence_Of - (Defining_Identifier (Par), Loc), - when others => (raise Program_Error)); - - if Present (Curr_Nam) then - Set_Prefix (Curr_Nam, Base_Obj); - else - Obj := Base_Obj; - end if; + Constructor_Call := Make_Procedure_Call_Statement (Loc, + Parameter_Associations => Constructor_Params, + Name => Proc_Name); end; - Prepend_To (Params, Obj); + Set_Is_Expanded_Constructor_Call (Constructor_Call, True); - -- Find the constructor we are interested in by doing a - -- pseudo-pass to resolve the constructor call. + Constructor_EWA := + Make_Expression_With_Actions (Loc, + Actions => New_List (Result_Decl, Constructor_Call), + Expression => New_Occurrence_Of (Result_Id, Loc)); - declare - Dummy_Params : List_Id := New_Copy_List (Expressions (N)); - Dummy_Self : Node_Id; - Dummy_Block : Node_Id; - Dummy_Call : Node_Id; - Dummy_Id : Entity_Id := Make_Temporary (Loc, 'D', N); - begin - if Is_Empty_List (Dummy_Params) then - Dummy_Params := New_List; - end if; - - Dummy_Self := Make_Object_Declaration (Loc, - Defining_Identifier => Dummy_Id, - Object_Definition => - New_Occurrence_Of (Typ, Loc)); - Prepend_To (Dummy_Params, New_Occurrence_Of (Dummy_Id, Loc)); - - Dummy_Call := Make_Procedure_Call_Statement (Loc, - Parameter_Associations => Dummy_Params, - Name => - (if not Has_Prefix (Pref) then - Make_Identifier (Loc, - Chars (Constructor_Name (Typ))) - else - Make_Expanded_Name (Loc, - Chars => - Chars (Constructor_Name (Typ)), - Prefix => - New_Copy_Tree (Prefix (Pref)), - Selector_Name => - Make_Identifier (Loc, - Chars (Constructor_Name (Typ)))))); - Set_Is_Expanded_Constructor_Call (Dummy_Call, True); - - Dummy_Block := Make_Block_Statement (Loc, - Declarations => New_List (Dummy_Self), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Dummy_Call))); - - Expander_Active := False; - - Insert_After_And_Analyze - (Enclosing_Declaration_Or_Statement (Par), Dummy_Block); - - Expander_Active := True; - - -- Finally, we can get the constructor based on our pseudo-pass - - Construct := Entity (Name (Dummy_Call)); - - -- Replace the Typ'Make attribute with an aggregate featuring - -- then relevant aggregate from the correct constructor's - -- Inializeaspect if it is present - otherwise, simply use a - -- box. - - if Has_Aspect (Construct, Aspect_Initialize) then - Rewrite (N, - New_Copy_Tree - (Find_Value_Of_Aspect (Construct, Aspect_Initialize))); - - Param := Next (First (Params)); - Formal := Next_Entity (First_Entity (Construct)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association then - Formal := Selector_Name (Param); - Replace_Expr := Explicit_Actual_Parameter (Param); - else - Replace_Expr := Param; - end if; - - Init_Param := First (Component_Associations (N)); - while Present (Init_Param) loop - Search_And_Replace_Formal (Expression (Init_Param)); - - Next (Init_Param); - end loop; - - if Nkind (Param) /= N_Parameter_Association then - Next_Entity (Formal); - end if; - Next (Param); - end loop; - - Init_Param := First (Component_Associations (N)); - while Present (Init_Param) loop - if Nkind (Expression (Init_Param)) = N_Attribute_Reference - and then Attribute_Name - (Expression (Init_Param)) = Name_Make - then - Insert_After (Par, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - New_Copy_Tree (First (Params)), - Selector_Name => - Make_Identifier (Loc, - Chars (First (Choices (Init_Param))))), - Expression => - New_Copy_Tree (Expression (Init_Param)))); - - Rewrite (Expression (Init_Param), - Make_Aggregate (Loc, - Expressions => New_List, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => - New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)))); - end if; - - Next (Init_Param); - end loop; - else - Rewrite (N, - Make_Aggregate (Loc, - Expressions => New_List, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)))); - end if; - - -- Rewrite this block to be null and pretend it didn't happen - - Rewrite (Dummy_Block, Make_Null_Statement (Loc)); - end; - - Analyze_And_Resolve (N, Typ); - - -- Finally, insert the constructor call - - Construct_Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Construct, Loc), - Parameter_Associations => Params); - - Set_Is_Expanded_Constructor_Call (Construct_Call); - Insert_After (Par, Construct_Call); + Rewrite (N, Constructor_EWA); end; + Analyze_And_Resolve (N, Typ); + -------------- -- Mantissa -- -------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 07cb4eb84de8..d5dfc5d20944 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -75,7 +75,6 @@ with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Stand; use Stand; with Snames; use Snames; -with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Validsw; use Validsw; with Warnsw; use Warnsw; @@ -211,32 +210,6 @@ package body Exp_Ch3 is -- component that requires late initialization; this includes -- components of ancestor types. - type Initialization_Mode is - (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only); - -- The initialization routine for a tagged type is passed in a - -- formal parameter of this type, indicating what initialization - -- is to be performed. This parameter defaults to Full_Init in all - -- cases except when the init proc of a type extension (let's call - -- that type T2) calls the init proc of its parent (let's call that - -- type T1). In that case, one of the other 3 values will - -- be passed in. In all three of those cases, the Tag component has - -- already been initialized before the call and is therefore not to be - -- modified. T2's init proc will either call T1's init proc - -- once (with Full_Init_Except_Tag as the parameter value) or twice - -- (first with Early_Init_Only, then later with Late_Init_Only), - -- depending on the result returned by Has_Late_Init_Component (T1). - -- In the latter case, the first call does not initialize any - -- components that require late initialization and the second call - -- then performs that deferred initialization. - -- Strictly speaking, the formal parameter subtype is actually Natural - -- but calls will only pass in values corresponding to literals - -- of this enumeration type. - - function Make_Mode_Literal - (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id - is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode))); - -- Generate an integer literal for a given mode value. - function Tag_Init_Condition (Loc : Source_Ptr; Init_Control_Formal : Entity_Id) return Node_Id; @@ -2481,14 +2454,10 @@ package body Exp_Ch3 is and then Nkind (Id_Ref) = N_Selected_Component and then Chars (Selector_Name (Id_Ref)) = Name_uParent then - declare - use Initialization_Control; - begin - Append_To (Args, - (if Present (Init_Control_Actual) - then Init_Control_Actual - else Make_Mode_Literal (Loc, Full_Init_Except_Tag))); - end; + Append_To (Args, + (if Present (Init_Control_Actual) + then Init_Control_Actual + else Make_Mode_Literal (Loc, Full_Init_Except_Tag))); elsif Present (Constructor_Ref) then Append_List_To (Args, New_Copy_List (Parameter_Associations (Constructor_Ref))); @@ -3216,6 +3185,40 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); + elsif Present (Constructor_Name (Rec_Type)) then + if Present (Default_Constructor (Rec_Type)) then + -- The 'Make attribute reference (with no arguments) will + -- generate a call to the one-parameter constructor procedure. + + Append_To (Body_Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of + (Defining_Identifier (First (Parameters)), Loc), + Expression => Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rec_Type, Loc), + Attribute_Name => Name_Make))); + else + -- No constructor procedure with an appropriate profile + -- is available, so raise Program_Error. + -- + -- We could instead do nothing here, since the absence of a + -- one-parameter constructor procedure should trigger other + -- legality checks which should statically ensure that + -- the init proc we are constructing here will never be + -- called. So a bit of "belt and suspenders" here. + -- If this raise statement is ever executed, that probably + -- means that some compile-time legality check is not + -- implemented, and that the program should have instead + -- failed to compile. + -- Because this raise statement should never be executed, it + -- seems ok to pass in a dubious Reason parameter instead of + -- declaring a new RT_Exception_Code value. + + Append_To (Body_Stmts, + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise)); + end if; + elsif Nkind (Type_Definition (N)) = N_Record_Definition then Build_Discriminant_Assignments (Body_Stmts); @@ -3310,7 +3313,7 @@ package body Exp_Ch3 is end if; end if; - -- Add here the assignment to instantiate the Tag + -- Add here the assignment to initialize the Tag -- The assignment corresponds to the code: @@ -4170,7 +4173,6 @@ package body Exp_Ch3 is if Present (Parent_Id) then declare Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id)); - use Initialization_Control; begin -- We are building the init proc for a type extension. -- Call the parent type's init proc a second time, this @@ -4558,6 +4560,8 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing). + -- 10. The type has a specified Constructor aspect. + -- Note: the reason we exclude the CPP_Class case is because in this -- case the initialization is performed by the C++ constructors, and -- the IP is built by Set_CPP_Constructors. @@ -4573,6 +4577,7 @@ package body Exp_Ch3 is or else Is_Tagged_Type (Rec_Id) or else Is_Concurrent_Record_Type (Rec_Id) or else Has_Task (Rec_Id) + or else Present (Constructor_Name (Rec_Id)) then return True; end if; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 0b0a2b68642c..69e6cb4ba352 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -27,6 +27,7 @@ with Elists; use Elists; with Exp_Tss; use Exp_Tss; +with Tbuild; use Tbuild; with Types; use Types; with Uintp; use Uintp; @@ -194,6 +195,32 @@ package Exp_Ch3 is -- initialized; if Variable_Comps is True then tags components located at -- variable positions of Target are initialized. + type Initialization_Mode is + (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only); + -- The initialization routine for a tagged type is passed in a + -- formal parameter of this type, indicating what initialization + -- is to be performed. This parameter defaults to Full_Init in all + -- cases except when the init proc of a type extension (let's call + -- that type T2) calls the init proc of its parent (let's call that + -- type T1). In that case, one of the other 3 values will + -- be passed in. In all three of those cases, the Tag component has + -- already been initialized before the call and is therefore not to be + -- modified. T2's init proc will either call T1's init proc + -- once (with Full_Init_Except_Tag as the parameter value) or twice + -- (first with Early_Init_Only, then later with Late_Init_Only), + -- depending on the result returned by Has_Late_Init_Component (T1). + -- In the latter case, the first call does not initialize any + -- components that require late initialization and the second call + -- then performs that deferred initialization. + -- Strictly speaking, the formal parameter subtype is actually Natural + -- but calls will only pass in values corresponding to literals + -- of this enumeration type. + + function Make_Mode_Literal + (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id + is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode))); + -- Generate an integer literal for a given mode value. + procedure Make_Controlling_Function_Wrappers (Tag_Typ : Entity_Id; Decl_List : out List_Id; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1a9002ce3a8b..32e96bed2349 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6244,6 +6244,15 @@ package body Exp_Ch6 is -- returns, since they get eliminated anyway later on. Spec_Id denotes -- the corresponding spec of the subprogram body. + procedure Prepend_Constructor_Procedure_Prologue + (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id); + + -- If N is the body of a constructor procedure (that is, a procedure + -- named in a Constructor aspect specification for the type of the + -- procedure's first parameter), then prepend and analyze the + -- associated initialization code for that parameter. + -- This has nothing to do with CPP constructors. + ---------------- -- Add_Return -- ---------------- @@ -6317,6 +6326,300 @@ package body Exp_Ch6 is end if; end Add_Return; + -------------------------------------------- + -- Prepend_Constructor_Procedure_Prologue -- + -------------------------------------------- + + procedure Prepend_Constructor_Procedure_Prologue + (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id) + is + + function First_Param_Type return Entity_Id is + (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); + + Is_Constructor_Procedure : constant Boolean := + Nkind (Specification (N)) = N_Procedure_Specification + and then Present (First_Formal (Spec_Id)) + and then Present (Constructor_Name (First_Param_Type)) + and then Chars (Spec_Id) = Chars (Constructor_Name + (First_Param_Type)) + and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter + and then Scope (Spec_Id) = Scope (First_Param_Type); + begin + if not Is_Constructor_Procedure then + return; -- the usual case + end if; + + -- Initialize the first parameter. + -- First_Param_Type is a record type (tagged or untagged) or + -- a type extension. If it is a type extension, then we begin by + -- calling the appropriate constructor procedure for the _parent + -- part. In the absence of a Super aspect specification, the + -- "appropriate" constructor is the one that takes only a single + -- parameter (the object being initialized). Additional actual + -- parameters for the constructor call may be provided via a + -- Super aspect specification, in which case a different + -- constructor procedure will be invoked. + -- + -- For each remaining component we first check to see if it + -- is mentioned in the Initialize aspect specification (if any) for + -- Body_Id. If so, then evaluate the expression given for that + -- component in the aspect specification and assign it to the + -- given component of the first parameter. If not, and if an + -- explicit default initial value is provided for the given component + -- in the type declaration, then do the same thing with that + -- expression instead. Otherwise perform normal default + -- initialization for the component - invoke the init proc for the + -- component's type if one exists, and otherwise do nothing. + + -- We do not perform tag initialization here. That is dealt with + -- elsewhere. The init proc for a tagged type is + -- passed an extra parameter indicating whether to perform + -- tag initialization. + + -- In the case of a type (tagged or untagged) that is not + -- an extension, we could just generate a single assignment, + -- taking the RHS from the Initialize aspect value (which is an + -- N_Aggregate node). But that gets complicated in the case of + -- an extension, so we handle all cases one component at a time. + + declare + Initialize_Aspect : constant Node_Id := + Find_Aspect (Body_Id, Aspect_Initialize); + + First_Initialize_Comp_Assoc : constant Node_Id := + (if Present (Initialize_Aspect) + then First (Component_Associations + (Expression (Initialize_Aspect))) + else Empty); + + Component : Entity_Id := First_Entity (First_Param_Type); + Init_List : constant List_Id := New_List; + + function Init_Expression_If_Any (Component : Entity_Id) + return Node_Id; + -- If the given component is mentioned in the Initialize + -- aspect for the constructor procedure, then return the + -- initial value expression specified there. + -- Otherwise, if the component declaration includes an + -- initial value expression, then return that expression. + -- Otherwise, return Empty. + + function Make_Init_Proc_Call (Component : Entity_Id; + Component_Name : Node_Id) + return Node_Id; + -- Builds and returns a call to the init proc for the type of + -- the component in order to initialize the given component. + -- The init proc must exist. + + function Make_Parent_Constructor_Call (Parent_Type : Entity_Id) + return Node_Id; + -- Builds and returns a call to the appropriate constructor + -- procedure of the parent type. + -- This function is called only in the case of a + -- Constructor procedure for a type extension. + + ---------------------------- + -- Init_Expression_If_Any -- + ---------------------------- + + function Init_Expression_If_Any (Component : Entity_Id) + return Node_Id + is + Initialize_Comp_Assoc : Node_Id := First_Initialize_Comp_Assoc; + Choice : Node_Id; + + -- ??? Technically, this is quadratic (linear search called + -- a linear number of times). When/if we see performance + -- problems with hundreds of components mentioned in one + -- Initialize aspect specification, we can revisit this. + begin + while Present (Initialize_Comp_Assoc) loop + Choice := First (Choices (Initialize_Comp_Assoc)); + + while Present (Choice) loop + if Nkind (Choice) = N_Identifier + and then Chars (Choice) = Chars (Component) + then + return Expression (Initialize_Comp_Assoc); + end if; + Next (Choice); + end loop; + + Next (Initialize_Comp_Assoc); + end loop; + + if Present (Expression (Parent (Component))) then + return Expression (Parent (Component)); + end if; + + return Empty; + end Init_Expression_If_Any; + + ------------------------- + -- Make_Init_Proc_Call -- + ------------------------- + + function Make_Init_Proc_Call (Component : Entity_Id; + Component_Name : Node_Id) + return Node_Id + is + Params : constant List_Id := New_List (Component_Name); + Init_Proc : constant Entity_Id := + Base_Init_Proc (Etype (Component)); + begin + if Is_Tagged_Type (Etype (Component)) then + Append (Make_Mode_Literal (Loc, Full_Init), Params); + end if; + + return Init_Proc_Call : constant Node_Id := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Init_Proc, Loc), + Parameter_Associations => Params) + do + pragma Assert (Check_Number_Of_Actuals + (Subp_Call => Init_Proc_Call, + Subp_Id => Init_Proc)); + end return; + end Make_Init_Proc_Call; + + ---------------------------------- + -- Make_Parent_Constructor_Call -- + ---------------------------------- + + function Make_Parent_Constructor_Call (Parent_Type : Entity_Id) + return Node_Id + is + Actual_Parameters : List_Id := No_List; + Super_Aspect : constant Node_Id := + Find_Aspect (Body_Id, Aspect_Super); + + -- Do not confuse the Super aspect with the Super attribute. + -- Both are referenced here, but they are not related as + -- closely as some aspect/attribute homonym pairs are. + -- The attribute takes an object as a prefix. The aspect + -- can be specified for the body of a constructor procedure. + begin + if Present (Super_Aspect) then + declare + Super_Expr : constant Node_Id := + Expression (Super_Aspect); + Expr : Node_Id; + begin + if Nkind (Super_Expr) /= N_Aggregate then + Expr := New_Copy_Tree (Super_Expr); + Set_Paren_Count (Expr, 0); + Actual_Parameters := New_List (Expr); + else + -- Interpret this "aggregate" as a list of + -- actual parameter expressions. + + Actual_Parameters := New_List; + Expr := First (Expressions (Super_Expr)); + while Present (Expr) loop + Append (New_Copy_Tree (Expr), Actual_Parameters); + Next (Expr); + end loop; + end if; + end; + end if; + + -- Build a prefixed-notation call + declare + Proc_Name : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (First_Formal (Spec_Id), Loc), + Attribute_Name => Name_Super), + Selector_Name => + Make_Identifier (Loc, + Chars (Constructor_Name (Parent_Type)))); + begin + Set_Is_Prefixed_Call (Proc_Name); + + return Make_Procedure_Call_Statement (Loc, + Name => Proc_Name, + Parameter_Associations => Actual_Parameters); + end; + end Make_Parent_Constructor_Call; + + begin + while Present (Component) loop + pragma Assert (Ekind (Component) = E_Component); + + if Chars (Component) = Name_uTag then + null; + + elsif Chars (Component) = Name_uParent then + -- ??? Here is where we should be looking for a + -- Super aspect specification in order to call the + -- right constructor with the right parameters + -- (as opposed to unconditionally calling the + -- single-parameter constructor). + Append_To (Init_List, Make_Parent_Constructor_Call + (Parent_Type => Etype (Component))); + + else + declare + Maybe_Init_Exp : constant Node_Id := + Init_Expression_If_Any (Component); + + function Make_Component_Name return Node_Id is + (Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (First_Formal (Spec_Id), Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Component)))); + begin + -- Handle case where initial value for this component + -- is specified either in an Initialize aspect + -- specification or as part of the component declaration. + + if Present (Maybe_Init_Exp) then + -- ??? Should reorganize things so that + -- procedure Build_Assignment in exp_ch3.adb + -- (which is currently declared inside of + -- Build_Record_Init_Proc) can be called from here. + -- That procedure handles some corner cases + -- that are not properly handled here (e.g., + -- mapping current instance references to the + -- appropriate formal parameter). + + if Is_Tagged_Type (Etype (Component)) then + Append_To (Init_List, + Make_Tag_Assignment_From_Type (Loc, + Target => Make_Component_Name, + Typ => Etype (Component))); + end if; + + Append_To (Init_List, + Make_Assignment_Statement (Loc, + Name => Make_Component_Name, + Expression => New_Copy_Tree + (Maybe_Init_Exp, + New_Scope => Body_Id))); + + -- Handle case where component's type has an init proc + elsif Has_Non_Null_Base_Init_Proc (Etype (Component)) then + Append_To (Init_List, + Make_Init_Proc_Call ( + Component => Component, + Component_Name => Make_Component_Name)); + else + pragma Assert (not Is_Tagged_Type (Etype (Component))); + end if; + end; + end if; + + Next_Entity (Component); + end loop; + + Insert_List_Before_And_Analyze (First (L), Init_List); + end; + end Prepend_Constructor_Procedure_Prologue; + -- Local variables Except_H : Node_Id; @@ -6549,6 +6852,12 @@ package body Exp_Ch6 is Detect_Infinite_Recursion (N, Spec_Id); end if; + -- If the subprogram is a constructor procedure then prepend + -- and analyze initialization code. + + Prepend_Constructor_Procedure_Prologue + (Spec_Id => Spec_Id, Body_Id => Body_Id, L => L); + -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 2a92ffbce4f3..e08dc42d903d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5179,10 +5179,8 @@ package body Sem_Attr is when Attribute_Make => declare Expr : Entity_Id; begin - -- Should this be assert? Parsing should fail if it hits 'Make - -- and all extensions aren't enabled ??? - if not All_Extensions_Allowed then + Error_Msg_GNAT_Extension ("Make attribute", Loc); return; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a4f15ac979c1..2166eb318d75 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4464,11 +4464,16 @@ package body Sem_Ch13 is -- Error checking if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; + Error_Msg_GNAT_Extension ("aspect %", Loc); goto Continue; end if; - if Ekind (E) /= E_Procedure then - Error_Msg_N ("Initialize must apply to a constructor", N); + if Ekind (E) /= E_Subprogram_Body + or else Nkind (Parent (E)) /= N_Procedure_Specification + then + Error_Msg_N + ("Initialize must apply to a constructor body", N); end if; if Present (Expressions (Expression (Aspect))) then @@ -4507,11 +4512,6 @@ package body Sem_Ch13 is Next_Entity (Type_Comp); end loop; - -- Push the scope and formals for analysis - - Push_Scope (E); - Install_Formals (Defining_Unit_Name (Specification (N))); - -- Analyze the components Aspect_Comp := @@ -4530,10 +4530,6 @@ package body Sem_Ch13 is Dummy_Aggr := New_Copy_Tree (Expression (Aspect)); Resolve_Aggregate (Dummy_Aggr, Typ); Expander_Active := True; - - -- Return the scope - - End_Scope; end Initialize; -- Initializes @@ -5031,6 +5027,12 @@ package body Sem_Ch13 is goto Continue; when Aspect_Constructor => + if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; + Error_Msg_GNAT_Extension ("aspect %", Loc); + goto Continue; + end if; + Set_Constructor_Name (E, Expr); Set_Needs_Construction (E); @@ -5295,6 +5297,80 @@ package body Sem_Ch13 is -- generated yet because the evaluation of the boolean needs -- to be delayed till the freeze point. + -- Super + + when Aspect_Super => Super : + declare + Analyze_Parameter_Expressions : constant Boolean := True; + -- ??? + -- We can analyze actual parameter expressions here (with + -- no context, like the operand of a type conversion), + -- or leave them unanalyzed for now and catch problems + -- when we analyze the generated constructor call + -- (where overload resolution may provide context that + -- resolves some ambiguities). + -- For now, we analyze them here to avoid depending + -- on legality checking performed during expansion. + -- To reverse this decision, set this flag to False. + + begin + -- Error checking + + if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; + Error_Msg_GNAT_Extension ("aspect %", Loc); + goto Continue; + end if; + + if Ekind (E) /= E_Subprogram_Body + or else Nkind (Parent (E)) /= N_Procedure_Specification + then + Error_Msg_N ("Super must apply to a constructor body", N); + end if; + + -- handle missing parameter list (an error case) + + if No (Expr) then + Error_Msg_N ("constructor parameters required", N); + + -- Handle parameter list of length more than one + -- (such a list is parsed as an aggregate). + + elsif Nkind (Expr) = N_Aggregate then + if Present (Component_Associations (Expr)) + or else No (Expressions (Expr)) + then + Error_Msg_N + ("malformed constructor parameter list", N); + + elsif Analyze_Parameter_Expressions then + declare + Param_Expr : Node_Id := First (Expressions (Expr)); + begin + while Present (Param_Expr) loop + Analyze (Param_Expr); + Next (Param_Expr); + end loop; + + Set_Analyzed (Expr); + -- Someday Vast may complain that this so-called + -- aggregate has no Etype. For now, we mark it + -- as analyzed and hope that nobody trips over it. + end; + end if; + + -- handle parameter list of length one + + elsif Paren_Count (Expr) = 0 then + Error_Msg_N + ("parentheses missing for constructor parameter list ", + N); + + elsif Analyze_Parameter_Expressions then + Analyze (Expr); + end if; + end Super; + when Boolean_Aspects | Library_Unit_Aspects => @@ -5690,7 +5766,9 @@ package body Sem_Ch13 is Set_Declarations (N, New_List); end if; - Prepend (Aitem, Declarations (N)); + if Present (Aitem) then + Prepend (Aitem, Declarations (N)); + end if; elsif Nkind (N) = N_Generic_Package_Declaration then if No (Visible_Declarations (Specification (N))) then @@ -5761,7 +5839,9 @@ package body Sem_Ch13 is -- The pragma is added before source declarations - Prepend_To (Declarations (N), Aitem); + if Present (Aitem) then + Prepend_To (Declarations (N), Aitem); + end if; -- When delay is not required and the context is not a compilation -- unit, we simply insert the pragma/attribute definition clause @@ -11629,7 +11709,7 @@ package body Sem_Ch13 is -- Case of stream attributes and Put_Image, just have to compare -- entities. However, the expression is just a possibly-overloaded -- name, so we need to verify that one of these interpretations is - -- the one available at at the freeze point. + -- the one available at the freeze point. elsif A_Id in Aspect_Constructor | Aspect_Destructor @@ -12221,6 +12301,7 @@ package body Sem_Ch13 is | Aspect_Relaxed_Initialization | Aspect_SPARK_Mode | Aspect_Subprogram_Variant + | Aspect_Super | Aspect_Suppress | Aspect_Test_Case | Aspect_Unimplemented