with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
-- This function uses the discriminants of a type to build a list of
- -- formal parameters, used in the following function. If the flag Use_Dl
- -- is set, the list is built using the already defined discriminals
- -- of the type. Otherwise new identifiers are created, with the source
- -- names of the discriminants.
+ -- formal parameters, used in Build_Init_Procedure among other places.
+ -- If the flag Use_Dl is set, the list is built using the already
+ -- defined discriminals of the type, as is the case for concurrent
+ -- types with discriminants. Otherwise new identifiers are created,
+ -- with the source names of the discriminants.
function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
-- This function builds a static aggregate that can serve as the initial
-- _controller of type Record_Controller or Limited_Record_Controller
-- in the record T.
- procedure Freeze_Array_Type (N : Node_Id);
+ procedure Expand_Freeze_Array_Type (N : Node_Id);
-- Freeze an array type. Deals with building the initialization procedure,
-- creating the packed array type for a packed array and also with the
-- creation of the controlling procedures for the controlled case. The
-- argument N is the N_Freeze_Entity node for the type.
- procedure Freeze_Enumeration_Type (N : Node_Id);
+ procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
-- Freeze enumeration type with non-standard representation. Builds the
-- array and function needed to convert between enumeration pos and
-- enumeration representation values. N is the N_Freeze_Entity node
-- for the type.
- procedure Freeze_Record_Type (N : Node_Id);
+ procedure Expand_Freeze_Record_Type (N : Node_Id);
-- Freeze record type. Builds all necessary discriminant checking
-- and other ancillary functions, and builds dispatch tables where
-- needed. The argument N is the N_Freeze_Entity node. This processing
-- 1. Initialization is suppressed for the type
-- 2. The type is a value type, in the CIL sense.
- -- 3. An initialization already exists for the base type
+ -- 3. The type has CIL/JVM convention.
+ -- 4. An initialization already exists for the base type
if Suppress_Init_Proc (A_Type)
or else Is_Value_Type (Comp_Type)
+ or else Convention (A_Type) = Convention_CIL
+ or else Convention (A_Type) = Convention_Java
or else Present (Base_Init_Proc (A_Type))
then
return;
Set_Init_Proc (A_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
- and then Nkind (First (Body_Stmts)) = N_Null_Statement
+
+ -- We must skip SCIL nodes because they may have been added to this
+ -- list by Insert_Actions.
+
+ and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
then
Set_Is_Null_Init_Proc (Proc_Id);
Set_Static_Initialization
(Proc_Id,
- Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
+ Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
end if;
end if;
end Build_Array_Init_Proc;
Parameter_List : constant List_Id := New_List;
D : Entity_Id;
Formal : Entity_Id;
+ Formal_Type : Entity_Id;
Param_Spec_Node : Node_Id;
begin
if Use_Dl then
Formal := Discriminal (D);
+ Formal_Type := Etype (Formal);
else
Formal := Make_Defining_Identifier (Loc, Chars (D));
+ Formal_Type := Etype (D);
end if;
Param_Spec_Node :=
Make_Parameter_Specification (Loc,
Defining_Identifier => Formal,
Parameter_Type =>
- New_Reference_To (Etype (D), Loc));
+ New_Reference_To (Formal_Type, Loc));
Append (Param_Spec_Node, Parameter_List);
Next_Discriminant (D);
end loop;
---------------------------------------
function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
- Agg : Node_Id;
- Comp : Entity_Id;
+ Agg : Node_Id;
+ Comp : Entity_Id;
+ Comp_Type : Entity_Id;
-- Start of processing for Build_Equivalent_Record_Aggregate
-- aggregate with static components.
if Is_Array_Type (Etype (Comp)) then
- declare
- Comp_Type : constant Entity_Id := Component_Type (Etype (Comp));
+ Comp_Type := Component_Type (Etype (Comp));
- begin
- if Nkind (Parent (Comp)) /= N_Component_Declaration
- or else No (Expression (Parent (Comp)))
- or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
- then
- Initialization_Warning (T);
- return Empty;
-
- elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
- and then
- (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
- or else not Compile_Time_Known_Value
- (Type_High_Bound (Comp_Type)))
- then
- Initialization_Warning (T);
- return Empty;
+ if Nkind (Parent (Comp)) /= N_Component_Declaration
+ or else No (Expression (Parent (Comp)))
+ or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
+ then
+ Initialization_Warning (T);
+ return Empty;
- elsif
- not Static_Array_Aggregate (Expression (Parent (Comp)))
- then
- Initialization_Warning (T);
- return Empty;
- end if;
- end;
+ elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
+ and then
+ (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
+ or else
+ not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
+ then
+ Initialization_Warning (T);
+ return Empty;
+
+ elsif
+ not Static_Array_Aggregate (Expression (Parent (Comp)))
+ then
+ Initialization_Warning (T);
+ return Empty;
+ end if;
elsif Is_Scalar_Type (Etype (Comp)) then
+ Comp_Type := Etype (Comp);
+
if Nkind (Parent (Comp)) /= N_Component_Declaration
or else No (Expression (Parent (Comp)))
or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
+ or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
+ or else not
+ Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
then
Initialization_Warning (T);
return Empty;
Next_Component (Comp);
end loop;
- -- All components have static initialization. Build positional
- -- aggregate from the given expressions or defaults.
+ -- All components have static initialization. Build positional aggregate
+ -- from the given expressions or defaults.
Agg := Make_Aggregate (Sloc (T), New_List, New_List);
Set_Parent (Agg, Parent (T));
Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
end if;
+ pragma Assert (Present (Proc));
Init_Type := Etype (First_Formal (Proc));
Full_Init_Type := Underlying_Type (Init_Type);
if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars)
or else Is_Value_Type (Typ)
- or else Is_Value_Type (Component_Type (Typ))
+ or else
+ (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ)))
then
return Empty_List;
end if;
end if;
-- Ada 2005 (AI-287): In case of default initialized components,
- -- we need to generate the corresponding selected component node
- -- to access the discriminant value. In other cases this is not
- -- required because we are inside the init proc and we use the
- -- corresponding formal.
+ -- if the component is constrained with a discriminant of the
+ -- enclosing type, we need to generate the corresponding selected
+ -- component node to access the discriminant value. In other cases
+ -- this is not required, either because we are inside the init
+ -- proc and we use the corresponding formal, or else because the
+ -- component is constrained by an expression.
if With_Default_Init
and then Nkind (Id_Ref) = N_Selected_Component
and then Nkind (Arg) = N_Identifier
+ and then Ekind (Entity (Arg)) = E_Discriminant
then
Append_To (Args,
Make_Selected_Component (Loc,
-- Take a copy of Exp to ensure that later copies of this component
-- declaration in derived types see the original tree, not a node
- -- rewritten during expansion of the init_proc.
+ -- rewritten during expansion of the init_proc. If the copy contains
+ -- itypes, the scope of the new itypes is the init_proc being built.
- Exp := New_Copy_Tree (Exp);
+ Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
Res := New_List (
Make_Assignment_Statement (Loc,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
+ Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)),
end if;
-- Adjust the component if controlled except if it is an aggregate
- -- that will be expanded inline
+ -- that will be expanded inline.
if Kind = N_Qualified_Expression then
Kind := Nkind (Expression (N));
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
and then not Is_Inherently_Limited_Type (Typ)
then
- Append_List_To (Res,
- Make_Adjust_Call (
- Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id),
- Flist_Ref =>
- Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
- With_Attach => Make_Integer_Literal (Loc, 1)));
+ declare
+ Ref : constant Node_Id :=
+ New_Copy_Tree (Lhs, New_Scope => Proc_Id);
+ begin
+ Append_List_To (Res,
+ Make_Adjust_Call (
+ Ref => Ref,
+ Typ => Etype (Id),
+ Flist_Ref => Find_Final_List (Etype (Id), Ref),
+ With_Attach => Make_Integer_Literal (Loc, 1)));
+ end;
end if;
return Res;
D := First_Discriminant (Rec_Type);
while Present (D) loop
+
-- Don't generate the assignment for discriminants in derived
-- tagged types if the discriminant is a renaming of some
-- ancestor discriminant. This initialization will be done
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+ -- Generate the SCIL node associated with the initialization of
+ -- the tag component.
+
+ if Generate_SCIL then
+ declare
+ New_Node : Node_Id;
+
+ begin
+ New_Node :=
+ Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List)));
+ Set_SCIL_Related_Node (New_Node, First (Init_Tags_List));
+ Set_SCIL_Entity (New_Node, Rec_Type);
+ Prepend_To (Init_Tags_List, New_Node);
+ end;
+ end if;
+
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
-- variable size components are initialized later ---see below).
Set_Init_Proc (Rec_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
- and then Nkind (First (Body_Stmts)) = N_Null_Statement
- and then VM_Target /= CLI_Target
+
+ -- We must skip SCIL nodes because they may have been added to this
+ -- list by Insert_Actions.
+
+ and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
+ and then VM_Target = No_VM
then
-- Even though the init proc may be null at this time it might get
- -- some stuff added to it later by the CIL backend, so always keep
- -- it when VM_Target = CLI_Target.
+ -- some stuff added to it later by the VM backend.
Set_Is_Null_Init_Proc (Proc_Id);
end if;
Stmts :=
Build_Initialization_Call
(Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ,
- In_Init_Proc => True,
- Enclos_Type => Rec_Type,
- Discr_Map => Discr_Map,
+ Id_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ => Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map,
Constructor_Ref => Expression (Decl));
else
Stmts := Build_Assignment (Id, Expression (Decl));
Stmts :=
Build_Initialization_Call
(Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ,
+ Id_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ => Typ,
In_Init_Proc => True,
- Enclos_Type => Rec_Type,
- Discr_Map => Discr_Map);
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map);
Clean_Task_Names (Typ, Proc_Id);
Next_Non_Pragma (Decl);
end loop;
- if Per_Object_Constraint_Components then
-
- -- Second pass: components with per-object constraints
-
- Decl := First_Non_Pragma (Component_Items (Comp_List));
- while Present (Decl) loop
- Loc := Sloc (Decl);
- Id := Defining_Identifier (Decl);
- Typ := Etype (Id);
-
- if Has_Access_Constraint (Id)
- and then No (Expression (Decl))
- then
- if Has_Non_Null_Base_Init_Proc (Typ) then
- Append_List_To (Statement_List,
- Build_Initialization_Call (Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ,
- In_Init_Proc => True,
- Enclos_Type => Rec_Type,
- Discr_Map => Discr_Map));
-
- Clean_Task_Names (Typ, Proc_Id);
-
- elsif Component_Needs_Simple_Initialization (Typ) then
- Append_List_To (Statement_List,
- Build_Assignment
- (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
- end if;
- end if;
-
- Next_Non_Pragma (Decl);
- end loop;
- end if;
-
- -- Process the variant part
-
- if Present (Variant_Part (Comp_List)) then
- Alt_List := New_List;
- Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
- while Present (Variant) loop
- Loc := Sloc (Variant);
- Append_To (Alt_List,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_Copy_List (Discrete_Choices (Variant)),
- Statements =>
- Build_Init_Statements (Component_List (Variant))));
- Next_Non_Pragma (Variant);
- end loop;
-
- -- The expression of the case statement which is a reference
- -- to one of the discriminants is replaced by the appropriate
- -- formal parameter of the initialization procedure.
-
- Append_To (Statement_List,
- Make_Case_Statement (Loc,
- Expression =>
- New_Reference_To (Discriminal (
- Entity (Name (Variant_Part (Comp_List)))), Loc),
- Alternatives => Alt_List));
- end if;
+ -- Set up tasks and protected object support. This needs to be done
+ -- before any component with a per-object access discriminant
+ -- constraint, or any variant part (which may contain such
+ -- components) is initialized, because the initialization of these
+ -- components may reference the enclosing concurrent object.
-- For a task record type, add the task create call and calls
-- to bind any interrupt (signal) entries.
end if;
end if;
+ if Per_Object_Constraint_Components then
+
+ -- Second pass: components with per-object constraints
+
+ Decl := First_Non_Pragma (Component_Items (Comp_List));
+ while Present (Decl) loop
+ Loc := Sloc (Decl);
+ Id := Defining_Identifier (Decl);
+ Typ := Etype (Id);
+
+ if Has_Access_Constraint (Id)
+ and then No (Expression (Decl))
+ then
+ if Has_Non_Null_Base_Init_Proc (Typ) then
+ Append_List_To (Statement_List,
+ Build_Initialization_Call (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map));
+
+ Clean_Task_Names (Typ, Proc_Id);
+
+ elsif Component_Needs_Simple_Initialization (Typ) then
+ Append_List_To (Statement_List,
+ Build_Assignment
+ (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
+ end if;
+ end if;
+
+ Next_Non_Pragma (Decl);
+ end loop;
+ end if;
+
+ -- Process the variant part
+
+ if Present (Variant_Part (Comp_List)) then
+ Alt_List := New_List;
+ Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (Variant) loop
+ Loc := Sloc (Variant);
+ Append_To (Alt_List,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List (Discrete_Choices (Variant)),
+ Statements =>
+ Build_Init_Statements (Component_List (Variant))));
+ Next_Non_Pragma (Variant);
+ end loop;
+
+ -- The expression of the case statement which is a reference
+ -- to one of the discriminants is replaced by the appropriate
+ -- formal parameter of the initialization procedure.
+
+ Append_To (Statement_List,
+ Make_Case_Statement (Loc,
+ Expression =>
+ New_Reference_To (Discriminal (
+ Entity (Name (Variant_Part (Comp_List)))), Loc),
+ Alternatives => Alt_List));
+ end if;
+
-- If no initializations when generated for component declarations
-- corresponding to this Statement_List, append a null statement
-- to the Statement_List to make it a valid Ada tree.
-- object being initialized. This is because the call is not a
-- source level call. This works fine, because the only possible
-- statements depending on freeze status that can appear after the
- -- _Init call are rep clauses which can safely appear after actual
- -- references to the object.
+ -- Init_Proc call are rep clauses which can safely appear after
+ -- actual references to the object. Note that this call may
+ -- subsequently be removed (if a pragma Import is encountered),
+ -- or moved to the freeze actions for the object (e.g. if an
+ -- address clause is applied to the object, causing it to get
+ -- delayed freezing).
Id_Ref := New_Reference_To (Def_Id, Loc);
Set_Must_Not_Freeze (Id_Ref);
return;
- else
- -- In most cases, we must check that the initial value meets any
- -- constraint imposed by the declared type. However, there is one
- -- very important exception to this rule. If the entity has an
- -- unconstrained nominal subtype, then it acquired its constraints
- -- from the expression in the first place, and not only does this
- -- mean that the constraint check is not needed, but an attempt to
- -- perform the constraint check can cause order of elaboration
- -- problems.
+ -- Ada 2005 (AI-251): Rewrite the expression that initializes a
+ -- class-wide object to ensure that we copy the full object,
+ -- unless we are targetting a VM where interfaces are handled by
+ -- VM itself. Note that if the root type of Typ is an ancestor
+ -- of Expr's type, both types share the same dispatch table and
+ -- there is no need to displace the pointer.
- if not Is_Constr_Subt_For_U_Nominal (Typ) then
-
- -- If this is an allocator for an aggregate that has been
- -- allocated in place, delay checks until assignments are
- -- made, because the discriminants are not initialized.
+ elsif Comes_From_Source (N)
+ and then Is_Interface (Typ)
+ then
+ pragma Assert (Is_Class_Wide_Type (Typ));
- if Nkind (Expr) = N_Allocator
- and then No_Initialization (Expr)
- then
- null;
- else
- Apply_Constraint_Check (Expr, Typ);
- end if;
- end if;
+ -- If the object is a return object of an inherently limited type,
+ -- which implies build-in-place treatment, bypass the special
+ -- treatment of class-wide interface initialization below. In this
+ -- case, the expansion of the return statement will take care of
+ -- creating the object (via allocator) and initializing it.
- -- Ada 2005 (AI-251): Rewrite the expression that initializes a
- -- class-wide object to ensure that we copy the full object,
- -- unless we are targetting a VM where interfaces are handled by
- -- VM itself. Note that if the root type of Typ is an ancestor
- -- of Expr's type, both types share the same dispatch table and
- -- there is no need to displace the pointer.
-
- -- Replace
- -- CW : I'Class := Obj;
- -- by
- -- Temp : I'Class := I'Class (Base_Address (Obj'Address));
- -- CW : I'Class renames Displace (Temp, I'Tag);
-
- if Is_Interface (Typ)
- and then Is_Class_Wide_Type (Typ)
- and then
- (Is_Class_Wide_Type (Etype (Expr))
- or else
- not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
- and then Comes_From_Source (Def_Id)
- and then Tagged_Type_Expansion
+ if Is_Return_Object (Def_Id)
+ and then Is_Inherently_Limited_Type (Typ)
then
+ null;
+
+ elsif Tagged_Type_Expansion then
declare
- Decl_1 : Node_Id;
- Decl_2 : Node_Id;
+ Iface : constant Entity_Id := Root_Type (Typ);
+ Expr_N : Node_Id := Expr;
+ Expr_Typ : Entity_Id;
+
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ New_Expr : Node_Id;
begin
- Decl_1 :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('D')),
+ -- If the original node of the expression was a conversion
+ -- to this specific class-wide interface type then we
+ -- restore the original node to generate code that
+ -- statically displaces the pointer to the interface
+ -- component.
+
+ if not Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+ and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr_N)) = Typ
+ then
+ Rewrite (Expr_N, Original_Node (Expression (N)));
+ end if;
- Object_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Root_Type (Etype (Def_Id)), Loc),
- Attribute_Name => Name_Class),
+ -- Avoid expansion of redundant interface conversion
- Expression =>
- Unchecked_Convert_To
- (Class_Wide_Type (Root_Type (Etype (Def_Id))),
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Base_Address),
- Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Expr),
- Attribute_Name => Name_Address)))))));
+ if Is_Interface (Etype (Expr_N))
+ and then Nkind (Expr_N) = N_Type_Conversion
+ and then Etype (Expr_N) = Typ
+ then
+ Expr_N := Expression (Expr_N);
+ Set_Expression (N, Expr_N);
+ end if;
- Insert_Action (N, Decl_1);
+ Expr_Typ := Base_Type (Etype (Expr_N));
- Decl_2 :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('D')),
+ if Is_Class_Wide_Type (Expr_Typ) then
+ Expr_Typ := Root_Type (Expr_Typ);
+ end if;
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Root_Type (Etype (Def_Id)), Loc),
- Attribute_Name => Name_Class),
+ -- Replace
+ -- CW : I'Class := Obj;
+ -- by
+ -- Tmp : T := Obj;
+ -- CW : I'Class renames TiC!(Tmp.I_Tag);
+
+ if Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Identifier
+ and then not Is_Interface (Expr_Typ)
+ and then (Expr_Typ = Etype (Expr_Typ)
+ or else not
+ Is_Variable_Size_Record (Etype (Expr_Typ)))
+ then
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of (Expr_Typ, Loc),
+ Expression =>
+ Unchecked_Convert_To (Expr_Typ,
+ Relocate_Node (Expr_N)));
+
+ -- Statically reference the tag associated with the
+ -- interface
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Selector_Name =>
+ New_Reference_To
+ (Find_Interface_Tag (Expr_Typ, Iface),
+ Loc))));
+
+ -- General case:
+
+ -- Replace
+ -- IW : I'Class := Obj;
+ -- by
+ -- type Equiv_Record is record ... end record;
+ -- implicit subtype CW is <Class_Wide_Subtype>;
+ -- Temp : CW := CW!(Obj'Address);
+ -- IW : I'Class renames Displace (Temp, I'Tag);
- Name =>
- Unchecked_Convert_To (
- Class_Wide_Type (Root_Type (Etype (Def_Id))),
+ else
+ -- Generate the equivalent record type
+
+ Expand_Subtype_From_Expr
+ (N => N,
+ Unc_Type => Typ,
+ Subtype_Indic => Object_Definition (N),
+ Exp => Expression (N));
+
+ if not Is_Interface (Etype (Expression (N))) then
+ New_Expr := Relocate_Node (Expression (N));
+ else
+ New_Expr :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Displace), Loc),
-
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To
- (Defining_Identifier (Decl_1), Loc),
- Attribute_Name => Name_Address),
-
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table
- (Root_Type (Typ)))),
- Loc))))))));
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Attribute_Name => Name_Address)));
+ end if;
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Etype (Object_Definition (N)), Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Etype (Object_Definition (N)), New_Expr));
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Iface))),
+ Loc))))))));
+ end if;
+
+ Insert_Action (N, Decl_1);
Rewrite (N, Decl_2);
Analyze (N);
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
-
- return;
end;
end if;
+ return;
+
+ else
+ -- In most cases, we must check that the initial value meets any
+ -- constraint imposed by the declared type. However, there is one
+ -- very important exception to this rule. If the entity has an
+ -- unconstrained nominal subtype, then it acquired its constraints
+ -- from the expression in the first place, and not only does this
+ -- mean that the constraint check is not needed, but an attempt to
+ -- perform the constraint check can cause order of elaboration
+ -- problems.
+
+ if not Is_Constr_Subt_For_U_Nominal (Typ) then
+
+ -- If this is an allocator for an aggregate that has been
+ -- allocated in place, delay checks until assignments are
+ -- made, because the discriminants are not initialized.
+
+ if Nkind (Expr) = N_Allocator
+ and then No_Initialization (Expr)
+ then
+ null;
+ else
+ Apply_Constraint_Check (Expr, Typ);
+
+ -- If the expression has been marked as requiring a range
+ -- generate it now and reset the flag.
+
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed);
+ end if;
+ end if;
+ end if;
+
-- If the type is controlled and not inherently limited, then
-- the target is adjusted after the copy and attached to the
-- finalization list. However, no adjustment is done in the case
end if;
end Clean_Task_Names;
- -----------------------
- -- Freeze_Array_Type --
- -----------------------
+ ------------------------------
+ -- Expand_Freeze_Array_Type --
+ ------------------------------
- procedure Freeze_Array_Type (N : Node_Id) is
+ procedure Expand_Freeze_Array_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Base : constant Entity_Id := Base_Type (Typ);
then
Build_Array_Init_Proc (Base, N);
end if;
- end Freeze_Array_Type;
+ end Expand_Freeze_Array_Type;
- -----------------------------
- -- Freeze_Enumeration_Type --
- -----------------------------
+ ------------------------------------
+ -- Expand_Freeze_Enumeration_Type --
+ ------------------------------------
- procedure Freeze_Enumeration_Type (N : Node_Id) is
+ procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
exception
when RE_Not_Available =>
return;
- end Freeze_Enumeration_Type;
-
- ------------------------
- -- Freeze_Record_Type --
- ------------------------
-
- procedure Freeze_Record_Type (N : Node_Id) is
-
- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id);
- -- Add to the list of primitives of Tagged_Types the internal entities
- -- associated with interface primitives that are located in secondary
- -- dispatch tables.
+ end Expand_Freeze_Enumeration_Type;
- -------------------------------------
- -- Add_Internal_Interface_Entities --
- -------------------------------------
-
- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
- Elmt : Elmt_Id;
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
- Iface_Prim : Entity_Id;
- Ifaces_List : Elist_Id;
- New_Subp : Entity_Id := Empty;
- Prim : Entity_Id;
-
- begin
- pragma Assert (Ada_Version >= Ada_05
- and then Is_Record_Type (Tagged_Type)
- and then Is_Tagged_Type (Tagged_Type)
- and then Has_Interfaces (Tagged_Type)
- and then not Is_Interface (Tagged_Type));
-
- Collect_Interfaces (Tagged_Type, Ifaces_List);
-
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
-
- -- Exclude from this processing interfaces that are parents
- -- of Tagged_Type because their primitives are located in the
- -- primary dispatch table (and hence no auxiliary internal
- -- entities are required to handle secondary dispatch tables
- -- in such case).
-
- if not Is_Ancestor (Iface, Tagged_Type) then
- Elmt := First_Elmt (Primitive_Operations (Iface));
- while Present (Elmt) loop
- Iface_Prim := Node (Elmt);
-
- if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
- Prim :=
- Find_Primitive_Covering_Interface
- (Tagged_Type => Tagged_Type,
- Iface_Prim => Iface_Prim);
-
- pragma Assert (Present (Prim));
-
- Derive_Subprogram
- (New_Subp => New_Subp,
- Parent_Subp => Iface_Prim,
- Derived_Type => Tagged_Type,
- Parent_Type => Iface);
-
- -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
- -- associated with interface types. These entities are
- -- only registered in the list of primitives of its
- -- corresponding tagged type because they are only used
- -- to fill the contents of the secondary dispatch tables.
- -- Therefore they are removed from the homonym chains.
-
- Set_Is_Hidden (New_Subp);
- Set_Is_Internal (New_Subp);
- Set_Alias (New_Subp, Prim);
- Set_Is_Abstract_Subprogram (New_Subp,
- Is_Abstract_Subprogram (Prim));
- Set_Interface_Alias (New_Subp, Iface_Prim);
-
- -- Internal entities associated with interface types are
- -- only registered in the list of primitives of the
- -- tagged type. They are only used to fill the contents
- -- of the secondary dispatch tables. Therefore they are
- -- not needed in the homonym chains.
-
- Remove_Homonym (New_Subp);
-
- -- Hidden entities associated with interfaces must have
- -- set the Has_Delay_Freeze attribute to ensure that, in
- -- case of locally defined tagged types (or compiling
- -- with static dispatch tables generation disabled) the
- -- corresponding entry of the secondary dispatch table is
- -- filled when such entity is frozen.
-
- Set_Has_Delayed_Freeze (New_Subp);
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
- end Add_Internal_Interface_Entities;
-
- -- Local variables
+ -------------------------------
+ -- Expand_Freeze_Record_Type --
+ -------------------------------
+ procedure Expand_Freeze_Record_Type (N : Node_Id) is
Def_Id : constant Node_Id := Entity (N);
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
Wrapper_Body_List : List_Id := No_List;
Null_Proc_Decl_List : List_Id := No_List;
- -- Start of processing for Freeze_Record_Type
+ -- Start of processing for Expand_Freeze_Record_Type
begin
-- Build discriminant checking functions if not a derived type (for
if Has_Task (Comp_Typ) then
Set_Has_Task (Def_Id);
- elsif Has_Controlled_Component (Comp_Typ)
- or else (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Comp_Typ))
+ -- Do not set Has_Controlled_Component on a class-wide equivalent
+ -- type. See Make_CW_Equivalent_Type.
+
+ elsif not Is_Class_Wide_Equivalent_Type (Def_Id)
+ and then (Has_Controlled_Component (Comp_Typ)
+ or else (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Comp_Typ)))
then
Set_Has_Controlled_Component (Def_Id);
Next_Component (Comp);
end loop;
+ -- Handle constructors of non-tagged CPP_Class types
+
+ if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then
+ Set_CPP_Constructors (Def_Id);
+ end if;
+
-- Creation of the Dispatch Table. Note that a Dispatch Table is built
-- for regular tagged types as well as for Ada types deriving from a C++
-- Class, but not for tagged types directly corresponding to C++ classes
Insert_Actions (N, Null_Proc_Decl_List);
end if;
- -- Ada 2005 (AI-251): Add internal entities associated with
- -- secondary dispatch tables to the list of primitives of tagged
- -- types that are not interfaces
-
- if Ada_Version >= Ada_05
- and then not Is_Interface (Def_Id)
- and then Has_Interfaces (Def_Id)
- then
- Add_Internal_Interface_Entities (Def_Id);
- end if;
-
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
if Present (Wrapper_Body_List) then
Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
end if;
+
+ -- Create extra formals for the primitive operations of the type.
+ -- This must be done before analyzing the body of the initialization
+ -- procedure, because a self-referential type might call one of these
+ -- primitives in the body of the init_proc itself.
+
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Def_Id));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ if not Has_Foreign_Convention (Subp)
+ and then not Is_Predefined_Dispatching_Operation (Subp)
+ then
+ Create_Extra_Formals (Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
end if;
- end Freeze_Record_Type;
+ end Expand_Freeze_Record_Type;
------------------------------
-- Freeze_Stream_Operations --
if Is_Record_Type (Def_Id) then
if Ekind (Def_Id) = E_Record_Type then
- Freeze_Record_Type (N);
+ Expand_Freeze_Record_Type (N);
-- The subtype may have been declared before the type was frozen. If
-- the type has controlled components it is necessary to create the
-- Freeze processing for array types
elsif Is_Array_Type (Def_Id) then
- Freeze_Array_Type (N);
+ Expand_Freeze_Array_Type (N);
-- Freeze processing for access types
-- is not the same as its representation)
if Has_Non_Standard_Rep (Def_Id) then
- Freeze_Enumeration_Type (N);
+ Expand_Freeze_Enumeration_Type (N);
end if;
-- Private types that are completed by a derivation from a private
elsif Restriction_Active (No_Finalization) then
null;
+ -- Skip these for CIL Value types, where finalization is not available
+
+ elsif Is_Value_Type (Tag_Typ) then
+ null;
+
elsif Etype (Tag_Typ) = Tag_Typ
or else Needs_Finalization (Tag_Typ)
OSDN Git Service
