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
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;
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
-- the tag component.
if Generate_SCIL then
- Prepend_To (Init_Tags_List,
- New_SCIL_Node
- (SN_Kind => IP_Tag_Init,
- Related_Node => First (Init_Tags_List),
- Entity => Rec_Type));
+ 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
Set_Init_Proc (Rec_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
and then VM_Target = No_VM
then
-- Even though the init proc may be null at this time it might get
then
pragma Assert (Is_Class_Wide_Type (Typ));
- if Tagged_Type_Expansion then
+ -- 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.
+
+ if Is_Return_Object (Def_Id)
+ and then Is_Inherently_Limited_Type (Typ)
+ then
+ null;
+
+ elsif Tagged_Type_Expansion then
declare
Iface : constant Entity_Id := Root_Type (Typ);
Expr_N : Node_Id := Expr;
-------------------------------
procedure Expand_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.
-
- -------------------------------------
- -- 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
-
Def_Id : constant Node_Id := Entity (N);
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
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);
OSDN Git Service
