Skip to content

R
riscv-gcc-1
Commit ea1941af by Ed Schonberg Committed by Arnaud Charlet
Options

exp_ch3.ads, [...] (Analyze_N_Full_Type_Declaration): For an anonymous access component... 

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_ch3.ads, exp_ch3.adb (Analyze_N_Full_Type_Declaration): For an
	anonymous access component, do not create a master_id if type already
	has one, as may happen if the type is a subcomponent of a packed array
	type.
	(Build_Init_Procedure, Component_Needs_Simple_Initialization,
	Initialize_Tag): Remove code associated with the old CPP pragmas.
	CPP_Virtual and CPP_Vtable are no longer supported.
	(Build_Offset_To_Top_Internal): Add support for concurrent record types
	(Build_Offset_To_Top_Functions): Add support for concurrent record types
	(Freeze_Record_Type): Remove call to
	Init_Predefined_Interface_Primitives.
	(Init_Secondary_Tags.Initialize_Tag): New subprogram containing all the
	code required to initialize the tags of the secondary dispatch tables.
	This leaves the algoritm more clear.
	(Init_Secondary_Tags): Add support for concurrent record types
	(Make_Predefined_Primitive_Specs): Code cleanup.
	(Predefined_Primitive_Bodies): Code cleanup.
	(Build_Master_Renaming): New local subprogram.
	(Expand_N_Full_Type_Declaration): Build the master_id associated with
	anonymous access to task type components.
	(Expand_N_Subtype_Indication): The bounds of a range constraint in a
	subtype indication are resolved during analysis, and must not be done
	here.
	(Stream_Operation_OK): Check Restriction_Active before RTE_Available.

From-SVN: r123551
parent 3d6efb77
Showing with 632 additions and 396 deletions
gcc/ada/exp_ch3.adb
...@@ -26,10 +26,10 @@ ...@@ -26,10 +26,10 @@
with Atree; use Atree; with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch4; use Exp_Ch4; with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6; with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
...@@ -92,6 +92,20 @@ package body Exp_Ch3 is ...@@ -92,6 +92,20 @@ package body Exp_Ch3 is
-- of the type. Otherwise new identifiers are created, with the source -- of the type. Otherwise new identifiers are created, with the source
-- names of the discriminants. -- names of the discriminants.
function Build_Master_Renaming
(N : Node_Id;
T : Entity_Id) return Entity_Id;
-- If the designated type of an access type is a task type or contains
-- tasks, we make sure that a _Master variable is declared in the current
-- scope, and then declare a renaming for it:
--
-- atypeM : Master_Id renames _Master;
--
-- where atyp is the name of the access type. This declaration is used when
-- an allocator for the access type is expanded. The node is the full
-- declaration of the designated type that contains tasks. The renaming
-- declaration is inserted before N, and after the Master declaration.
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id);
-- Build record initialization procedure. N is the type declaration -- Build record initialization procedure. N is the type declaration
-- node, and Pe is the corresponding entity for the record type. -- node, and Pe is the corresponding entity for the record type.
...@@ -508,7 +522,10 @@ package body Exp_Ch3 is ...@@ -508,7 +522,10 @@ package body Exp_Ch3 is
else else
Clean_Task_Names (Comp_Type, Proc_Id); Clean_Task_Names (Comp_Type, Proc_Id);
return return
Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); Build_Initialization_Call
(Loc, Comp, Comp_Type,
In_Init_Proc => True,
Enclos_Type => A_Type);
end if; end if;
end Init_Component; end Init_Component;
...@@ -1143,6 +1160,7 @@ package body Exp_Ch3 is ...@@ -1143,6 +1160,7 @@ package body Exp_Ch3 is
-- for the value 3 (should be rtsfindable constant ???) -- for the value 3 (should be rtsfindable constant ???)
Append_To (Args, Make_Integer_Literal (Loc, 3)); Append_To (Args, Make_Integer_Literal (Loc, 3));
else else
Append_To (Args, Make_Identifier (Loc, Name_uMaster)); Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if; end if;
...@@ -1343,7 +1361,10 @@ package body Exp_Ch3 is ...@@ -1343,7 +1361,10 @@ package body Exp_Ch3 is
-- Build_Master_Renaming -- -- Build_Master_Renaming --
--------------------------- ---------------------------
procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is function Build_Master_Renaming
(N : Node_Id;
T : Entity_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
M_Id : Entity_Id; M_Id : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
...@@ -1352,7 +1373,7 @@ package body Exp_Ch3 is ...@@ -1352,7 +1373,7 @@ package body Exp_Ch3 is
-- Nothing to do if there is no task hierarchy -- Nothing to do if there is no task hierarchy
if Restriction_Active (No_Task_Hierarchy) then if Restriction_Active (No_Task_Hierarchy) then
return; return Empty;
end if; end if;
M_Id := M_Id :=
...@@ -1366,7 +1387,28 @@ package body Exp_Ch3 is ...@@ -1366,7 +1387,28 @@ package body Exp_Ch3 is
Name => Make_Identifier (Loc, Name_uMaster)); Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (N, Decl); Insert_Before (N, Decl);
Analyze (Decl); Analyze (Decl);
return M_Id;
exception
when RE_Not_Available =>
return Empty;
end Build_Master_Renaming;
---------------------------
-- Build_Master_Renaming --
---------------------------
procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
M_Id : Entity_Id;
begin
-- Nothing to do if there is no task hierarchy
if Restriction_Active (No_Task_Hierarchy) then
return;
end if;
M_Id := Build_Master_Renaming (N, T);
Set_Master_Id (T, M_Id); Set_Master_Id (T, M_Id);
exception exception
...@@ -1764,9 +1806,20 @@ package body Exp_Ch3 is ...@@ -1764,9 +1806,20 @@ package body Exp_Ch3 is
procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is
begin begin
-- Climb to the ancestor (if any) handling private types -- Climb to the ancestor (if any) handling synchronized interface
-- derivations and private types
if Present (Full_View (Etype (Typ))) then if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id :=
Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Build_Offset_To_Top_Internal (Etype (First (Iface_List)));
end if;
end;
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then if Full_View (Etype (Typ)) /= Typ then
Build_Offset_To_Top_Internal (Full_View (Etype (Typ))); Build_Offset_To_Top_Internal (Full_View (Etype (Typ)));
end if; end if;
...@@ -1842,7 +1895,12 @@ package body Exp_Ch3 is ...@@ -1842,7 +1895,12 @@ package body Exp_Ch3 is
-- Start of processing for Build_Offset_To_Top_Functions -- Start of processing for Build_Offset_To_Top_Functions
begin begin
if Etype (Rec_Type) = Rec_Type if Is_Concurrent_Record_Type (Rec_Type)
and then Is_Empty_List (Abstract_Interface_List (Rec_Type))
then
return;
elsif Etype (Rec_Type) = Rec_Type
or else not Has_Discriminants (Etype (Rec_Type)) or else not Has_Discriminants (Etype (Rec_Type))
or else No (Abstract_Interfaces (Rec_Type)) or else No (Abstract_Interfaces (Rec_Type))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type)) or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type))
...@@ -2011,7 +2069,6 @@ package body Exp_Ch3 is ...@@ -2011,7 +2069,6 @@ package body Exp_Ch3 is
declare declare
Nod : Node_Id := First (Body_Stmts); Nod : Node_Id := First (Body_Stmts);
New_N : Node_Id; New_N : Node_Id;
Args : List_Id;
begin begin
-- We assume the first init_proc call is for the parent -- We assume the first init_proc call is for the parent
...@@ -2026,82 +2083,61 @@ package body Exp_Ch3 is ...@@ -2026,82 +2083,61 @@ package body Exp_Ch3 is
-- Generate: -- Generate:
-- ancestor_constructor (_init.parent); -- ancestor_constructor (_init.parent);
-- if Arg2 then -- if Arg2 then
-- inherit_prim_ops (_init._tag, new_dt, num_prims);
-- _init._tag := new_dt; -- _init._tag := new_dt;
-- end if; -- end if;
if Debug_Flag_QQ then New_N :=
Init_Tag := Build_Inherit_Prims (Loc,
Make_If_Statement (Loc, Old_Tag_Node =>
Condition => New_Occurrence_Of (Set_Tag, Loc), Make_Selected_Component (Loc,
Then_Statements => New_List (Init_Tag)); Prefix => Make_Identifier (Loc, Name_uInit),
Insert_After (Nod, Init_Tag); Selector_Name =>
New_Reference_To
(First_Tag_Component (Rec_Type), Loc)),
New_Tag_Node =>
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Rec_Type))),
Loc),
Num_Prims =>
UI_To_Int
(DT_Entry_Count (First_Tag_Component (Rec_Type))));
Init_Tag :=
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => New_List (New_N, Init_Tag));
Insert_After (Nod, Init_Tag);
-- We have inherited the whole contents of the DT table
-- from the CPP side. Therefore all our previous initia-
-- lization has been lost and we must refill entries
-- associated with Ada primitives. This needs more work
-- to avoid its execution each time an object is
-- initialized???
declare
E : Elmt_Id;
Prim : Node_Id;
-- Generate: begin
-- ancestor_constructor (_init.parent); E := First_Elmt (Primitive_Operations (Rec_Type));
-- if Arg2 then while Present (E) loop
-- inherit_dt (_init._tag, new_dt, num_prims); Prim := Node (E);
-- _init._tag := new_dt;
-- end if; if not Is_Imported (Prim)
else and then Convention (Prim) = Convention_CPP
Args := New_List ( and then not Present (Abstract_Interface_Alias
Node1 => (Prim))
Make_Selected_Component (Loc, then
Prefix => Make_Identifier (Loc, Name_uInit), Insert_After (Init_Tag,
Selector_Name => Fill_DT_Entry (Loc, Prim));
New_Reference_To end if;
(First_Tag_Component (Rec_Type), Loc)),
Node2 =>
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Rec_Type))),
Loc),
Node3 =>
Make_Integer_Literal (Loc,
DT_Entry_Count (First_Tag_Component (Rec_Type))));
New_N :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Inherit_CPP_DT),
Loc),
Parameter_Associations => Args);
Init_Tag :=
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => New_List (New_N, Init_Tag));
Insert_After (Nod, Init_Tag);
-- We have inherited the whole contents of the DT table
-- from the CPP side. Therefore all our previous initia-
-- lization has been lost and we must refill entries
-- associated with Ada primitives. This needs more work
-- to avoid its execution each time an object is
-- initialized???
declare
E : Elmt_Id;
Prim : Node_Id;
begin
E := First_Elmt (Primitive_Operations (Rec_Type));
while Present (E) loop
Prim := Node (E);
if not Is_Imported (Prim)
and then Convention (Prim) = Convention_CPP
and then not Present (Abstract_Interface_Alias
(Prim))
then
Insert_After (Init_Tag,
Fill_DT_Entry (Loc, Prim));
end if;
Next_Elmt (E); Next_Elmt (E);
end loop; end loop;
end; end;
end if;
end; end;
end if; end if;
...@@ -2244,8 +2280,8 @@ package body Exp_Ch3 is ...@@ -2244,8 +2280,8 @@ package body Exp_Ch3 is
Prefix => Make_Identifier (Loc, Name_uInit), Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc)), Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ, Typ,
True, In_Init_Proc => True,
Rec_Type, Enclos_Type => Rec_Type,
Discr_Map => Discr_Map); Discr_Map => Discr_Map);
Clean_Task_Names (Typ, Proc_Id); Clean_Task_Names (Typ, Proc_Id);
...@@ -2276,7 +2312,7 @@ package body Exp_Ch3 is ...@@ -2276,7 +2312,7 @@ package body Exp_Ch3 is
-- if the parent holds discriminants that can be used -- if the parent holds discriminants that can be used
-- to compute the offset of the controller. We assume here -- to compute the offset of the controller. We assume here
-- that the last statement of the initialization call is the -- that the last statement of the initialization call is the
-- attachement of the parent (see Build_Initialization_Call) -- attachment of the parent (see Build_Initialization_Call)
if Chars (Id) = Name_uController if Chars (Id) = Name_uController
and then Rec_Type /= Etype (Rec_Type) and then Rec_Type /= Etype (Rec_Type)
...@@ -2311,9 +2347,12 @@ package body Exp_Ch3 is ...@@ -2311,9 +2347,12 @@ package body Exp_Ch3 is
Append_List_To (Statement_List, Append_List_To (Statement_List,
Build_Initialization_Call (Loc, Build_Initialization_Call (Loc,
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit), Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc)), Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ, True, Rec_Type, Discr_Map => Discr_Map)); Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map));
Clean_Task_Names (Typ, Proc_Id); Clean_Task_Names (Typ, Proc_Id);
...@@ -2486,7 +2525,6 @@ package body Exp_Ch3 is ...@@ -2486,7 +2525,6 @@ package body Exp_Ch3 is
return return
Needs_Simple_Initialization (T) Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag) and then not Is_RTE (T, RE_Tag)
and then not Is_RTE (T, RE_Vtable_Ptr)
-- Ada 2005 (AI-251): Check also the tag of abstract interfaces -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
...@@ -3453,9 +3491,15 @@ package body Exp_Ch3 is ...@@ -3453,9 +3491,15 @@ package body Exp_Ch3 is
Par_Id : Entity_Id; Par_Id : Entity_Id;
FN : Node_Id; FN : Node_Id;
begin procedure Build_Master (Def_Id : Entity_Id);
if Is_Access_Type (Def_Id) then -- Create the master associated with Def_Id
------------------
-- Build_Master --
------------------
procedure Build_Master (Def_Id : Entity_Id) is
begin
-- Anonymous access types are created for the components of the -- Anonymous access types are created for the components of the
-- record parameter for an entry declaration. No master is created -- record parameter for an entry declaration. No master is created
-- for such a type. -- for such a type.
...@@ -3497,19 +3541,97 @@ package body Exp_Ch3 is ...@@ -3497,19 +3541,97 @@ package body Exp_Ch3 is
and then Convention (Designated_Type (Def_Id)) /= Convention_Java and then Convention (Designated_Type (Def_Id)) /= Convention_Java
then then
Build_Class_Wide_Master (Def_Id); Build_Class_Wide_Master (Def_Id);
end if;
end Build_Master;
-- Start of processing for Expand_N_Full_Type_Declaration
begin
if Is_Access_Type (Def_Id) then
Build_Master (Def_Id);
elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
Expand_Access_Protected_Subprogram_Type (N); Expand_Access_Protected_Subprogram_Type (N);
end if; end if;
elsif Ada_Version >= Ada_05
and then Is_Array_Type (Def_Id)
and then Is_Access_Type (Component_Type (Def_Id))
and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
then
Build_Master (Component_Type (Def_Id));
elsif Has_Task (Def_Id) then elsif Has_Task (Def_Id) then
Expand_Previous_Access_Type (Def_Id); Expand_Previous_Access_Type (Def_Id);
elsif Ada_Version >= Ada_05
and then
(Is_Record_Type (Def_Id)
or else (Is_Array_Type (Def_Id)
and then Is_Record_Type (Component_Type (Def_Id))))
then
declare
Comp : Entity_Id;
Typ : Entity_Id;
M_Id : Entity_Id;
begin
-- Look for the first anonymous access type component
if Is_Array_Type (Def_Id) then
Comp := First_Entity (Component_Type (Def_Id));
else
Comp := First_Entity (Def_Id);
end if;
while Present (Comp) loop
Typ := Etype (Comp);
exit when Is_Access_Type (Typ)
and then Ekind (Typ) = E_Anonymous_Access_Type;
Next_Entity (Comp);
end loop;
-- If found we add a renaming reclaration of master_id and we
-- associate it to each anonymous access type component. Do
-- nothing if the access type already has a master. This will be
-- the case if the array type is the packed array created for a
-- user-defined array type T, where the master_id is created when
-- expanding the declaration for T.
if Present (Comp)
and then not Restriction_Active (No_Task_Hierarchy)
and then No (Master_Id (Typ))
then
Build_Master_Entity (Def_Id);
M_Id := Build_Master_Renaming (N, Def_Id);
if Is_Array_Type (Def_Id) then
Comp := First_Entity (Component_Type (Def_Id));
else
Comp := First_Entity (Def_Id);
end if;
while Present (Comp) loop
Typ := Etype (Comp);
if Is_Access_Type (Typ)
and then Ekind (Typ) = E_Anonymous_Access_Type
then
Set_Master_Id (Typ, M_Id);
end if;
Next_Entity (Comp);
end loop;
end if;
end;
end if; end if;
Par_Id := Etype (B_Id); Par_Id := Etype (B_Id);
-- The parent type is private then we need to inherit -- The parent type is private then we need to inherit any TSS operations
-- any TSS operations from the full view. -- from the full view.
if Ekind (Par_Id) in Private_Kind if Ekind (Par_Id) in Private_Kind
and then Present (Full_View (Par_Id)) and then Present (Full_View (Par_Id))
...@@ -3517,26 +3639,25 @@ package body Exp_Ch3 is ...@@ -3517,26 +3639,25 @@ package body Exp_Ch3 is
Par_Id := Base_Type (Full_View (Par_Id)); Par_Id := Base_Type (Full_View (Par_Id));
end if; end if;
if Nkind (Type_Definition (Original_Node (N))) if Nkind (Type_Definition (Original_Node (N))) =
= N_Derived_Type_Definition N_Derived_Type_Definition
and then not Is_Tagged_Type (Def_Id) and then not Is_Tagged_Type (Def_Id)
and then Present (Freeze_Node (Par_Id)) and then Present (Freeze_Node (Par_Id))
and then Present (TSS_Elist (Freeze_Node (Par_Id))) and then Present (TSS_Elist (Freeze_Node (Par_Id)))
then then
Ensure_Freeze_Node (B_Id); Ensure_Freeze_Node (B_Id);
FN := Freeze_Node (B_Id); FN := Freeze_Node (B_Id);
if No (TSS_Elist (FN)) then if No (TSS_Elist (FN)) then
Set_TSS_Elist (FN, New_Elmt_List); Set_TSS_Elist (FN, New_Elmt_List);
end if; end if;
declare declare
T_E : constant Elist_Id := TSS_Elist (FN); T_E : constant Elist_Id := TSS_Elist (FN);
Elmt : Elmt_Id; Elmt : Elmt_Id;
begin begin
Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
while Present (Elmt) loop while Present (Elmt) loop
if Chars (Node (Elmt)) /= Name_uInit then if Chars (Node (Elmt)) /= Name_uInit then
Append_Elmt (Node (Elmt), T_E); Append_Elmt (Node (Elmt), T_E);
...@@ -3572,13 +3693,12 @@ package body Exp_Ch3 is ...@@ -3572,13 +3693,12 @@ package body Exp_Ch3 is
procedure Expand_N_Object_Declaration (N : Node_Id) is procedure Expand_N_Object_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N); Def_Id : constant Entity_Id := Defining_Identifier (N);
Typ : constant Entity_Id := Etype (Def_Id);
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
Loc : constant Source_Ptr := Sloc (N);
New_Ref : Node_Id; Typ : constant Entity_Id := Etype (Def_Id);
Id_Ref : Node_Id;
Expr_Q : Node_Id; Expr_Q : Node_Id;
Id_Ref : Node_Id;
New_Ref : Node_Id;
begin begin
-- Don't do anything for deferred constants. All proper actions will -- Don't do anything for deferred constants. All proper actions will
...@@ -3650,16 +3770,16 @@ package body Exp_Ch3 is ...@@ -3650,16 +3770,16 @@ package body Exp_Ch3 is
declare declare
L : constant List_Id := L : constant List_Id :=
Make_Init_Call ( Make_Init_Call
Ref => New_Occurrence_Of (Def_Id, Loc), (Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ), Typ => Base_Type (Typ),
Flist_Ref => Find_Final_List (Def_Id), Flist_Ref => Find_Final_List (Def_Id),
With_Attach => Make_Integer_Literal (Loc, 1)); With_Attach => Make_Integer_Literal (Loc, 1));
Blk : constant Node_Id := Blk : constant Node_Id :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, L)); Make_Handled_Sequence_Of_Statements (Loc, L));
begin begin
Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
...@@ -3680,12 +3800,12 @@ package body Exp_Ch3 is ...@@ -3680,12 +3800,12 @@ package body Exp_Ch3 is
if Has_Non_Null_Base_Init_Proc (Typ) if Has_Non_Null_Base_Init_Proc (Typ)
and then not No_Initialization (N) and then not No_Initialization (N)
then then
-- The call to the initialization procedure does NOT freeze -- The call to the initialization procedure does NOT freeze the
-- the object being initialized. This is because the call is -- object being initialized. This is because the call is not a
-- not a source level call. This works fine, because the only -- source level call. This works fine, because the only possible
-- possible statements depending on freeze status that can -- statements depending on freeze status that can appear after the
-- appear after the _Init call are rep clauses which can -- _Init call are rep clauses which can safely appear after actual
-- safely appear after actual references to the object. -- references to the object.
Id_Ref := New_Reference_To (Def_Id, Loc); Id_Ref := New_Reference_To (Def_Id, Loc);
Set_Must_Not_Freeze (Id_Ref); Set_Must_Not_Freeze (Id_Ref);
...@@ -3699,8 +3819,8 @@ package body Exp_Ch3 is ...@@ -3699,8 +3819,8 @@ package body Exp_Ch3 is
-- initialization is required even though No_Init_Flag is present. -- initialization is required even though No_Init_Flag is present.
-- An internally generated temporary needs no initialization because -- An internally generated temporary needs no initialization because
-- it will be assigned subsequently. In particular, there is no -- it will be assigned subsequently. In particular, there is no point
-- point in applying Initialize_Scalars to such a temporary. -- in applying Initialize_Scalars to such a temporary.
elsif Needs_Simple_Initialization (Typ) elsif Needs_Simple_Initialization (Typ)
and then not Is_Internal (Def_Id) and then not Is_Internal (Def_Id)
...@@ -3791,23 +3911,112 @@ package body Exp_Ch3 is ...@@ -3791,23 +3911,112 @@ package body Exp_Ch3 is
end if; end if;
end if; end if;
-- If the type is controlled we attach the object to the final -- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- list and adjust the target after the copy. This -- class-wide object to ensure that we copy the full object.
-- ??? incomplete sentence
-- Replace
-- CW : I'Class := Obj;
-- by
-- CW__1 : I'Class := I'Class (Base_Address (Obj'Address));
-- CW : I'Class renames Displace (CW__1, I'Tag);
if Is_Interface (Typ)
and then Is_Class_Wide_Type (Etype (Expr))
and then Comes_From_Source (Def_Id)
then
declare
Decl_1 : Node_Id;
Decl_2 : Node_Id;
-- Ada 2005 (AI-251): Do not register in the final list objects begin
-- containing class-wide interfaces; otherwise we erroneously Decl_1 :=
-- register the tag of the interface in the final list. Example: Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
-- Obj1 : T; -- Controlled object that implements Iface Object_Definition =>
-- Obj2 : Iface'Class := Iface'Class (Obj1); Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc,
Chars (Root_Type (Etype (Def_Id)))),
Attribute_Name => Name_Class),
-- Obj1 is registered in the final list; Obj2 is not registered. 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 Controlled_Type (Typ) Insert_Action (N, Decl_1);
and then not (Is_Interface (Typ)
and then Is_Class_Wide_Type (Typ)) Decl_2 :=
then Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Identifier (Loc,
Chars => Chars (Root_Type (Etype (Def_Id)))),
Attribute_Name => Name_Class),
Name =>
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_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))))))));
Rewrite (N, Decl_2);
Analyze (N);
-- Replace internal identifier of Decl_2 by the identifier
-- found in the sources. We also have to exchange entities
-- containing their defining identifiers to ensure the
-- correct replacement of the object declaration by this
-- object renaming declaration (because such definings
-- identifier have been previously added by Enter_Name to
-- the current scope).
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
return;
end;
end if;
-- If the type is controlled we attach the object to the final
-- list and adjust the target after the copy. This
-- ??? incomplete sentence
if Controlled_Type (Typ) then
declare declare
Flist : Node_Id; Flist : Node_Id;
F : Entity_Id; F : Entity_Id;
...@@ -3984,7 +4193,6 @@ package body Exp_Ch3 is ...@@ -3984,7 +4193,6 @@ package body Exp_Ch3 is
or else or else
Nkind (Parent (N)) = N_Slice Nkind (Parent (N)) = N_Slice
then then
Resolve (Ran, Typ);
Apply_Range_Check (Ran, Typ); Apply_Range_Check (Ran, Typ);
end if; end if;
end Expand_N_Subtype_Indication; end Expand_N_Subtype_Indication;
...@@ -3996,10 +4204,9 @@ package body Exp_Ch3 is ...@@ -3996,10 +4204,9 @@ package body Exp_Ch3 is
-- If the last variant does not contain the Others choice, replace it with -- If the last variant does not contain the Others choice, replace it with
-- an N_Others_Choice node since Gigi always wants an Others. Note that we -- an N_Others_Choice node since Gigi always wants an Others. Note that we
-- do not bother to call Analyze on the modified variant part, since it's -- do not bother to call Analyze on the modified variant part, since it's
-- only effect would be to compute the contents of the -- only effect would be to compute the Others_Discrete_Choices node
-- Others_Discrete_Choices node laboriously, and of course we already know -- laboriously, and of course we already know the list of choices that
-- the list of choices that corresponds to the others choice (it's the -- corresponds to the others choice (it's the list we are replacing!)
-- list we are replacing!)
procedure Expand_N_Variant_Part (N : Node_Id) is procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
...@@ -4096,8 +4303,8 @@ package body Exp_Ch3 is ...@@ -4096,8 +4303,8 @@ package body Exp_Ch3 is
else else
-- The controller cannot be placed before the _Parent field since -- The controller cannot be placed before the _Parent field since
-- gigi lays out field in order and _parent must be first to -- gigi lays out field in order and _parent must be first to preserve
-- preserve the polymorphism of tagged types. -- the polymorphism of tagged types.
First_Comp := First (Component_Items (Comp_List)); First_Comp := First (Component_Items (Comp_List));
...@@ -4770,9 +4977,15 @@ package body Exp_Ch3 is ...@@ -4770,9 +4977,15 @@ package body Exp_Ch3 is
-- must be before the freeze point). -- must be before the freeze point).
Set_Is_Frozen (Def_Id, False); Set_Is_Frozen (Def_Id, False);
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq); -- Do not add the spec of the predefined primitives if we are
Insert_List_Before_And_Analyze (N, Predef_List); -- compiling under restriction No_Dispatching_Calls
if not Restriction_Active (No_Dispatching_Calls) then
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
end if;
-- Ada 2005 (AI-391): For a nonabstract null extension, create -- Ada 2005 (AI-391): For a nonabstract null extension, create
-- wrapper functions for each nonoverridden inherited function -- wrapper functions for each nonoverridden inherited function
...@@ -4781,7 +4994,7 @@ package body Exp_Ch3 is ...@@ -4781,7 +4994,7 @@ package body Exp_Ch3 is
-- the parent function. -- the parent function.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then not Is_Abstract (Def_Id) and then not Is_Abstract_Type (Def_Id)
and then Is_Null_Extension (Def_Id) and then Is_Null_Extension (Def_Id)
then then
Make_Controlling_Function_Wrappers Make_Controlling_Function_Wrappers
...@@ -4797,7 +5010,7 @@ package body Exp_Ch3 is ...@@ -4797,7 +5010,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Etype (Def_Id) /= Def_Id and then Etype (Def_Id) /= Def_Id
and then not Is_Abstract (Def_Id) and then not Is_Abstract_Type (Def_Id)
then then
Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List); Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
Insert_Actions (N, Null_Proc_Decl_List); Insert_Actions (N, Null_Proc_Decl_List);
...@@ -4839,7 +5052,13 @@ package body Exp_Ch3 is ...@@ -4839,7 +5052,13 @@ package body Exp_Ch3 is
begin begin
-- Climb to the ancestor (if any) handling private types -- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then if Is_Concurrent_Record_Type (Typ) then
if Present (Abstract_Interface_List (Typ)) then
Add_Secondary_Tables
(Etype (First (Abstract_Interface_List (Typ))));
end if;
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then if Full_View (Etype (Typ)) /= Typ then
Add_Secondary_Tables (Full_View (Etype (Typ))); Add_Secondary_Tables (Full_View (Etype (Typ)));
end if; end if;
...@@ -4913,12 +5132,14 @@ package body Exp_Ch3 is ...@@ -4913,12 +5132,14 @@ package body Exp_Ch3 is
(Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id)));
end if; end if;
-- Freeze rest of primitive operations -- Freeze rest of primitive operations. There is no need to handle
-- the predefined primitives if we are compiling under restriction
-- No_Dispatching_Calls
Append_Freeze_Actions if not Restriction_Active (No_Dispatching_Calls) then
(Def_Id, Predefined_Primitive_Freeze (Def_Id)); Append_Freeze_Actions
Append_Freeze_Actions (Def_Id, Predefined_Primitive_Freeze (Def_Id));
(Def_Id, Init_Predefined_Interface_Primitives (Def_Id)); end if;
end if; end if;
-- In the non-tagged case, an equality function is provided only for -- In the non-tagged case, an equality function is provided only for
...@@ -4990,8 +5211,14 @@ package body Exp_Ch3 is ...@@ -4990,8 +5211,14 @@ package body Exp_Ch3 is
-- the primitive operations may need the initialization routine -- the primitive operations may need the initialization routine
if Is_Tagged_Type (Def_Id) then if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List); -- Do not add the body of the predefined primitives if we are
-- compiling under restriction No_Dispatching_Calls
if not Restriction_Active (No_Dispatching_Calls) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
end if;
-- Ada 2005 (AI-391): If any wrappers were created for nonoverridden -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
-- inherited functions, then add their bodies to the freeze actions. -- inherited functions, then add their bodies to the freeze actions.
...@@ -5007,10 +5234,7 @@ package body Exp_Ch3 is ...@@ -5007,10 +5234,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Dispatching_Calls)
and then Is_Concurrent_Record_Type (Def_Id) and then Is_Concurrent_Record_Type (Def_Id)
and then Implements_Interface ( and then Has_Abstract_Interfaces (Def_Id)
Typ => Def_Id,
Kind => Any_Limited_Interface,
Check_Parent => True)
then then
Append_Freeze_Actions (Def_Id, Append_Freeze_Actions (Def_Id,
Make_Select_Specific_Data_Table (Def_Id)); Make_Select_Specific_Data_Table (Def_Id));
...@@ -5867,31 +6091,227 @@ package body Exp_Ch3 is ...@@ -5867,31 +6091,227 @@ package body Exp_Ch3 is
Target : Node_Id; Target : Node_Id;
Stmts_List : List_Id) Stmts_List : List_Id)
is is
Loc : constant Source_Ptr := Sloc (Target); Loc : constant Source_Ptr := Sloc (Target);
ADT : Elmt_Id; ADT : Elmt_Id;
Full_Typ : Entity_Id; Full_Typ : Entity_Id;
AI_Tag_Comp : Entity_Id;
Is_Synch_Typ : Boolean := False;
-- In case of non concurrent-record-types each parent-type has the
-- tags associated with the interface types that are not implemented
-- by the ancestors; concurrent-record-types have their whole list of
-- interface tags (and this case requires some special management).
procedure Initialize_Tag
(Typ : Entity_Id;
Iface : Entity_Id;
Tag_Comp : in out Entity_Id;
Iface_Tag : Node_Id);
-- Initialize the tag of the secondary dispatch table of Typ associated
-- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
procedure Init_Secondary_Tags_Internal (Typ : Entity_Id); procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the root type. -- Internal subprogram used to recursively climb to the root type.
-- We assume that all the primitives of the imported C++ class are -- We assume that all the primitives of the imported C++ class are
-- defined in the C side. -- defined in the C side.
--------------------
-- Initialize_Tag --
--------------------
procedure Initialize_Tag
(Typ : Entity_Id;
Iface : Entity_Id;
Tag_Comp : in out Entity_Id;
Iface_Tag : Node_Id)
is
Prev_E : Entity_Id;
begin
-- If we are compiling under the CPP full ABI compatibility mode and
-- the ancestor is a CPP_Pragma tagged type then we generate code to
-- inherit the contents of the dispatch table directly from the
-- ancestor.
if Is_CPP_Class (Etype (Typ)) then
Append_To (Stmts_List,
Build_Inherit_Prims (Loc,
Old_Tag_Node =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (Tag_Comp, Loc)),
New_Tag_Node =>
New_Reference_To (Iface_Tag, Loc),
Num_Prims =>
UI_To_Int
(DT_Entry_Count (First_Tag_Component (Iface)))));
end if;
-- Initialize the pointer to the secondary DT associated with the
-- interface.
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (Tag_Comp, Loc)),
Expression =>
New_Reference_To (Iface_Tag, Loc)));
-- If the ancestor is CPP_Class, nothing else to do here
if Is_CPP_Class (Etype (Typ)) then
null;
-- Otherwise, comment required ???
else
-- Issue error if Set_Offset_To_Top is not available in a
-- configurable run-time environment.
if not RTE_Available (RE_Set_Offset_To_Top) then
Error_Msg_CRT ("abstract interface types", Typ);
return;
end if;
-- We generate a different call when the parent of the type has
-- discriminants.
if Typ /= Etype (Typ)
and then Has_Discriminants (Etype (Typ))
then
pragma Assert
(Present (DT_Offset_To_Top_Func (Tag_Comp)));
-- Generate:
-- Set_Offset_To_Top
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => False,
-- Offset_Value => n,
-- Offset_Func => Fn'Address)
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_False, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To
(DT_Offset_To_Top_Func (Tag_Comp), Loc),
Attribute_Name => Name_Address)))));
-- In this case the next component stores the value of the
-- offset to the top.
Prev_E := Tag_Comp;
Next_Entity (Tag_Comp);
pragma Assert (Present (Tag_Comp));
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (Tag_Comp, Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Prev_E, Loc)),
Attribute_Name => Name_Position)));
-- Normal case: No discriminants in the parent type
else
-- Generate:
-- Set_Offset_To_Top
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => True,
-- Offset_Value => n,
-- Offset_Func => null);
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_True, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
New_Reference_To
(RTE (RE_Null_Address), Loc))));
end if;
end if;
end Initialize_Tag;
---------------------------------- ----------------------------------
-- Init_Secondary_Tags_Internal -- -- Init_Secondary_Tags_Internal --
---------------------------------- ----------------------------------
procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
Args : List_Id; AI_Elmt : Elmt_Id;
Aux_N : Node_Id;
E : Entity_Id;
Iface : Entity_Id;
New_N : Node_Id;
Prev_E : Entity_Id;
begin begin
-- Climb to the ancestor (if any) handling private types -- Climb to the ancestor (if any) handling synchronized interface
-- derivations and private types
if Present (Full_View (Etype (Typ))) then if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Init_Secondary_Tags_Internal (Etype (First (Iface_List)));
end if;
end;
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then if Full_View (Etype (Typ)) /= Typ then
Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
end if; end if;
...@@ -5916,220 +6336,36 @@ package body Exp_Ch3 is ...@@ -5916,220 +6336,36 @@ package body Exp_Ch3 is
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target), Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address), Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Typ))), (Node (First_Elmt (Access_Disp_Table (Typ))),
Loc)), Loc)),
New_Occurrence_Of (Standard_True, Loc), New_Occurrence_Of (Standard_True, Loc),
Make_Integer_Literal (Loc, Uint_0), Make_Integer_Literal (Loc, Uint_0),
New_Reference_To (RTE (RE_Null_Address), Loc)))); New_Reference_To (RTE (RE_Null_Address), Loc))));
end if; end if;
if Present (Abstract_Interfaces (Typ)) if Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
then then
E := First_Entity (Typ); if not Is_Synch_Typ then
while Present (E) loop AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
if Is_Tag (E) pragma Assert (Present (AI_Tag_Comp));
and then Chars (E) /= Name_uTag end if;
then
Aux_N := Node (ADT);
pragma Assert (Present (Aux_N));
Iface := Find_Interface (Typ, E);
-- If we are compiling under the CPP full ABI compatibility
-- mode and the ancestor is a CPP_Pragma tagged type then
-- we generate code to inherit the contents of the dispatch
-- table directly from the ancestor.
if Is_CPP_Class (Etype (Typ))
and then not Debug_Flag_QQ
then
Args := New_List (
Node1 =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (E, Loc))),
Node2 =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Aux_N, Loc)),
Node3 =>
Make_Integer_Literal (Loc,
DT_Entry_Count (First_Tag_Component (Iface))));
-- Issue error if Inherit_CPP_DT is not available
-- in a configurable run-time environment.
if not RTE_Available (RE_Inherit_CPP_DT) then
Error_Msg_CRT ("cpp interfacing", Typ);
return;
end if;
New_N :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Inherit_CPP_DT),
Loc),
Parameter_Associations => Args);
Append_To (Stmts_List, New_N);
end if;
-- Initialize the pointer to the secondary DT associated
-- with the interface
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (E, Loc)),
Expression =>
New_Reference_To (Aux_N, Loc)));
-- If the ancestor is CPP_Class, nothing else to do here
if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
null;
-- Otherwise, comment required ???
else
-- Issue error if Set_Offset_To_Top is not available in a
-- configurable run-time environment.
if not RTE_Available (RE_Set_Offset_To_Top) then
Error_Msg_CRT ("abstract interface types", Typ);
return;
end if;
-- We generate a different call when the parent of the
-- type has discriminants.
if Typ /= Etype (Typ)
and then Has_Discriminants (Etype (Typ))
then
pragma Assert
(Present (DT_Offset_To_Top_Func (E)));
-- Generate:
-- Set_Offset_To_Top
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => False,
-- Offset_Value => n,
-- Offset_Func => Fn'Address)
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_False, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (E, Loc)),
Attribute_Name => Name_Position)),
Unchecked_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To
(DT_Offset_To_Top_Func (E),
Loc),
Attribute_Name =>
Name_Address)))));
-- In this case the next component stores the
-- value of the offset to the top.
Prev_E := E;
Next_Entity (E);
pragma Assert (Present (E));
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (E, Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Prev_E, Loc)),
Attribute_Name => Name_Position)));
-- Normal case: No discriminants in the parent type
else
-- Generate:
-- Set_Offset_To_Top
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => True,
-- Offset_Value => n,
-- Offset_Func => null);
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_True, Loc),
Unchecked_Convert_To AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
(RTE (RE_Storage_Offset), while Present (AI_Elmt) loop
Make_Attribute_Reference (Loc, pragma Assert (Present (Node (ADT)));
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (E, Loc)),
Attribute_Name => Name_Position)),
New_Reference_To Initialize_Tag
(RTE (RE_Null_Address), Loc)))); (Typ => Typ,
end if; Iface => Node (AI_Elmt),
end if; Tag_Comp => AI_Tag_Comp,
Iface_Tag => Node (ADT));
Next_Elmt (ADT); Next_Elmt (ADT);
end if; AI_Tag_Comp := Next_Tag_Component (AI_Tag_Comp);
Next_Elmt (AI_Elmt);
Next_Entity (E);
end loop; end loop;
end if; end if;
end Init_Secondary_Tags_Internal; end Init_Secondary_Tags_Internal;
...@@ -6150,6 +6386,11 @@ package body Exp_Ch3 is ...@@ -6150,6 +6386,11 @@ package body Exp_Ch3 is
Full_Typ := Typ; Full_Typ := Typ;
end if; end if;
if Is_Concurrent_Record_Type (Typ) then
Is_Synch_Typ := True;
AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
end if;
Init_Secondary_Tags_Internal (Full_Typ); Init_Secondary_Tags_Internal (Full_Typ);
end Init_Secondary_Tags; end Init_Secondary_Tags;
...@@ -6195,9 +6436,9 @@ package body Exp_Ch3 is ...@@ -6195,9 +6436,9 @@ package body Exp_Ch3 is
-- is needed to distinguish inherited operations from renamings -- is needed to distinguish inherited operations from renamings
-- (which also have Alias set). -- (which also have Alias set).
if Is_Abstract (Subp) if Is_Abstract_Subprogram (Subp)
and then Present (Alias (Subp)) and then Present (Alias (Subp))
and then not Is_Abstract (Alias (Subp)) and then not Is_Abstract_Subprogram (Alias (Subp))
and then not Comes_From_Source (Subp) and then not Comes_From_Source (Subp)
and then Ekind (Subp) = E_Function and then Ekind (Subp) = E_Function
and then Has_Controlling_Result (Subp) and then Has_Controlling_Result (Subp)
...@@ -6668,7 +6909,7 @@ package body Exp_Ch3 is ...@@ -6668,7 +6909,7 @@ package body Exp_Ch3 is
elsif Chars (Node (Prim)) = Name_Op_Eq elsif Chars (Node (Prim)) = Name_Op_Eq
and then Present (Alias (Node (Prim))) and then Present (Alias (Node (Prim)))
and then Is_Abstract (Alias (Node (Prim))) and then Is_Abstract_Subprogram (Alias (Node (Prim)))
then then
Eq_Needed := False; Eq_Needed := False;
exit; exit;
...@@ -6767,12 +7008,8 @@ package body Exp_Ch3 is ...@@ -6767,12 +7008,8 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then and then
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else or else (Is_Concurrent_Record_Type (Tag_Typ)
(Is_Concurrent_Record_Type (Tag_Typ) and then Has_Abstract_Interfaces (Tag_Typ)))
and then Implements_Interface (
Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then then
Append_To (Res, Append_To (Res,
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
...@@ -7002,7 +7239,7 @@ package body Exp_Ch3 is ...@@ -7002,7 +7239,7 @@ package body Exp_Ch3 is
elsif (Is_TSS (Name, TSS_Stream_Input) elsif (Is_TSS (Name, TSS_Stream_Input)
or else or else
Is_TSS (Name, TSS_Stream_Output)) Is_TSS (Name, TSS_Stream_Output))
and then Is_Abstract (Tag_Typ) and then Is_Abstract_Type (Tag_Typ)
then then
return Make_Abstract_Subprogram_Declaration (Loc, Spec); return Make_Abstract_Subprogram_Declaration (Loc, Spec);
...@@ -7147,7 +7384,7 @@ package body Exp_Ch3 is ...@@ -7147,7 +7384,7 @@ package body Exp_Ch3 is
-- Skip bodies of _Input and _Output for the abstract case, since -- Skip bodies of _Input and _Output for the abstract case, since
-- the corresponding specs are abstract (see Predef_Spec_Or_Body) -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
if not Is_Abstract (Tag_Typ) then if not Is_Abstract_Type (Tag_Typ) then
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
and then No (TSS (Tag_Typ, TSS_Stream_Input)) and then No (TSS (Tag_Typ, TSS_Stream_Input))
then then
...@@ -7181,12 +7418,8 @@ package body Exp_Ch3 is ...@@ -7181,12 +7418,8 @@ package body Exp_Ch3 is
not Restriction_Active (No_Dispatching_Calls) not Restriction_Active (No_Dispatching_Calls)
and then and then
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else or else (Is_Concurrent_Record_Type (Tag_Typ)
(Is_Concurrent_Record_Type (Tag_Typ) and then Has_Abstract_Interfaces (Tag_Typ)))
and then Implements_Interface (
Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
...@@ -7415,9 +7648,13 @@ package body Exp_Ch3 is ...@@ -7415,9 +7648,13 @@ package body Exp_Ch3 is
not (Is_Limited_Type (Typ) not (Is_Limited_Type (Typ)
and then not Has_Inheritable_Stream_Attribute) and then not Has_Inheritable_Stream_Attribute)
and then not Has_Unknown_Discriminants (Typ) and then not Has_Unknown_Discriminants (Typ)
and then RTE_Available (RE_Tag) and then not (Is_Interface (Typ)
and then RTE_Available (RE_Root_Stream_Type) and then (Is_Task_Interface (Typ)
or else Is_Protected_Interface (Typ)
or else Is_Synchronized_Interface (Typ)))
and then not Restriction_Active (No_Streams)
and then not Restriction_Active (No_Dispatch) and then not Restriction_Active (No_Dispatch)
and then not Restriction_Active (No_Streams); and then RTE_Available (RE_Tag)
and then RTE_Available (RE_Root_Stream_Type);
end Stream_Operation_OK; end Stream_Operation_OK;
end Exp_Ch3; end Exp_Ch3;
gcc/ada/exp_ch3.ads
...@@ -69,17 +69,16 @@ package Exp_Ch3 is ...@@ -69,17 +69,16 @@ package Exp_Ch3 is
Enclos_Type : Entity_Id := Empty; Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List; Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False) return List_Id; With_Default_Init : Boolean := False) return List_Id;
-- Builds a call to the initialization procedure of the Id entity. Id_Ref -- Builds a call to the initialization procedure for the base type of Typ,
-- is either a new reference to Id (for record fields), or an indexed -- passing it the object denoted by Id_Ref, plus additional parameters as
-- component (for array elements). Loc is the source location for the -- appropriate for the type (the _Master, for task types, for example).
-- constructed tree, and Typ is the type of the entity (the initialization -- Loc is the source location for the constructed tree. In_Init_Proc has
-- procedure of the base type is the procedure that actually gets called). -- to be set to True when the call is itself in an init proc in order to
-- In_Init_Proc has to be set to True when the call is itself in an init -- enable the use of discriminals. Enclos_Type is the enclosing type when
-- proc in order to enable the use of discriminals. Enclos_type is the type -- initializing a component in an outer init proc, and it is used for
-- of the init proc and it is used for various expansion cases including -- various expansion cases including the case where Typ is a task type
-- the case where Typ is a task type which is a array component, the -- which is an array component, the indices of the enclosing type are
-- indices of the enclosing type are used to build the string that -- used to build the string that identifies each task at runtime.
-- identifies each task at runtime.
-- --
-- Discr_Map is used to replace discriminants by their discriminals in -- Discr_Map is used to replace discriminants by their discriminals in
-- expressions used to constrain record components. In the presence of -- expressions used to constrain record components. In the presence of
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment