Aspect_Stream_Size,
Aspect_String_Literal,
Aspect_Subprogram_Variant, -- GNAT
+ Aspect_Super, -- GNAT
Aspect_Suppress,
Aspect_Synchronization,
Aspect_Test_Case, -- GNAT
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,
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,
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,
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,
-- 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);
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
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;
- end if;
-
- -- Identify the enclosing parent for the non-copy cases
-
- 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;
+ if Is_Empty_List (Constructor_Params) then
+ Constructor_Params := New_List;
end if;
- declare
- Base_Obj : Node_Id := Empty;
- Typ_Comp : Entity_Id;
- Agg_Comp : Entity_Id;
- Comp_Nam : Node_Id := Empty;
- 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;
-
- 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;
+ Result_Decl := Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc));
- 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;
- end;
+ -- Suppress default initialization for result object.
+ -- Default init (except for tag, if tagged) will instead be
+ -- performed in the constructor procedure.
- Prepend_To (Params, Obj);
+ Mutate_Ekind (Result_Id, E_Variable);
+ Set_Suppress_Initialization (Result_Id);
- -- Find the constructor we are interested in by doing a
- -- pseudo-pass to resolve the constructor call.
+ -- Build a prefixed-notation call
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);
+ 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
- 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;
+ Set_Is_Prefixed_Call (Proc_Name);
- 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));
+ Constructor_Call := Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Constructor_Params,
+ Name => Proc_Name);
end;
- Analyze_And_Resolve (N, Typ);
-
- -- Finally, insert the constructor call
+ Set_Is_Expanded_Constructor_Call (Constructor_Call, True);
- Construct_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Construct, Loc),
- Parameter_Associations => Params);
+ Constructor_EWA :=
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (Result_Decl, Constructor_Call),
+ Expression => New_Occurrence_Of (Result_Id, Loc));
- Set_Is_Expanded_Constructor_Call (Construct_Call);
- Insert_After (Par, Construct_Call);
+ Rewrite (N, Constructor_EWA);
end;
+ Analyze_And_Resolve (N, Typ);
+
--------------
-- Mantissa --
--------------
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;
-- 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;
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)));
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);
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:
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
-- 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.
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;
with Elists; use Elists;
with Exp_Tss; use Exp_Tss;
+with Tbuild; use Tbuild;
with Types; use Types;
with Uintp; use Uintp;
-- 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;
-- 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 --
----------------
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;
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);
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;
-- 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
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 :=
Dummy_Aggr := New_Copy_Tree (Expression (Aspect));
Resolve_Aggregate (Dummy_Aggr, Typ);
Expander_Active := True;
-
- -- Return the scope
-
- End_Scope;
end Initialize;
-- Initializes
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);
-- 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
=>
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
-- 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
-- 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
| Aspect_Relaxed_Initialization
| Aspect_SPARK_Mode
| Aspect_Subprogram_Variant
+ | Aspect_Super
| Aspect_Suppress
| Aspect_Test_Case
| Aspect_Unimplemented
projects / thirdparty / gcc.git / commitdiff
