mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 13:51:00 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_disp.adb (Export_DT): Addition of a new argument (Index)...

Browse Source 
2009-04-09  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Export_DT): Addition of a new argument (Index); used to
	retrieve from the Dispatch_Table_Wrappers list the external name.
	Addition of documentation.
	(Make_Secondary_DT): Addition of a new argument (Suffix_Index) that is
	used to export secondary dispatch tables (in the previous version of
	the frontend only primary dispatch tables were exported). Addition of
	documentation.
	(Import_DT): New subprogram (internal of Make_Tags). Used to import a
	dispatch table of a given tagged type. 
	(Make_Tags): Modified to import secondary dispatch tables.

	* sem_ch3.adb (Analyze_Object_Declaration): Code cleanup.
	(Constant_Redeclaration): Code cleanup.

	* einfo.ads (Dispatch_Table_Wrapper): Renamed to
	Dispatch_Table_Wrappers.  Update documentation.

	* einfo.adb (Dispatch_Table_Wrapper, Set_Dispatch_Table_Wrapper):
	Renamed to Dispatch_Table_Wrappers.

	* sem_util.adb (Collect_Interface_Components): Improve handling of
	private types.

	* atree.ads (Elist26, Set_Elist26): New subprograms

	* atree.adb (Elist26, Set_Elist26): New subprograms

From-SVN: r145811
This commit is contained in:
Javier Miranda 2009-04-09 09:35:24 +00:00 committed by Arnaud Charlet
parent 59262ebb3e
commit b16d9747ff
8 changed files with 344 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2009-04-09 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Export_DT): Addition of a new argument (Index); used to
retrieve from the Dispatch_Table_Wrappers list the external name.
Addition of documentation.
(Make_Secondary_DT): Addition of a new argument (Suffix_Index) that is
used to export secondary dispatch tables (in the previous version of
the frontend only primary dispatch tables were exported). Addition of
documentation.
(Import_DT): New subprogram (internal of Make_Tags). Used to import a
dispatch table of a given tagged type.
(Make_Tags): Modified to import secondary dispatch tables.
* sem_ch3.adb (Analyze_Object_Declaration): Code cleanup.
(Constant_Redeclaration): Code cleanup.
* einfo.ads (Dispatch_Table_Wrapper): Renamed to
Dispatch_Table_Wrappers. Update documentation.
* einfo.adb (Dispatch_Table_Wrapper, Set_Dispatch_Table_Wrapper):
Renamed to Dispatch_Table_Wrappers.
* sem_util.adb (Collect_Interface_Components): Improve handling of
private types.
* atree.ads (Elist26, Set_Elist26): New subprograms
* atree.adb (Elist26, Set_Elist26): New subprograms
2009-04-09 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Build_Derived_Record_Type): Fix typo.

17
gcc/ada/atree.adb
View File

@ -3305,6 +3305,17 @@ package body Atree is
end if;
end Elist25;
function Elist26 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 4).Field8;
begin
if Value = 0 then
return No_Elist;
else
return Elist_Id (Value);
end if;
end Elist26;
function Name1 (N : Node_Id) return Name_Id is
begin
pragma Assert (N <= Nodes.Last);
@ -5422,6 +5433,12 @@ package body Atree is
Nodes.Table (N + 4).Field7 := Union_Id (Val);
end Set_Elist25;
procedure Set_Elist26 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field8 := Union_Id (Val);
end Set_Elist26;
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
pragma Assert (N <= Nodes.Last);

8
gcc/ada/atree.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1060,6 +1060,9 @@ package Atree is
function Elist25 (N : Node_Id) return Elist_Id;
pragma Inline (Elist25);
function Elist26 (N : Node_Id) return Elist_Id;
pragma Inline (Elist26);
function Name1 (N : Node_Id) return Name_Id;
pragma Inline (Name1);
@ -2090,6 +2093,9 @@ package Atree is
procedure Set_Elist25 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist25);
procedure Set_Elist26 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist26);
procedure Set_Name1 (N : Node_Id; Val : Name_Id);
pragma Inline (Set_Name1);

20
gcc/ada/einfo.adb
View File

@ -214,7 +214,7 @@ package body Einfo is
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrapper Node26
-- Dispatch_Table_Wrappers Elist26
-- Last_Assignment Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
@ -851,11 +851,11 @@ package body Einfo is
return Uint15 (Id);
end Discriminant_Number;
function Dispatch_Table_Wrapper (Id : E) return E is
function Dispatch_Table_Wrappers (Id : E) return L is
begin
pragma Assert (Is_Tagged_Type (Id));
return Node26 (Implementation_Base_Type (Id));
end Dispatch_Table_Wrapper;
return Elist26 (Implementation_Base_Type (Id));
end Dispatch_Table_Wrappers;
function DT_Entry_Count (Id : E) return U is
begin
@ -3262,11 +3262,11 @@ package body Einfo is
Set_Uint15 (Id, V);
end Set_Discriminant_Number;
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E) is
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
Set_Node26 (Id, V);
end Set_Dispatch_Table_Wrapper;
Set_Elist26 (Id, V);
end Set_Dispatch_Table_Wrappers;
procedure Set_DT_Entry_Count (Id : E; V : U) is
begin
@ -8659,10 +8659,10 @@ package body Einfo is
when E_Record_Type |
E_Record_Type_With_Private =>
Write_Str ("Dispatch_Table_Wrapper");
Write_Str ("Dispatch_Table_Wrappers");
when E_In_Out_Parameter |
E_Out_Parameter |
when E_In_Out_Parameter |
E_Out_Parameter |
E_Variable =>
Write_Str ("Last_Assignment");

18
gcc/ada/einfo.ads
View File

@ -816,11 +816,11 @@ package Einfo is
-- the list of discriminants of the type, i.e. a sequential integer
-- index starting at 1 and ranging up to Number_Discriminants.
-- Dispatch_Table_Wrapper (Node26) [implementation base type only]
-- Dispatch_Table_Wrappers (Elist26) [implementation base type only]
-- Present in library level record type entities if we are generating
-- statically allocated dispatch tables. For a tagged type, points to
-- the dispatch table wrapper associated with the tagged type. For a
-- non-tagged record, contains Empty.
-- the list of dispatch table wrappers associated with the tagged type.
-- For a non-tagged record, contains No_Elist.
-- DTC_Entity (Node16)
-- Present in function and procedure entities. Set to Empty unless
@ -5360,7 +5360,7 @@ package Einfo is
-- E_Record_Subtype
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
@ -5395,7 +5395,7 @@ package Einfo is
-- E_Record_Subtype_With_Private
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@ -5785,7 +5785,7 @@ package Einfo is
function Current_Value (Id : E) return N;
function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E;
function Dispatch_Table_Wrapper (Id : E) return E;
function Dispatch_Table_Wrappers (Id : E) return L;
function DTC_Entity (Id : E) return E;
function DT_Entry_Count (Id : E) return U;
function DT_Offset_To_Top_Func (Id : E) return E;
@ -6313,7 +6313,7 @@ package Einfo is
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E);
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
@ -6994,7 +6994,7 @@ package Einfo is
pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
pragma Inline (Dispatch_Table_Wrapper);
pragma Inline (Dispatch_Table_Wrappers);
pragma Inline (DTC_Entity);
pragma Inline (DT_Entry_Count);
pragma Inline (DT_Offset_To_Top_Func);
@ -7421,7 +7421,7 @@ package Einfo is
pragma Inline (Set_Current_Value);
pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link);
pragma Inline (Set_Dispatch_Table_Wrapper);
pragma Inline (Set_Dispatch_Table_Wrappers);
pragma Inline (Set_DTC_Entity);
pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func);

378
gcc/ada/exp_disp.adb
View File

@ -3150,13 +3150,19 @@ package body Exp_Disp is
-- freezes a tagged type, when one of its primitive operations has a
-- type in its profile whose full view has not been analyzed yet.
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id);
-- Export the dispatch table entity DT of tagged type Typ. Required to
-- generate forward references and statically allocate the table.
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- forward references and statically allocate the table. For primary
-- dispatch tables Index is 0; for secondary dispatch tables the value
-- of index must match the Suffix_Index value assigned to the table by
-- Make_Tags when generating its unique external name, and it is used to
-- retrieve from the Dispatch_Table_Wrappers list associated with Typ
-- the external name generated by Import_DT.
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
@ -3171,7 +3177,12 @@ package body Exp_Disp is
-- calls through interface types; the latter secondary table is
-- generated when Build_Thunks is False, and provides support for
-- Generic Dispatching Constructors that dispatch calls through
-- interface types.
-- interface types. When constructing this latter table the value
-- of Suffix_Index is -1 to indicate that there is no need to export
-- such table when building statically allocated dispatch tables; a
-- positive value of Suffix_Index must match the Suffix_Index value
-- assigned to this secondary dispatch table by Make_Tags when its
-- unique external name was generated.
------------------------------
-- Check_Premature_Freezing --
@ -3200,14 +3211,29 @@ package body Exp_Disp is
-- Export_DT --
---------------
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
is
Count : Nat;
Elmt : Elmt_Id;
begin
Set_Is_Statically_Allocated (DT);
Set_Is_True_Constant (DT);
Set_Is_Exported (DT);
pragma Assert (Present (Dispatch_Table_Wrapper (Typ)));
Get_External_Name (Dispatch_Table_Wrapper (Typ), True);
Count := 0;
Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
while Count /= Index loop
Next_Elmt (Elmt);
Count := Count + 1;
end loop;
pragma Assert (Related_Type (Node (Elmt)) = Typ);
Get_External_Name
(Entity => Node (Elmt),
Has_Suffix => True);
Set_Interface_Name (DT,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
@ -3225,6 +3251,7 @@ package body Exp_Disp is
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
@ -3232,13 +3259,16 @@ package body Exp_Disp is
Result : List_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
Name_DT : constant Name_Id := New_Internal_Name ('T');
Exporting_Table : constant Boolean :=
Building_Static_DT (Typ)
and then Suffix_Index > 0;
Iface_DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT);
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
Predef_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_Predef_Prims);
Chars => Name_Predef_Prims);
DT_Constr_List : List_Id;
DT_Aggr_List : List_Id;
Empty_DT : Boolean := False;
@ -3273,10 +3303,10 @@ package body Exp_Disp is
Set_Is_True_Constant (Iface_DT);
end if;
-- Generate code to create the storage for the Dispatch_Table object.
-- If the number of primitives of Typ is 0 we reserve a dummy single
-- entry for its DT because at run-time the pointer to this dummy
-- entry will be used as the tag.
-- Calculate the number of slots of the dispatch table. If the number
-- of primitives of Typ is 0 we reserve a dummy single entry for its
-- DT because at run-time the pointer to this dummy entry will be
-- used as the tag.
if Num_Iface_Prims = 0 then
Empty_DT := True;
@ -3432,6 +3462,7 @@ package body Exp_Disp is
-- prim-op-2'address,
-- ...
-- prim-op-n'address));
-- for Iface_DT'Alignment use Address'Alignment;
-- Stage 3: Initialize the discriminant and the record components
@ -3686,10 +3717,16 @@ package body Exp_Disp is
Append_Elmt (New_Node, DT_Aggr);
-- Note: Secondary dispatch tables cannot be declared constant
-- because the component Offset_To_Top is currently initialized
-- by the IP routine.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT,
Aliased_Present => True,
Constant_Present => False,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
@ -3697,54 +3734,68 @@ package body Exp_Disp is
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List)),
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
Expression =>
Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Iface_DT, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
if Exporting_Table then
Export_DT (Typ, Iface_DT, Suffix_Index);
-- Generate code to create the pointer to the dispatch table
-- Iface_DT_Ptr : Tag := Tag!(DT'Address);
-- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT_Ptr,
Constant_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Interface_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iface_DT, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
-- Note: This declaration is not added here if the table is exported
-- because in such case Make_Tags has already added this declaration.
else
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT_Ptr,
Constant_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Interface_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iface_DT, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
end if;
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
Constant_Present => True,
Object_Definition =>
Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc),
Expression =>
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iface_DT, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Predef_Prims), Loc)),
Prefix => New_Reference_To (Iface_DT, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
-- Remember entities containing dispatch tables
@ -3927,7 +3978,14 @@ package body Exp_Disp is
if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
Suffix_Index := 0;
-- Each secondary dispatch table is assigned an unique positive
-- suffix index; such value also corresponds with the location of
-- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
-- Note: This value must be kept sync with the Suffix_Index values
-- generated by Make_Tags
Suffix_Index := 1;
AI_Tag_Elmt :=
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
@ -3939,16 +3997,18 @@ package body Exp_Disp is
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
Suffix_Index => Suffix_Index,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True,
Result => Result);
-- Skip secondary dispatch table and secondary dispatch table of
-- predefined primitives
Next_Elmt (AI_Tag_Elmt);
-- Skip the secondary dispatch table of predefined primitives
Next_Elmt (AI_Tag_Elmt);
-- Build the secondary table containing pointers to primitives
@ -3957,16 +4017,18 @@ package body Exp_Disp is
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
Suffix_Index => -1,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => False,
Result => Result);
-- Skip secondary dispatch table and secondary dispatch table of
-- predefined primitives
Next_Elmt (AI_Tag_Elmt);
-- Skip the secondary dispatch table of predefined primitives
Next_Elmt (AI_Tag_Elmt);
Suffix_Index := Suffix_Index + 1;
@ -5177,7 +5239,8 @@ package body Exp_Disp is
end if;
end if;
-- Initialize the table of ancestor tags
-- Initialize the table of ancestor tags if not building static
-- dispatch table
if not Building_Static_DT (Typ)
and then not Is_Interface (Typ)
@ -5202,11 +5265,10 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if;
-- Inherit the dispatch tables of the parent
-- There is no need to inherit anything from the parent when building
-- static dispatch tables because the whole dispatch table (including
-- inherited primitives) has been already built.
-- Inherit the dispatch tables of the parent. There is no need to
-- inherit anything from the parent when building static dispatch tables
-- because the whole dispatch table (including inherited primitives) has
-- been already built.
if Building_Static_DT (Typ) then
null;
@ -5486,8 +5548,8 @@ package body Exp_Disp is
Analyze_List (Result, Suppress => All_Checks);
Set_Has_Dispatch_Table (Typ);
-- Mark entities containing dispatch tables. Required by the
-- backend to handle them properly.
-- Mark entities containing dispatch tables. Required by the backend to
-- handle them properly.
if not Is_Interface (Typ) then
declare
@ -5687,20 +5749,116 @@ package body Exp_Disp is
---------------
function Make_Tags (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Loc : constant Source_Ptr := Sloc (Typ);
Result : constant List_Id := New_List;
procedure Import_DT
(Tag_Typ : Entity_Id;
DT : Entity_Id;
Is_Secondary_DT : Boolean);
-- Import the dispatch table DT of tagged type Tag_Typ. Required to
-- generate forward references and statically allocate the table. For
-- primary dispatch tables that require no dispatch table generate:
-- DT : static aliased constant Non_Dispatch_Table_Wrapper;
-- $pragma import (ada, DT);
-- Otherwise generate:
-- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
-- $pragma import (ada, DT);
---------------
-- Import_DT --
---------------
procedure Import_DT
(Tag_Typ : Entity_Id;
DT : Entity_Id;
Is_Secondary_DT : Boolean)
is
DT_Constr_List : List_Id;
Nb_Prim : Nat;
begin
Set_Is_Imported (DT);
Set_Ekind (DT, E_Constant);
Set_Related_Type (DT, Typ);
-- The scope must be set now to call Get_External_Name
Set_Scope (DT, Current_Scope);
Get_External_Name (DT, True);
Set_Interface_Name (DT,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Ensure proper Sprint output of this implicit importation
Set_Is_Internal (DT);
-- Save this entity to allow Make_DT to generate its exportation
Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
-- No dispatch table required
if not Is_Secondary_DT
and then not Has_DT (Tag_Typ)
then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
Constant_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
else
-- Calculate the number of primitives of the dispatch table and
-- the size of the Type_Specific_Data record.
Nb_Prim :=
UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
-- If the tagged type has no primitives we add a dummy slot
-- whose address will be the tag of this type.
if Nb_Prim = 0 then
DT_Constr_List :=
New_List (Make_Integer_Literal (Loc, 1));
else
DT_Constr_List :=
New_List (Make_Integer_Literal (Loc, Nb_Prim));
end if;
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
Constant_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
end if;
end Import_DT;
-- Local variables
Tname : constant Name_Id := Chars (Typ);
Result : constant List_Id := New_List;
AI_Tag_Comp : Elmt_Id;
DT : Node_Id;
DT_Constr_List : List_Id;
DT_Ptr : Node_Id;
Predef_Prims_Ptr : Node_Id;
Iface_DT : Node_Id;
Iface_DT_Ptr : Node_Id;
Nb_Prim : Nat;
Suffix_Index : Int;
Typ_Name : Name_Id;
Typ_Comps : Elist_Id;
-- Start of processing for Make_Tags
begin
-- 1) Generate the primary and secondary tag entities
@ -5729,63 +5887,15 @@ package body Exp_Disp is
-- (Make_DT will take care of its exportation)
if Building_Static_DT (Typ) then
Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
DT :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Tname, 'T'));
-- Generate:
-- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
-- $pragma import (ada, DT);
Set_Is_Imported (DT);
-- The scope must be set now to call Get_External_Name
Set_Scope (DT, Current_Scope);
Get_External_Name (DT, True);
Set_Interface_Name (DT,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Ensure proper Sprint output of this implicit importation
Set_Is_Internal (DT);
-- Save this entity to allow Make_DT to generate its exportation
Set_Dispatch_Table_Wrapper (Typ, DT);
Import_DT (Typ, DT, Is_Secondary_DT => False);
if Has_DT (Typ) then
-- Calculate the number of primitives of the dispatch table and
-- the size of the Type_Specific_Data record.
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
-- If the tagged type has no primitives we add a dummy slot
-- whose address will be the tag of this type.
if Nb_Prim = 0 then
DT_Constr_List :=
New_List (Make_Integer_Literal (Loc, 1));
else
DT_Constr_List :=
New_List (Make_Integer_Literal (Loc, Nb_Prim));
end if;
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
Constant_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
@ -5821,14 +5931,6 @@ package body Exp_Disp is
-- No dispatch table required
else
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
Constant_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
@ -5858,7 +5960,12 @@ package body Exp_Disp is
-- 2) Generate the secondary tag entities
if Has_Interfaces (Typ) then
Suffix_Index := 0;
-- Note: The following value of Suffix_Index must be in sync with
-- the Suffix_Index values of secondary dispatch tables generated
-- by Make_DT.
Suffix_Index := 1;
-- For each interface type we build an unique external name
-- associated with its corresponding secondary dispatch table.
@ -5872,9 +5979,19 @@ package body Exp_Disp is
while Present (AI_Tag_Comp) loop
Get_Secondary_DT_External_Name
(Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
Typ_Name := Name_Find;
if Building_Static_DT (Typ) then
Iface_DT :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name
(Typ_Name, 'T', Suffix_Index => -1));
Import_DT
(Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
DT => Iface_DT,
Is_Secondary_DT => True);
end if;
-- Secondary dispatch table referencing thunks to user-defined
-- primitives covered by this interface.
@ -5892,6 +6009,25 @@ package body Exp_Disp is
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
if Building_Static_DT (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Interface_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iface_DT, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
end if;
-- Secondary dispatch table referencing thunks to predefined
-- primitives.

24
gcc/ada/sem_ch3.adb
View File

@ -2416,17 +2416,6 @@ package body Sem_Ch3 is
if Constant_Present (N)
and then No (E)
then
-- We exclude forward references to tags
if Is_Imported (Defining_Identifier (N))
and then
(T = RTE (RE_Tag)
or else
(Present (Full_View (T))
and then Full_View (T) = RTE (RE_Tag)))
then
null;
-- A deferred constant may appear in the declarative part of the
-- following constructs:
@ -2444,7 +2433,7 @@ package body Sem_Ch3 is
-- return statements are flagged as invalid contexts because they do
-- not have a declarative part and so cannot accommodate the pragma.
elsif Ekind (Current_Scope) = E_Return_Statement then
if Ekind (Current_Scope) = E_Return_Statement then
Error_Msg_N
("invalid context for deferred constant declaration (RM 7.4)",
N);
@ -9328,19 +9317,10 @@ package body Sem_Ch3 is
Error_Msg_N ("ALIASED required (see declaration#)", N);
end if;
-- Allow incomplete declaration of tags (used to handle forward
-- references to tags). The check on Ada_Tags avoids circularities
-- when rebuilding the compiler.
if RTU_Loaded (Ada_Tags)
and then T = RTE (RE_Tag)
then
null;
-- Check that placement is in private part and that the incomplete
-- declaration appeared in the visible part.
elsif Ekind (Current_Scope) = E_Package
if Ekind (Current_Scope) = E_Package
and then not In_Private_Part (Current_Scope)
then
Error_Msg_Sloc := Sloc (Prev);

17
gcc/ada/sem_util.adb
View File

@ -1356,10 +1356,19 @@ package body Sem_Util is
-------------
procedure Collect (Typ : Entity_Id) is
Tag_Comp : Entity_Id;
Tag_Comp : Entity_Id;
Parent_Typ : Entity_Id;
begin
if Etype (Typ) /= Typ
-- Handle private types
if Present (Full_View (Etype (Typ))) then
Parent_Typ := Full_View (Etype (Typ));
else
Parent_Typ := Etype (Typ);
end if;
if Parent_Typ /= Typ
-- Protect the frontend against wrong sources. For example:
@ -1372,9 +1381,9 @@ package body Sem_Util is
-- type C is new B with null record;
-- end P;
and then Etype (Typ) /= Tagged_Type
and then Parent_Typ /= Tagged_Type
then
Collect (Etype (Typ));
Collect (Parent_Typ);
end if;
-- Collect the components containing tags of secondary dispatch