From e18d6a151c6c0a45cd30f150de87f1fb5c10f199 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 11 Sep 2007 13:31:51 +0000 Subject: [PATCH] Put back previous change, the random failure was caused by a makefile bug, causing the Ada run-time not to be recompiled by the new compiler. From-SVN: r128374 --- gcc/ada/ChangeLog | 21 +++ gcc/ada/einfo.adb | 17 ++ gcc/ada/einfo.ads | 12 ++ gcc/ada/exp_disp.adb | 419 +++++++++++++++++++++++-------------------- gcc/ada/freeze.adb | 95 +++++----- 5 files changed, 317 insertions(+), 247 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 05182f88f97..1ad4a404e8e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2007-09-11 Javier Miranda + + * 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 * misc.c (gnat_expand_body): Kill. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7b705b02f20..fad178003e5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -217,6 +217,7 @@ 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 @@ -842,6 +843,12 @@ 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)); @@ -3116,6 +3123,12 @@ 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); @@ -8253,6 +8266,10 @@ 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 924472bc183..b95165ba3b0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -819,6 +819,12 @@ 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 @@ -5120,6 +5126,7 @@ 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) @@ -5153,6 +5160,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) -- First_Entity (Node17) -- Private_Dependents (Elist18) -- Underlying_Full_View (Node19) @@ -5547,6 +5555,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 DTC_Entity (Id : E) return E; function DT_Entry_Count (Id : E) return U; function DT_Offset_To_Top_Func (Id : E) return E; @@ -6048,6 +6057,7 @@ 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); @@ -6676,6 +6686,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 (DTC_Entity); pragma Inline (DT_Entry_Count); pragma Inline (DT_Offset_To_Top_Func); @@ -7080,6 +7091,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_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 1eb0624c287..2d663baf6c2 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -10,14 +10,13 @@ -- -- -- 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 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -67,10 +66,18 @@ 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) @@ -90,6 +97,16 @@ 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 -- ---------------------------------- @@ -1428,6 +1445,16 @@ 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 -- ------------------------------------- @@ -2434,14 +2461,6 @@ 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 @@ -2460,6 +2479,10 @@ 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; @@ -2496,6 +2519,28 @@ 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 -- ----------------------- @@ -2508,7 +2553,6 @@ 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); @@ -2533,7 +2577,7 @@ package body Exp_Disp is -- Handle cases in which we do not generate statically allocated -- dispatch tables. - if not Build_Static_DT then + if not Building_Static_DT (Typ) then Set_Ekind (Predef_Prims, E_Variable); Set_Is_Statically_Allocated (Predef_Prims); @@ -2576,7 +2620,7 @@ package body Exp_Disp is -- Stage 1: Calculate the number of predefined primitives - if not Build_Static_DT then + if not Building_Static_DT (Typ) then Nb_Predef_Prims := Max_Predef_Prims; else Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); @@ -2650,7 +2694,7 @@ package body Exp_Disp is Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, - Constant_Present => Build_Static_DT, + Constant_Present => Building_Static_DT (Typ), Aliased_Present => True, Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), @@ -2858,7 +2902,7 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Null_Address), Loc)); elsif Is_Abstract_Type (Typ) - or else not Build_Static_DT + or else not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, @@ -2963,7 +3007,7 @@ package body Exp_Disp is Object_Definition => New_Reference_To (RTE (RE_Interface_Tag), Loc), Expression => - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Interface_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, @@ -2978,14 +3022,13 @@ 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_Tag_Comp : Elmt_Id; AI_Ptr_Elmt : Elmt_Id; - DT_Constr_List : List_Id; + AI_Tag_Comp : Elmt_Id; DT_Aggr_List : List_Id; + DT_Constr_List : List_Id; DT_Ptr : Entity_Id; ITable : Node_Id; I_Depth : Nat := 0; @@ -3066,7 +3109,7 @@ package body Exp_Disp is Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (RTE (RE_Null_Address), Loc)))); Analyze_List (Result, Suppress => All_Checks); @@ -3096,10 +3139,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 primitive in the slot will be generated later --- when + -- register the primitives in the slots will be generated later --- when -- each primitive is frozen (see Freeze_Subprogram). - if Build_Static_DT + if Building_Static_DT (Typ) and then not Is_CPP_Class (Typ) then declare @@ -3137,49 +3180,6 @@ 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,24 +3204,15 @@ package body Exp_Disp is end loop; end if; - -- Calculate the number of primitives of the dispatch table and the - -- size of the Type_Specific_Data record. + -- Get the _tag entity and the number of primitives of its dispatch + -- table. - if Has_DT then - Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - end if; + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - Set_Ekind (SSD, E_Constant); + Set_Is_Statically_Allocated (DT); 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 @@ -3246,14 +3237,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 Build_Static_DT then + if not Building_Static_DT (Typ) 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 then + if not Has_DT (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, @@ -3279,7 +3270,7 @@ package body Exp_Disp is Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, @@ -3334,7 +3325,7 @@ package body Exp_Disp is Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, Expression => - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, @@ -3359,6 +3350,9 @@ 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). @@ -3372,7 +3366,7 @@ package body Exp_Disp is -- Transportable => <>, -- RC_Offset => <>, -- [ Interfaces_Table => <> ] - -- [ SSD => SSD_Table'Address ] + -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, -- 1 => Parent'Tag -- ...); @@ -3711,7 +3705,7 @@ package body Exp_Disp is -- Iface_Tag - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (First_Elmt (Access_Disp_Table (Node (AI)))), Loc)), @@ -3787,7 +3781,7 @@ package body Exp_Disp is if RTE_Record_Component_Available (RE_SSD) then if Ada_Version >= Ada_05 - and then Has_DT + and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) and then Has_Abstract_Interfaces (Typ) and then Nb_Prim > 0 @@ -3845,48 +3839,18 @@ package body Exp_Disp is -- must fill position 0 with null because we still have not -- generated the tag of Typ. - if not Build_Static_DT + if not Building_Static_DT (Typ) 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 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. + -- Otherwise we can safely reference the tag. else - 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; + Append_To (TSD_Tags_List, + New_Reference_To (DT_Ptr, Loc)); end if; -- Fill the rest of the table with the tags of the ancestors @@ -3936,7 +3900,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => TSD, Aliased_Present => True, - Constant_Present => Build_Static_DT, + Constant_Present => Building_Static_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To ( @@ -3949,6 +3913,8 @@ 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), @@ -3958,15 +3924,9 @@ package body Exp_Disp is Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - -- 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 + -- Initialize or declare the dispatch table object - if not Has_DT then + if not Has_DT (Typ) then DT_Constr_List := New_List; DT_Aggr_List := New_List; @@ -3983,17 +3943,26 @@ 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 an assignment. + -- initialized by means of the following assignment: + + -- DT := (TSD'Address, 0); - if not Build_Static_DT then + if not Building_Static_DT (Typ) 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 the constant - -- object containing the dispatch table. + -- 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; else Append_To (Result, @@ -4016,21 +3985,7 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - 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)))); + Export_DT (Typ, DT); end if; -- Common case: Typ has a dispatch table @@ -4061,7 +4016,7 @@ package body Exp_Disp is Pos : Nat; begin - if not Build_Static_DT then + if not Building_Static_DT (Typ) then Nb_Predef_Prims := Max_Predef_Prims; else @@ -4097,7 +4052,7 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - if Build_Static_DT + if Building_Static_DT (Typ) and then Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Present (Prim_Table @@ -4132,7 +4087,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, - Constant_Present => Build_Static_DT, + Constant_Present => Building_Static_DT (Typ), Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), Expression => Make_Aggregate (Loc, @@ -4208,7 +4163,7 @@ package body Exp_Disp is Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); - elsif not Build_Static_DT then + elsif not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); @@ -4279,15 +4234,15 @@ package body Exp_Disp is -- and uninitialized object for the dispatch table, which is now -- initialized by means of an assignment. - if not Build_Static_DT then + if not Building_Static_DT (Typ) 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 the constant - -- object containing the dispatch table. + -- In case of library level tagged types we declare now and export + -- the constant object containing the dispatch table. else Append_To (Result, @@ -4314,27 +4269,13 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - 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)))); + Export_DT (Typ, DT); end if; end if; -- Initialize the table of ancestor tags - if not Build_Static_DT + if not Building_Static_DT (Typ) and then not Is_Interface (Typ) and then not Is_CPP_Class (Typ) then @@ -4357,7 +4298,7 @@ package body Exp_Disp is (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; - if Build_Static_DT then + if Building_Static_DT (Typ) then null; -- If the ancestor is a CPP_Class type we inherit the dispatch tables @@ -4376,10 +4317,10 @@ package body Exp_Disp is Null_Parent_Tag := True; Old_Tag1 := - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), Make_Integer_Literal (Loc, 0)); Old_Tag2 := - Unchecked_Convert_To (Generalized_Tag, + Unchecked_Convert_To (RTE (RE_Tag), Make_Integer_Literal (Loc, 0)); else @@ -4763,14 +4704,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; @@ -4789,30 +4730,116 @@ 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 tag (Make_DT will take care of - -- its exportation) + -- Import the forward declaration of the Dispatch Table wrapper record + -- (Make_DT will take care of its exportation) - 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, + 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); + + Get_External_Name (DT, True); + Set_Interface_Name (DT, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); - -- Set tag entity as internal to ensure proper Sprint output of its - -- implicit importation. + -- Ensure proper Sprint output of this implicit importation - Set_Is_Internal (DT_Ptr); + Set_Is_Internal (DT); - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); + -- 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))); + + 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_True_Constant (DT_Ptr); end if; pragma Assert (No (Access_Disp_Table (Typ))); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 2923aede4c5..787363898f5 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1461,9 +1461,10 @@ 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 Boolean; - -- Returns True if N is an expression or a qualified expression with - -- an allocator. + 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. procedure Check_Itype (Typ : Entity_Id); -- If the component subtype is an access to a constrained subtype of @@ -1479,15 +1480,22 @@ package body Freeze is -- Check_Allocator -- --------------------- - function Check_Allocator (N : Node_Id) return Boolean is + function Check_Allocator (N : Node_Id) return Node_Id is + Inner : Node_Id; begin - 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; + 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; end Check_Allocator; ----------------- @@ -1838,43 +1846,40 @@ 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 : Node_Id; + Alloc : constant Node_Id := + Check_Allocator (Expression (Parent (Comp))); begin - -- Handle qualified expressions + if Present (Alloc) then - Alloc := Expression (Parent (Comp)); - while Nkind (Alloc) /= N_Allocator loop - pragma Assert (Nkind (Alloc) = N_Qualified_Expression); - Alloc := Expression (Alloc); - end loop; - - -- 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 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 + if Is_Class_Wide_Type + (Designated_Type (Etype (Comp))) then - Freeze_And_Append - (Entity (Subtype_Mark (Expression (Alloc))), - Loc, Result); - end if; + 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; - elsif Is_Itype (Designated_Type (Etype (Comp))) then - Check_Itype (Etype (Comp)); + elsif Is_Itype (Designated_Type (Etype (Comp))) then + Check_Itype (Etype (Comp)); - else - Freeze_And_Append - (Designated_Type (Etype (Comp)), Loc, Result); + else + Freeze_And_Append + (Designated_Type (Etype (Comp)), Loc, Result); + end if; end if; end; @@ -4697,18 +4702,6 @@ 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 => -- 2.30.2