The patch implements the experimental constructors RFC. Currently a WIP.
gcc/ada/ChangeLog:
* aspects.ads: Add support for constructors.
* exp_aggr.adb: Likewise.
* exp_attr.adb: Likewise.
* exp_ch3.adb: Likewise.
* exp_ch4.adb: Likewise.
* exp_util.adb: Likewise.
* gen_il-fields.ads: Likewise.
* gen_il-gen-gen_entities.adb: Likewise.
* gen_il-gen-gen_nodes.adb: Likewise.
* par-ch4.adb: Likewise.
* sem_aggr.adb: Likewise.
* sem_attr.adb, sem_attr.ads: Likewise.
* sem_ch13.adb: Likewise.
* sem_ch3.adb: Likewise.
* sem_ch5.adb: Likewise.
* sem_ch6.adb: Likewise.
* sem_res.adb: Likewise.
* sem_util.adb, sem_util.ads: Likewise.
* snames.ads-tmpl: Likewise.
Aspect_Bit_Order,
Aspect_Component_Size,
Aspect_Constant_Indexing,
+ Aspect_Constructor, -- GNAT
Aspect_Contract_Cases, -- GNAT
Aspect_Convention,
Aspect_CPU,
Aspect_GNAT_Annotate, -- GNAT
Aspect_Implicit_Dereference,
Aspect_Initial_Condition, -- GNAT
+ Aspect_Initialize, -- GNAT
Aspect_Initializes, -- GNAT
Aspect_Input,
Aspect_Integer_Literal,
Aspect_Bit_Order => Expression,
Aspect_Component_Size => Expression,
Aspect_Constant_Indexing => Name,
+ Aspect_Constructor => Name,
Aspect_Contract_Cases => Expression,
Aspect_Convention => Name,
Aspect_CPU => Expression,
Aspect_GNAT_Annotate => Expression,
Aspect_Implicit_Dereference => Name,
Aspect_Initial_Condition => Expression,
+ Aspect_Initialize => Expression,
Aspect_Initializes => Expression,
Aspect_Input => Name,
Aspect_Integer_Literal => Name,
Aspect_Component_Size => True,
Aspect_Constant_Indexing => False,
Aspect_Contract_Cases => False,
+ Aspect_Constructor => False,
Aspect_Convention => True,
Aspect_CPU => False,
Aspect_Default_Component_Value => True,
Aspect_GNAT_Annotate => False,
Aspect_Implicit_Dereference => False,
Aspect_Initial_Condition => False,
+ Aspect_Initialize => False,
Aspect_Initializes => False,
Aspect_Input => False,
Aspect_Integer_Literal => False,
Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration,
Aspect_Constant_Indexing => Name_Constant_Indexing,
Aspect_Contract_Cases => Name_Contract_Cases,
+ Aspect_Constructor => Name_Constructor,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
Aspect_CUDA_Device => Name_CUDA_Device,
Aspect_Inline => Name_Inline,
Aspect_Inline_Always => Name_Inline_Always,
Aspect_Initial_Condition => Name_Initial_Condition,
+ Aspect_Initialize => Name_Initialize,
Aspect_Initializes => Name_Initializes,
Aspect_Input => Name_Input,
Aspect_Integer_Literal => Name_Integer_Literal,
Aspect_Asynchronous => Always_Delay,
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
+ Aspect_Constructor => Always_Delay,
Aspect_CPU => Always_Delay,
Aspect_CUDA_Device => Always_Delay,
Aspect_CUDA_Global => Always_Delay,
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Local_Restrictions => Never_Delay,
+ Aspect_Initialize => Never_Delay,
Aspect_Initializes => Never_Delay,
Aspect_Max_Entry_Queue_Length => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay,
Typ : constant Entity_Id := Etype (N);
Dims : constant Nat := Number_Dimensions (Typ);
Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
Static_Components : Boolean := True;
-- components because in this case will need to call the corresponding
-- IP procedure.
- if Has_Default_Init_Comps (N) then
+ if Has_Default_Init_Comps (N)
+ or else Present (Constructor_Name (Ctyp))
+ or else (Is_Access_Type (Ctyp)
+ and then Present
+ (Constructor_Name
+ (Directly_Designated_Type (Ctyp))))
+ then
return;
end if;
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
Analyze_And_Resolve (N, Typ);
+ ----------
+ -- Make --
+ ----------
+
+ 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);
+
+ 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;
+ 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;
+
+ 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;
+
+ Prepend_To (Params, Obj);
+
+ -- Find the constructor we are interested in by doing a
+ -- pseudo-pass to resolve the constructor 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);
+ 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);
+ end;
+
--------------
-- Mantissa --
--------------
Actions := Build_Assignment (Id, Expression (Decl));
end if;
+ -- Expand components with constructors to have the 'Make
+ -- attribute.
+
+ elsif Present (Constructor_Name (Typ))
+ and then Present (Default_Constructor (Typ))
+ then
+ Set_Expression (Decl,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Make,
+ Prefix =>
+ Subtype_Indication
+ (Component_Definition (Decl))));
+ Analyze (Expression (Decl));
+ Actions := Build_Assignment (Id, Expression (Decl));
+
-- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
-- components are filled in with the corresponding rep-item
-- expression of the concurrent type (if any).
procedure Expand_N_Object_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
- Expr : constant Node_Id := Expression (N);
Obj_Def : constant Node_Id := Object_Definition (N);
Typ : constant Entity_Id := Etype (Def_Id);
Base_Typ : constant Entity_Id := Base_Type (Typ);
Next_N : constant Node_Id := Next (N);
+ Expr : Node_Id := Expression (N);
+
Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id);
-- If this is a special return object, it will be allocated differently
-- and ultimately rewritten as a renaming, so initialization activities
-- Don't do anything for deferred constants. All proper actions will be
-- expanded during the full declaration.
- if No (Expr) and Constant_Present (N) then
+ if No (Expr)
+ and then Constant_Present (N)
+ and then (No (Constructor_Name (Typ))
+ or else No (Default_Constructor (Typ)))
+ then
return;
end if;
return;
end if;
+ -- Expand objects with default constructors to have the 'Make
+ -- attribute.
+
+ if Comes_From_Source (N)
+ and then No (Expr)
+ and then Present (Constructor_Name (Typ))
+ and then Present (Default_Constructor (Typ))
+ then
+ Expr := Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Make,
+ Prefix => Object_Definition (N));
+ Set_Expression (N, Expr);
+ Analyze_And_Resolve (Expr);
+ end if;
+
-- Make shared memory routines for shared passive variable
if Is_Shared_Passive (Def_Id) then
Error_Msg_N ("?_a?use of an anonymous access type allocator", N);
end if;
+ -- Here we set no initialization on types with constructors since we
+ -- generate initialization for the separately.
+
+ if Present (Constructor_Name (Directly_Designated_Type (PtrT)))
+ and then Nkind (Expression (N)) = N_Identifier
+ then
+ Set_No_Initialization (N, False);
+ end if;
+
-- RM E.2.2(17). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type.
-- We probably shouldn't be doing this legality check during expansion,
else
N := First (L);
while Present (N) loop
- if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
+ if Nkind (N) = N_Parameter_Association then
+ if not
+ Side_Effect_Free
+ (Explicit_Actual_Parameter (N), Name_Req, Variable_Ref)
+ then
+ return False;
+ end if;
+
+ Next (N);
+ elsif not Side_Effect_Free (N, Name_Req, Variable_Ref) then
return False;
else
Next (N);
Is_Elsif,
Is_Entry_Barrier_Function,
Is_Expanded_Build_In_Place_Call,
+ Is_Expanded_Constructor_Call,
Is_Expanded_Prefixed_Call,
Is_Folded_In_Parser,
Is_Generic_Contract_Pragma,
Component_Clause,
Component_Size,
Component_Type,
+ Constructor_List,
+ Constructor_Name,
Contract,
Contract_Wrapper,
Corresponding_Concurrent_Type,
Modulus,
Must_Be_On_Byte_Boundary,
Must_Have_Preelab_Init,
+ Needs_Construction,
Needs_Debug_Info,
Needs_No_Actuals,
Never_Set_In_Source,
Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
Sm (Class_Wide_Equivalent_Type, Node_Id),
Sm (Class_Wide_Type, Node_Id),
+ Sm (Constructor_List, Elist_Id),
+ Sm (Constructor_Name, Node_Id),
Sm (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
Sm (Derived_Type_Link, Node_Id),
Sm (Linker_Section_Pragma, Node_Id),
Sm (Must_Be_On_Byte_Boundary, Flag),
Sm (Must_Have_Preelab_Init, Flag),
+ Sm (Needs_Construction, Flag),
Sm (No_Tagged_Streams_Pragma, Node_Id,
Pre => "Is_Tagged_Type (N)"),
Sm (Non_Binary_Modulus, Flag, Base_Type_Only),
Sm (Is_Known_Guaranteed_ABE, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (No_Elaboration_Check, Flag),
+ Sm (Is_Expanded_Constructor_Call, Flag),
Sm (Is_Expanded_Prefixed_Call, Flag)));
Cc (N_Function_Call, N_Subprogram_Call,
Explicit_Actual_Parameter => Rnam));
exit;
+ -- 'Make is a special attribute that takes a variable
+ -- amount of parameters.
+
+ elsif All_Extensions_Allowed
+ and then Attr_Name = Name_Make
+ then
+ Scan;
+ Rnam := P_Expression;
+ Append_To (Expressions (Name_Node),
+ Make_Parameter_Association (Sloc (Rnam),
+ Selector_Name => Expr,
+ Explicit_Actual_Parameter => Rnam));
+ exit;
+
-- For all other cases named notation is illegal
else
function P_Allocator return Node_Id is
Alloc_Node : Node_Id;
- Type_Node : Node_Id;
Null_Exclusion_Present : Boolean;
+ Scan_State : Saved_Scan_State;
+ Type_Node : Node_Id;
begin
Alloc_Node := New_Node (N_Allocator, Token_Ptr);
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
+
+ -- Check for 'Make
+
+ if All_Extensions_Allowed
+ and then Token = Tok_Identifier
+ then
+ Save_Scan_State (Scan_State);
+ Type_Node := P_Qualified_Simple_Name_Resync;
+ if Token = Tok_Apostrophe then
+ Scan;
+ if Token_Name = Name_Make then
+ Restore_Scan_State (Scan_State);
+ Set_Expression
+ (Alloc_Node,
+ Make_Qualified_Expression (Token_Ptr,
+ Subtype_Mark => Check_Subtype_Mark (Type_Node),
+ Expression => P_Expression_Or_Range_Attribute));
+ return Alloc_Node;
+ end if;
+ end if;
+ Restore_Scan_State (Scan_State);
+ end if;
+
+ -- Otherwise continue parsing the subtype
+
Type_Node := P_Subtype_Mark_Resync;
if Token = Tok_Apostrophe then
-- Check the dimensions of the components in the record aggregate
Analyze_Dimension_Extension_Or_Record_Aggregate (N);
+
+ -- Do a pass for constructors which rely on things being fully expanded
+
+ declare
+ function Resolve_Make_Expr (N : Node_Id) return Traverse_Result;
+ -- Recurse in the aggregate and resolve references to 'Make
+
+ function Resolve_Make_Expr (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Make
+ then
+ Set_Analyzed (N, False);
+ Resolve (N);
+ end if;
+
+ return OK;
+ end Resolve_Make_Expr;
+
+ procedure Search_And_Resolve_Make_Expr is new
+ Traverse_Proc (Resolve_Make_Expr);
+ begin
+ Search_And_Resolve_Make_Expr (N);
+ end;
end Resolve_Record_Aggregate;
-----------------------------
E1 := Empty;
E2 := Empty;
- else
+ elsif Aname /= Name_Make then
E1 := First (Exprs);
-- Skip analysis for case of Restriction_Set, we do not expect
Check_Not_Incomplete_Type;
Set_Etype (N, Universal_Integer);
+ ----------
+ -- Make --
+ ----------
+
+ 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
+ return;
+ end if;
+
+ Set_Etype (N, Etype (P));
+
+ if Present (Expressions (N)) then
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Parameter_Association then
+ Analyze (Explicit_Actual_Parameter (Expr));
+ else
+ Analyze (Expr);
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+ end;
+
--------------
-- Mantissa --
--------------
Set_Etype (N, C_Type);
return;
+ -- Handle 'Make constructor calls
+
+ elsif All_Extensions_Allowed
+ and then Id = Attribute_Make
+ then
+ P_Type := P_Entity;
+
-- No other cases are foldable (they certainly aren't static, and at
-- the moment we don't try to fold any cases other than the ones above).
-- If either attribute or the prefix is Any_Type, then propagate
-- Any_Type to the result and don't do anything else at all.
- if P_Type = Any_Type
+ if Id /= Attribute_Make
+ and then (P_Type = Any_Type
or else (Present (E1) and then Etype (E1) = Any_Type)
- or else (Present (E2) and then Etype (E2) = Any_Type)
+ or else (Present (E2) and then Etype (E2) = Any_Type))
then
Set_Etype (N, Any_Type);
return;
Static := False;
Set_Is_Static_Expression (N, False);
- elsif Id /= Attribute_Max_Alignment_For_Allocation then
+ elsif Id not in Attribute_Max_Alignment_For_Allocation
+ | Attribute_Make
+ then
if not Is_Constrained (P_Type)
or else (Id /= Attribute_First and then
Id /= Attribute_Last and then
-- of the expressions to be scalar in order for the attribute to be
-- considered to be static.
- declare
- E : Node_Id;
+ if Id /= Attribute_Make then
+ declare
+ E : Node_Id;
- begin
- E := E1;
+ begin
+ E := E1;
- while Present (E) loop
+ while Present (E) loop
- -- If expression is not static, then the attribute reference
- -- result certainly cannot be static.
+ -- If expression is not static, then the attribute reference
+ -- result certainly cannot be static.
- if not Is_Static_Expression (E) then
- Static := False;
- Set_Is_Static_Expression (N, False);
- end if;
+ if not Is_Static_Expression (E) then
+ Static := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
- if Raises_Constraint_Error (E) then
- Set_Raises_Constraint_Error (N);
- end if;
+ if Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
+ end if;
- -- If the result is not known at compile time, or is not of
- -- a scalar type, then the result is definitely not static,
- -- so we can quit now.
+ -- If the result is not known at compile time, or is not of
+ -- a scalar type, then the result is definitely not static,
+ -- so we can quit now.
- if not Compile_Time_Known_Value (E)
- or else not Is_Scalar_Type (Etype (E))
- then
- Check_Expressions;
- return;
+ if not Compile_Time_Known_Value (E)
+ or else not Is_Scalar_Type (Etype (E))
+ then
+ Check_Expressions;
+ return;
- -- If the expression raises a constraint error, then so does
- -- the attribute reference. We keep going in this case because
- -- we are still interested in whether the attribute reference
- -- is static even if it is not static.
+ -- If the expression raises a constraint error, then so does
+ -- the attribute reference. We keep going in this case because
+ -- we are still interested in whether the attribute reference
+ -- is static even if it is not static.
- elsif Raises_Constraint_Error (E) then
- Set_Raises_Constraint_Error (N);
- end if;
+ elsif Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
+ end if;
- Next (E);
- end loop;
+ Next (E);
+ end loop;
- if Raises_Constraint_Error (Prefix (N)) then
- Set_Is_Static_Expression (N, False);
- return;
- end if;
- end;
+ if Raises_Constraint_Error (Prefix (N)) then
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+ end;
+ end if;
-- Deal with the case of a static attribute reference that raises
-- constraint error. The Raises_Constraint_Error flag will already
end if;
end Machine_Size;
+ ----------
+ -- Make --
+ ----------
+
+ when Attribute_Make =>
+ Set_Etype (N, Etype (Prefix (N)));
+
--------------
-- Mantissa --
--------------
-- If this is still an attribute reference, then it has not been folded
-- and that means that its expressions are in a non-static context.
- elsif Nkind (N) = N_Attribute_Reference then
+ elsif Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) /= Name_Make
+ then
Check_Expressions;
-- Note: the else case not covered here are odd cases where the
if Expander_Active
and then Present (Expressions (N))
+ and then Attr_Id /= Attribute_Make
then
declare
Expr : Node_Id := First (Expressions (N));
-- This attribute is identical to the Object_Size attribute. It is
-- provided for compatibility with the DEC attribute of this name.
+ ----------
+ -- Make --
+ ----------
+
+ Attribute_Make => True,
+
----------------------
-- Max_Integer_Size --
----------------------
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
goto Continue;
end Initial_Condition;
+ -- Initialize
+
+ when Aspect_Initialize => Initialize : declare
+ Aspect_Comp : Node_Id;
+ Type_Comp : Node_Id;
+ Typ : Entity_Id;
+ Dummy_Aggr : Node_Id;
+ begin
+ -- Error checking
+
+ if not All_Extensions_Allowed then
+ goto Continue;
+ end if;
+
+ if Ekind (E) /= E_Procedure then
+ Error_Msg_N ("Initialize must apply to a constructor", N);
+ end if;
+
+ if Present (Expressions (Expression (Aspect))) then
+ Error_Msg_N ("only component associations allowed", N);
+ end if;
+
+ -- Install the others for the aggregate if necessary
+
+ Typ := Etype (First_Entity (E));
+
+ if No (First_Entity (Typ)) then
+ Error_Msg_N
+ ("Initialize can only apply to contructors"
+ & " whose type has one or more components", N);
+ end if;
+
+ Aspect_Comp :=
+ First (Component_Associations (Expression (Aspect)));
+ Type_Comp := First_Entity (Typ);
+ while Present (Type_Comp) loop
+ if No (Aspect_Comp) then
+ Append_To
+ (Component_Associations (Expression (Aspect)),
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Others_Choice (Loc)),
+ Box_Present => True));
+ exit;
+ elsif Nkind (First (Choices (Aspect_Comp)))
+ = N_Others_Choice
+ then
+ exit;
+ end if;
+
+ Next (Aspect_Comp);
+ 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 :=
+ First (Component_Associations (Expression (Aspect)));
+ while Present (Aspect_Comp) loop
+ if Present (Expression (Aspect_Comp)) then
+ Analyze (Expression (Aspect_Comp));
+ end if;
+
+ Next (Aspect_Comp);
+ end loop;
+
+ -- Do a psuedo pass over the aggregate to ensure it is valid
+
+ Expander_Active := False;
+ Dummy_Aggr := New_Copy_Tree (Expression (Aspect));
+ Resolve_Aggregate (Dummy_Aggr, Typ);
+ Expander_Active := True;
+
+ -- Return the scope
+
+ End_Scope;
+ end Initialize;
+
-- Initializes
-- Aspect Initializes is never delayed because it is equivalent
Analyze_Aspect_Implicit_Dereference;
goto Continue;
+ when Aspect_Constructor =>
+ Set_Constructor_Name (E, Expr);
+ Set_Needs_Construction (E);
+
-- Dimension
when Aspect_Dimension =>
-- name, so we need to verify that one of these interpretations is
-- the one available at at the freeze point.
- elsif A_Id in Aspect_Input
+ elsif A_Id in Aspect_Constructor
+ | Aspect_Input
| Aspect_Output
| Aspect_Read
| Aspect_Write
-- Special case, the expression of these aspects is just an entity
-- that does not need any resolution, so just analyze.
- when Aspect_Input
+ when Aspect_Constructor
+ | Aspect_Input
| Aspect_Output
| Aspect_Put_Image
| Aspect_Read
| Aspect_GNAT_Annotate
| Aspect_Implicit_Dereference
| Aspect_Initial_Condition
+ | Aspect_Initialize
| Aspect_Initializes
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length
=>
null;
+ when Aspect_Constructor =>
+ null;
+
when Aspect_Dynamic_Predicate
| Aspect_Ghost_Predicate
| Aspect_Predicate
Propagate_Concurrent_Flags (T, Etype (Component));
+ -- Propagate information about constructor dependence
+
+ if Ekind (Etype (Component)) /= E_Void
+ and then Needs_Construction (Etype (Component))
+ then
+ Set_Needs_Construction (T);
+ end if;
+
if Ekind (Component) /= E_Component then
null;
if In_Inlined_Body then
null;
- elsif not Is_Variable (Lhs) then
+ elsif not Is_Variable (Lhs)
+ and then not (not Comes_From_Source (Lhs)
+ and then Nkind (Lhs) in N_Has_Etype
+ and then Needs_Construction (Etype (Lhs)))
+ then
-- Ada 2005 (AI-327): Check assignment to the attribute Priority of a
-- protected object.
End_Scope;
+ -- Register the subprogram in a Constructor_List when it is a valid
+ -- constructor.
+
+ if All_Extensions_Allowed
+ and then Present (First_Formal (Designator))
+ then
+
+ declare
+ First_Form_Type : constant Entity_Id :=
+ Etype (First_Formal (Designator));
+
+ Construct : Elmt_Id;
+ begin
+ -- Valid constructors have a "controlling" formal of a type
+ -- with the Constructor aspect specified. Additionally, the
+ -- subprogram name must match value described by the aspect.
+
+ -- Additionally, constructor declarations must exist within the
+ -- same scope as the type declaration and before the type is
+ -- frozen.
+
+ -- For example:
+ --
+ -- type Foo is null record with Constructor => Bar;
+ --
+ -- procedure Bar (Self : in out Foo);
+ --
+
+ if Present (Constructor_Name (First_Form_Type))
+ and then Current_Scope = Scope (First_Form_Type)
+ and then Chars (Constructor_Name (First_Form_Type))
+ = Chars (Designator)
+ and then Ekind (Designator) = E_Procedure
+ and then Nkind (Parent (N)) = N_Subprogram_Declaration
+ then
+ -- If the constructor list is empty than we don't have to
+ -- look for duplicates - we simply create the list and
+ -- add it.
+
+ if No (Constructor_List (First_Form_Type)) then
+ Set_Constructor_List
+ (First_Form_Type, New_Elmt_List (Designator));
+
+ -- Otherwise, we need to check the constructor hasen't
+ -- already been added (e.g. a specification and body) and
+ -- that there isn't a constructor with the same number of
+ -- type of formals.
+
+ -- NOTE: The Constructor_List is sorted by the number of
+ -- parameters.
+
+ else
+ Construct := First_Elmt
+ (Constructor_List (First_Form_Type));
+
+ -- Skip over constructors with less than the number of
+ -- parameters than Designator ???
+
+ -- Loop through the constructors looking for ones which
+ -- "match."
+
+ Outter : loop
+
+ -- When we are at the end of the constructor list we
+ -- know there are no matches, so it is safe to add.
+
+ if No (Construct) then
+ Append_Elmt
+ (Designator,
+ Constructor_List (First_Form_Type));
+ exit Outter;
+ end if;
+
+ -- Loop through the formals and check the formals
+ -- match on type ???
+
+ Next_Elmt (Construct);
+ end loop Outter;
+ end if;
+ end if;
+ end;
+ end if;
+
-- The subprogram scope is pushed and popped around the processing of
-- the return type for consistency with call above to Process_Formals
-- (which itself can call Analyze_Return_Type), and to ensure that any
if not Is_OK_Variable_For_Out_Formal (A)
and then not Is_Init_Proc (Nam)
+ and then not Is_Expanded_Constructor_Call (N)
then
Error_Msg_NE ("actual for& must be a variable", A, F);
and then not Preanalysis_Active
and then not Is_Imported (E)
and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
+ and then not Needs_Construction (Etype (E))
then
if No_Initialization (Parent (E))
or else (Present (Full_View (E))
return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ);
end CW_Or_Needs_Finalization;
+ -------------------------
+ -- Default_Constructor --
+ -------------------------
+
+ function Default_Constructor (Typ : Entity_Id) return Entity_Id is
+ Construct : Elmt_Id;
+ begin
+ pragma Assert (Is_Type (Typ));
+ if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then
+ return Empty;
+ end if;
+
+ Construct := First_Elmt (Constructor_List (Typ));
+ while Present (Construct) loop
+ if Parameter_Count (Elists.Node (Construct)) = 1 then
+ return Elists.Node (Construct);
+ end if;
+
+ Next_Elmt (Construct);
+ end loop;
+
+ return Empty;
+ end Default_Constructor;
+
---------------------
-- Defining_Entity --
---------------------
end if;
if Nkind (P) = N_Selected_Component
+ -- and then Ekind (Entity (Selector_Name (P)))
+ -- in Record_Field_Kind
and then Present (Entry_Formal (Entity (Selector_Name (P))))
then
-- Case of a reference to an entry formal
return Empty;
end Param_Entity;
+ ---------------------
+ -- Parameter_Count --
+ ---------------------
+
+ function Parameter_Count (Subp : Entity_Id) return Nat is
+ Result : Nat := 0;
+ Param : Entity_Id;
+ begin
+ Param := First_Entity (Subp);
+ while Present (Param) loop
+ Result := Result + 1;
+
+ Param := Next_Entity (Param);
+ end loop;
+
+ return Result;
+ end Parameter_Count;
+
----------------------
-- Policy_In_Effect --
----------------------
-- as Needs_Finalization except with pragma Restrictions (No_Finalization),
-- in which case we know that class-wide objects do not need finalization.
+ function Default_Constructor (Typ : Entity_Id) return Entity_Id;
+ -- Determine the default constructor (e.g. the constructor with only one
+ -- formal parameter) for a given type Typ.
+
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
-- WARNING: this routine should be used in debugging scenarios such as
-- tracking down undefined symbols as it is fairly low level.
+ function Parameter_Count (Subp : Entity_Id) return Nat;
+ -- Return the number of parameters for a given subprogram Subp.
+
function Param_Entity (N : Node_Id) return Entity_Id;
-- Given an expression N, determines if the expression is a reference
-- to a formal (of a subprogram or entry), and if so returns the Id
-- Names of aspects for which there are no matching pragmas or attributes
-- so that they need to be included for aspect specification use.
+ Name_Constructor : constant Name_Id := N + $;
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
Name_Designated_Storage_Model : constant Name_Id := N + $;
Name_Img : constant Name_Id := N + $; -- GNAT
Name_Input : constant Name_Id := N + $;
Name_Machine : constant Name_Id := N + $;
+ Name_Make : constant Name_Id := N + $; -- GNAT
Name_Max : constant Name_Id := N + $;
Name_Min : constant Name_Id := N + $;
Name_Model : constant Name_Id := N + $;
Attribute_Img,
Attribute_Input,
Attribute_Machine,
+ Attribute_Make,
Attribute_Max,
Attribute_Min,
Attribute_Model,
projects / thirdparty / gcc.git / commitdiff
