diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1ad4a404e8e04f76063c939cc355fb14a320e140..05182f88f973e59c327274f859adc676f5a0acba 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,24 +1,3 @@
-2007-09-11 Javier Miranda <miranda@adacore.com>
-
- * einfo.ads, einfo.adb (Dispatch_Table_Wrapper): New attribute. Present
- in library level record type entities if we are generating statically
- allocated dispatch tables.
-
- * exp_disp.adb (Make_Tags/Make_DT): Replace previous code
- importing/exporting the _tag declaration by new code
- importing/exporting the dispatch table wrapper. This change allows us
- to statically allocate of the TSD.
- (Make_DT.Export_DT): New procedure.
- (Build_Static_DT): New function.
- (Has_DT): New function.
-
- * freeze.adb (Freeze_Static_Object): Code cleanup: Do not reset flags
- True_Constant and Current_Value. Required to statically
- allocate the dispatch tables.
- (Check_Allocator): Make function iterative instead of recursive.
- Also return inner allocator node, when present, so that we do not have
- to look for that node again in the caller.
-
2007-09-11 Jan Hubicka <jh@suse.cz>
* misc.c (gnat_expand_body): Kill.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index fad178003e5a7fd7a3a873865acd3eb92727118d..7b705b02f20d5da02cc2aacfa4fc2c0779970582 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -217,7 +217,6 @@ package body Einfo is
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
- -- Dispatch_Table_Wrapper Node16
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Related_Interface Node26
@@ -843,12 +842,6 @@ package body Einfo is
return Uint15 (Id);
end Discriminant_Number;
- function Dispatch_Table_Wrapper (Id : E) return E is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Node26 (Implementation_Base_Type (Id));
- end Dispatch_Table_Wrapper;
-
function DT_Entry_Count (Id : E) return U is
begin
pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
@@ -3123,12 +3116,6 @@ package body Einfo is
Set_Uint15 (Id, V);
end Set_Discriminant_Number;
- procedure Set_Dispatch_Table_Wrapper (Id : E; V : E) is
- begin
- pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
- Set_Node26 (Id, V);
- end Set_Dispatch_Table_Wrapper;
-
procedure Set_DT_Entry_Count (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Component);
@@ -8266,10 +8253,6 @@ package body Einfo is
Write_Str ("Static_Initialization");
end if;
- when E_Record_Type |
- E_Record_Type_With_Private =>
- Write_Str ("Dispatch_Table_Wrapper");
-
when others =>
Write_Str ("Field26??");
end case;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b95165ba3b0db464a42943415fe7827864359d69..924472bc1839163edb8f062329164c69f3295d58 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -819,12 +819,6 @@ 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]
--- 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.
-
-- DTC_Entity (Node16)
-- Present in function and procedure entities. Set to Empty unless
-- the subprogram is dispatching in which case it references the
@@ -5126,7 +5120,6 @@ package Einfo is
-- E_Record_Subtype
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
- -- Dispatch_Table_Wrapper (Node26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
@@ -5160,7 +5153,6 @@ 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)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@@ -5555,7 +5547,6 @@ 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 DTC_Entity (Id : E) return E;
function DT_Entry_Count (Id : E) return U;
function DT_Offset_To_Top_Func (Id : E) return E;
@@ -6057,7 +6048,6 @@ package Einfo is
procedure Set_Abstract_Interfaces (Id : E; V : L);
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_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
@@ -6686,7 +6676,6 @@ package Einfo is
pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
- pragma Inline (Dispatch_Table_Wrapper);
pragma Inline (DTC_Entity);
pragma Inline (DT_Entry_Count);
pragma Inline (DT_Offset_To_Top_Func);
@@ -7091,7 +7080,6 @@ 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_DTC_Entity);
pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func);
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 2d663baf6c2d67265f17c6b7b5baa182f517fe6b..1eb0624c287ce2fd3c0ac192975be71496d6665d 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -10,13 +10,14 @@
-- --
-- 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- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
@@ -66,18 +67,10 @@ package body Exp_Disp is
-- Local Subprograms --
-----------------------
- function Building_Static_DT (Typ : Entity_Id) return Boolean;
- pragma Inline (Building_Static_DT);
- -- Returns true when building statically allocated dispatch tables
-
function Default_Prim_Op_Position (E : Entity_Id) return Uint;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
- function Has_DT (Typ : Entity_Id) return Boolean;
- pragma Inline (Has_DT);
- -- Returns true if we generate a dispatch table for tagged type Typ
-
function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (ie. through a renaming)
@@ -97,16 +90,6 @@ package body Exp_Disp is
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value.
- ------------------------
- -- Building_Static_DT --
- ------------------------
-
- function Building_Static_DT (Typ : Entity_Id) return Boolean is
- begin
- return Static_Dispatch_Tables
- and then Is_Library_Level_Tagged_Type (Typ);
- end Building_Static_DT;
-
----------------------------------
-- Build_Static_Dispatch_Tables --
----------------------------------
@@ -1445,16 +1428,6 @@ package body Exp_Disp is
end if;
end Expand_Interface_Thunk;
- ------------
- -- Has_DT --
- ------------
-
- function Has_DT (Typ : Entity_Id) return Boolean is
- begin
- return not Is_Interface (Typ)
- and then not Restriction_Active (No_Dispatching_Calls);
- end Has_DT;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
@@ -2461,6 +2434,14 @@ package body Exp_Disp is
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
+ Has_DT : constant Boolean :=
+ not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls);
+
+ Build_Static_DT : constant Boolean :=
+ Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Typ);
+
Max_Predef_Prims : constant Int :=
UI_To_Int
(Intval
@@ -2479,10 +2460,6 @@ 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 Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
@@ -2519,28 +2496,6 @@ package body Exp_Disp is
end if;
end Check_Premature_Freezing;
- ---------------
- -- Export_DT --
- ---------------
-
- procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
- 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);
- 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);
- Set_Is_Public (DT);
- end Export_DT;
-
-----------------------
-- Make_Secondary_DT --
-----------------------
@@ -2553,6 +2508,7 @@ package body Exp_Disp is
Result : List_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
+ Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
Name_DT : constant Name_Id := New_Internal_Name ('T');
Iface_DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT);
@@ -2577,7 +2533,7 @@ package body Exp_Disp is
-- Handle cases in which we do not generate statically allocated
-- dispatch tables.
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
Set_Ekind (Predef_Prims, E_Variable);
Set_Is_Statically_Allocated (Predef_Prims);
@@ -2620,7 +2576,7 @@ package body Exp_Disp is
-- Stage 1: Calculate the number of predefined primitives
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
Nb_Predef_Prims := Max_Predef_Prims;
else
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
@@ -2694,7 +2650,7 @@ package body Exp_Disp is
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
- Constant_Present => Building_Static_DT (Typ),
+ Constant_Present => Build_Static_DT,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
@@ -2902,7 +2858,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Null_Address), Loc));
elsif Is_Abstract_Type (Typ)
- or else not Building_Static_DT (Typ)
+ or else not Build_Static_DT
then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List,
@@ -3007,7 +2963,7 @@ package body Exp_Disp is
Object_Definition =>
New_Reference_To (RTE (RE_Interface_Tag), Loc),
Expression =>
- Unchecked_Convert_To (RTE (RE_Interface_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
@@ -3022,13 +2978,14 @@ package body Exp_Disp is
-- Local variables
Elab_Code : constant List_Id := New_List;
+ Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
Result : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ);
AI : Elmt_Id;
- AI_Ptr_Elmt : Elmt_Id;
AI_Tag_Comp : Elmt_Id;
- DT_Aggr_List : List_Id;
+ AI_Ptr_Elmt : Elmt_Id;
DT_Constr_List : List_Id;
+ DT_Aggr_List : List_Id;
DT_Ptr : Entity_Id;
ITable : Node_Id;
I_Depth : Nat := 0;
@@ -3109,7 +3066,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True,
Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
New_Reference_To (RTE (RE_Null_Address), Loc))));
Analyze_List (Result, Suppress => All_Checks);
@@ -3139,10 +3096,10 @@ package body Exp_Disp is
-- be referenced (otherwise we have problems with the backend). It is
-- not a requirement with nonstatic dispatch tables because in this case
-- we generate now an empty dispatch table; the extra code required to
- -- register the primitives in the slots will be generated later --- when
+ -- register the primitive in the slot will be generated later --- when
-- each primitive is frozen (see Freeze_Subprogram).
- if Building_Static_DT (Typ)
+ if Build_Static_DT
and then not Is_CPP_Class (Typ)
then
declare
@@ -3180,6 +3137,49 @@ package body Exp_Disp is
end;
end if;
+ -- In case of locally defined tagged type we declare the object
+ -- contanining the dispatch table by means of a variable. Its
+ -- initialization is done later by means of an assignment. This is
+ -- required to generate its External_Tag.
+
+ if not Build_Static_DT then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ Set_Ekind (DT, E_Variable);
+
+ -- Export the declaration of the tag previously generated and imported
+ -- by Make_Tags.
+
+ else
+ DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'C', Suffix_Index => -1));
+ Set_Ekind (DT_Ptr, E_Constant);
+ Set_Is_Statically_Allocated (DT_Ptr);
+ Set_Is_True_Constant (DT_Ptr);
+
+ Set_Is_Exported (DT_Ptr);
+ Get_External_Name (Node (First_Elmt (Access_Disp_Table (Typ))), True);
+ Set_Interface_Name (DT_Ptr,
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ -- Set tag as internal to ensure proper Sprint output of its implicit
+ -- exportation.
+
+ Set_Is_Internal (DT_Ptr);
+
+ Set_Ekind (DT, E_Constant);
+ Set_Is_True_Constant (DT);
+
+ -- The tag is made public to ensure its availability to the linker
+ -- (to handle the forward reference). This is required to handle
+ -- tagged types defined in library level package bodies.
+
+ Set_Is_Public (DT_Ptr);
+ end if;
+
+ Set_Is_Statically_Allocated (DT);
+
-- Ada 2005 (AI-251): Build the secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
@@ -3204,15 +3204,24 @@ package body Exp_Disp is
end loop;
end if;
- -- Get the _tag entity and the number of primitives of its dispatch
- -- table.
+ -- Calculate the number of primitives of the dispatch table and the
+ -- size of the Type_Specific_Data record.
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ if Has_DT then
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ end if;
- Set_Is_Statically_Allocated (DT);
+ Set_Ekind (SSD, E_Constant);
Set_Is_Statically_Allocated (SSD);
+ Set_Is_True_Constant (SSD);
+
+ Set_Ekind (TSD, E_Constant);
Set_Is_Statically_Allocated (TSD);
+ Set_Is_True_Constant (TSD);
+
+ Set_Ekind (Exname, E_Constant);
+ Set_Is_Statically_Allocated (Exname);
+ Set_Is_True_Constant (Exname);
-- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in
@@ -3237,14 +3246,14 @@ package body Exp_Disp is
-- initialization is done later by means of an assignment. This is
-- required to generate its External_Tag.
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
-- Generate:
-- DT : No_Dispatch_Table_Wrapper;
-- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
- if not Has_DT (Typ) then
+ if not Has_DT then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
@@ -3270,7 +3279,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True,
Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
@@ -3325,7 +3334,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True,
Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
@@ -3350,9 +3359,6 @@ package body Exp_Disp is
Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ)))));
- Set_Is_Statically_Allocated (Exname);
- Set_Is_True_Constant (Exname);
-
-- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb).
@@ -3366,7 +3372,7 @@ package body Exp_Disp is
-- Transportable => <<boolean-value>>,
-- RC_Offset => <<integer-value>>,
-- [ Interfaces_Table => <<access-value>> ]
- -- [ SSD => SSD_Table'Address ]
+ -- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
-- ...);
@@ -3705,7 +3711,7 @@ package body Exp_Disp is
-- Iface_Tag
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Node (AI)))),
Loc)),
@@ -3781,7 +3787,7 @@ package body Exp_Disp is
if RTE_Record_Component_Available (RE_SSD) then
if Ada_Version >= Ada_05
- and then Has_DT (Typ)
+ and then Has_DT
and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ)
and then Nb_Prim > 0
@@ -3839,18 +3845,48 @@ package body Exp_Disp is
-- must fill position 0 with null because we still have not
-- generated the tag of Typ.
- if not Building_Static_DT (Typ)
+ if not Build_Static_DT
or else Is_Interface (Typ)
then
Append_To (TSD_Tags_List,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)));
- -- Otherwise we can safely reference the tag.
+ -- Otherwise we can safely import the tag. The name must be unique
+ -- over the compilation unit, to avoid conflicts when types of the
+ -- same name appear in different nested packages. We don't need to
+ -- use an external name because this name is only locally used.
else
- Append_To (TSD_Tags_List,
- New_Reference_To (DT_Ptr, Loc));
+ declare
+ Imported_DT_Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('D'));
+
+ begin
+ Set_Is_Imported (Imported_DT_Ptr);
+ Set_Is_Statically_Allocated (Imported_DT_Ptr);
+ Set_Is_True_Constant (Imported_DT_Ptr);
+ Get_External_Name
+ (Node (First_Elmt (Access_Disp_Table (Typ))), True);
+ Set_Interface_Name (Imported_DT_Ptr,
+ Make_String_Literal (Loc, String_From_Name_Buffer));
+
+ -- Set tag as internal to ensure proper Sprint output of its
+ -- implicit importation.
+
+ Set_Is_Internal (Imported_DT_Ptr);
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Imported_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag),
+ Loc)));
+
+ Append_To (TSD_Tags_List,
+ New_Reference_To (Imported_DT_Ptr, Loc));
+ end;
end if;
-- Fill the rest of the table with the tags of the ancestors
@@ -3900,7 +3936,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
- Constant_Present => Building_Static_DT (Typ),
+ Constant_Present => Build_Static_DT,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
@@ -3913,8 +3949,6 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc,
Expressions => TSD_Aggr_List)));
- Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
-
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (TSD, Loc),
@@ -3924,9 +3958,15 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- -- Initialize or declare the dispatch table object
+ -- Generate the dummy Dispatch_Table object associated with tagged
+ -- types that have no dispatch table.
+
+ -- DT : No_Dispatch_Table :=
+ -- (NDT_TSD => TSD'Address;
+ -- NDT_Prims_Ptr => 0);
+ -- for DT'Alignment use Address'Alignment
- if not Has_DT (Typ) then
+ if not Has_DT then
DT_Constr_List := New_List;
DT_Aggr_List := New_List;
@@ -3943,26 +3983,17 @@ package body Exp_Disp is
-- In case of locally defined tagged types we have already declared
-- and uninitialized object for the dispatch table, which is now
- -- initialized by means of the following assignment:
-
- -- DT := (TSD'Address, 0);
+ -- initialized by means of an assignment.
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
Append_To (Result,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc),
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
- -- In case of library level tagged types we declare and export now
- -- the constant object containing the dummy dispatch table. There
- -- is no need to declare the tag here because it has been previously
- -- declared by Make_Tags
-
- -- DT : aliased constant No_Dispatch_Table :=
- -- (NDT_TSD => TSD'Address;
- -- NDT_Prims_Ptr => 0);
- -- for DT'Alignment use Address'Alignment;
+ -- In case of library level tagged types we declare now the constant
+ -- object containing the dispatch table.
else
Append_To (Result,
@@ -3985,7 +4016,21 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- Export_DT (Typ, DT);
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
end if;
-- Common case: Typ has a dispatch table
@@ -4016,7 +4061,7 @@ package body Exp_Disp is
Pos : Nat;
begin
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
Nb_Predef_Prims := Max_Predef_Prims;
else
@@ -4052,7 +4097,7 @@ package body Exp_Disp is
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- if Building_Static_DT (Typ)
+ if Build_Static_DT
and then Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Abstract_Subprogram (Prim)
and then not Present (Prim_Table
@@ -4087,7 +4132,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
Aliased_Present => True,
- Constant_Present => Building_Static_DT (Typ),
+ Constant_Present => Build_Static_DT,
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc,
@@ -4163,7 +4208,7 @@ package body Exp_Disp is
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
- elsif not Building_Static_DT (Typ) then
+ elsif not Build_Static_DT then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
@@ -4234,15 +4279,15 @@ package body Exp_Disp is
-- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment.
- if not Building_Static_DT (Typ) then
+ if not Build_Static_DT then
Append_To (Result,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc),
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
- -- In case of library level tagged types we declare now and export
- -- the constant object containing the dispatch table.
+ -- In case of library level tagged types we declare now the constant
+ -- object containing the dispatch table.
else
Append_To (Result,
@@ -4269,13 +4314,27 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
- Export_DT (Typ, DT);
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
end if;
end if;
-- Initialize the table of ancestor tags
- if not Building_Static_DT (Typ)
+ if not Build_Static_DT
and then not Is_Interface (Typ)
and then not Is_CPP_Class (Typ)
then
@@ -4298,7 +4357,7 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if;
- if Building_Static_DT (Typ) then
+ if Build_Static_DT then
null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables
@@ -4317,10 +4376,10 @@ package body Exp_Disp is
Null_Parent_Tag := True;
Old_Tag1 :=
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
Old_Tag2 :=
- Unchecked_Convert_To (RTE (RE_Tag),
+ Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
else
@@ -4704,14 +4763,14 @@ package body Exp_Disp is
function Make_Tags (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
+ Build_Static_DT : constant Boolean :=
+ Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Typ);
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;
Iface_DT_Ptr : Node_Id;
- Nb_Prim : Nat;
Suffix_Index : Int;
Typ_Name : Name_Id;
Typ_Comps : Elist_Id;
@@ -4730,116 +4789,30 @@ package body Exp_Disp is
DT_Ptr := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'P'));
Set_Etype (DT_Ptr, RTE (RE_Tag));
+ Set_Ekind (DT_Ptr, E_Variable);
- -- Import the forward declaration of the Dispatch Table wrapper record
- -- (Make_DT will take care of its exportation)
-
- if Building_Static_DT (Typ)
- and then not Is_CPP_Class (Typ)
- then
- DT := Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'T'));
-
- -- Generate:
- -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
- -- $pragma import (ada, DT);
-
- Set_Is_Imported (DT);
-
- -- Set_Is_True_Constant (DT);
- -- Why is the above commented out???
-
- -- The scope must be set now to call Get_External_Name
-
- Set_Scope (DT, Current_Scope);
+ -- Import the forward declaration of the tag (Make_DT will take care of
+ -- its exportation)
- Get_External_Name (DT, True);
- Set_Interface_Name (DT,
+ if Build_Static_DT then
+ Set_Is_Imported (DT_Ptr);
+ Set_Is_True_Constant (DT_Ptr);
+ Set_Scope (DT_Ptr, Current_Scope);
+ Get_External_Name (DT_Ptr, True);
+ Set_Interface_Name (DT_Ptr,
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);
-
- 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,
- Constant_Present => True,
- Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
-
- -- 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)));
+ -- Set tag entity as internal to ensure proper Sprint output of its
+ -- implicit importation.
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
- end if;
+ Set_Is_Internal (DT_Ptr);
- Set_Is_True_Constant (DT_Ptr);
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
end if;
pragma Assert (No (Access_Disp_Table (Typ)));
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 787363898f57c068be7a44e269ab1b52a7d3ae1b..2923aede4c5d69ef090b2cbfadd2350009867941 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1461,10 +1461,9 @@ package body Freeze is
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
- function Check_Allocator (N : Node_Id) return Node_Id;
- -- If N is an allocator, possibly wrapped in one or more level of
- -- qualified expression(s), return the inner allocator node, else
- -- return Empty.
+ function Check_Allocator (N : Node_Id) return Boolean;
+ -- Returns True if N is an expression or a qualified expression with
+ -- an allocator.
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
@@ -1480,22 +1479,15 @@ package body Freeze is
-- Check_Allocator --
---------------------
- function Check_Allocator (N : Node_Id) return Node_Id is
- Inner : Node_Id;
+ function Check_Allocator (N : Node_Id) return Boolean is
begin
- Inner := N;
-
- loop
- if Nkind (Inner) = N_Allocator then
- return Inner;
-
- elsif Nkind (Inner) = N_Qualified_Expression then
- Inner := Expression (Inner);
-
- else
- return Empty;
- end if;
- end loop;
+ if Nkind (N) = N_Allocator then
+ return True;
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Check_Allocator (Expression (N));
+ else
+ return False;
+ end if;
end Check_Allocator;
-----------------
@@ -1846,40 +1838,43 @@ package body Freeze is
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
and then Present (Expression (Parent (Comp)))
+ and then Check_Allocator (Expression (Parent (Comp)))
then
declare
- Alloc : constant Node_Id :=
- Check_Allocator (Expression (Parent (Comp)));
+ Alloc : Node_Id;
begin
- if Present (Alloc) then
+ -- Handle qualified expressions
- -- If component is pointer to a classwide type, freeze
- -- the specific type in the expression being allocated.
- -- The expression may be a subtype indication, in which
- -- case freeze the subtype mark.
-
- if Is_Class_Wide_Type
- (Designated_Type (Etype (Comp)))
- then
- if Is_Entity_Name (Expression (Alloc)) then
- Freeze_And_Append
- (Entity (Expression (Alloc)), Loc, Result);
- elsif
- Nkind (Expression (Alloc)) = N_Subtype_Indication
- then
- Freeze_And_Append
- (Entity (Subtype_Mark (Expression (Alloc))),
- Loc, Result);
- end if;
+ Alloc := Expression (Parent (Comp));
+ while Nkind (Alloc) /= N_Allocator loop
+ pragma Assert (Nkind (Alloc) = N_Qualified_Expression);
+ Alloc := Expression (Alloc);
+ end loop;
- elsif Is_Itype (Designated_Type (Etype (Comp))) then
- Check_Itype (Etype (Comp));
+ -- If component is pointer to a classwide type, freeze the
+ -- specific type in the expression being allocated. The
+ -- expression may be a subtype indication, in which case
+ -- freeze the subtype mark.
- else
+ if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
+ if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
- (Designated_Type (Etype (Comp)), Loc, Result);
+ (Entity (Expression (Alloc)), Loc, Result);
+ elsif
+ Nkind (Expression (Alloc)) = N_Subtype_Indication
+ then
+ Freeze_And_Append
+ (Entity (Subtype_Mark (Expression (Alloc))),
+ Loc, Result);
end if;
+
+ elsif Is_Itype (Designated_Type (Etype (Comp))) then
+ Check_Itype (Etype (Comp));
+
+ else
+ Freeze_And_Append
+ (Designated_Type (Etype (Comp)), Loc, Result);
end if;
end;
@@ -4702,6 +4697,18 @@ package body Freeze is
begin
Ensure_Type_Is_SA (Etype (E));
+ -- Reset True_Constant flag, since something strange is going on with
+ -- the scoping here, and our simple value tracing may not be sufficient
+ -- for this indication to be reliable. We kill the Constant_Value
+ -- and Last_Assignment indications for the same reason.
+
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+
+ if Ekind (E) = E_Variable then
+ Set_Last_Assignment (E, Empty);
+ end if;
+
exception
when Cannot_Be_Static =>