From f91622572c7af70568fd8a0515d485a953389982 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 11 Sep 2007 12:13:12 +0000 Subject: [PATCH] Temporarily undo previous change, which seems to be causing random failures. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@128372 138bc75d-0d04-0410-961f-82ee72b054a4 --- 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, 247 insertions(+), 317 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1ad4a40..05182f8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,24 +1,3 @@ -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 fad1780..7b705b0 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 b95165b..924472b 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 2d663ba..1eb0624 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 => <>, -- RC_Offset => <>, -- [ Interfaces_Table => <> ] - -- [ 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 7873638..2923aed 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 => -- 2.7.4