Skip to content

R
riscv-gcc-1
Commit e18d6a15 by Javier Miranda Committed by Arnaud Charlet
Options

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
parent 0f4cb75c
Showing with 294 additions and 224 deletions
gcc/ada/ChangeLog
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> 2007-09-11 Jan Hubicka <jh@suse.cz>
* misc.c (gnat_expand_body): Kill. * misc.c (gnat_expand_body): Kill.
gcc/ada/einfo.adb
...@@ -217,6 +217,7 @@ package body Einfo is ...@@ -217,6 +217,7 @@ package body Einfo is
-- DT_Offset_To_Top_Func Node25 -- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25 -- Task_Body_Procedure Node25
-- Dispatch_Table_Wrapper Node16
-- Overridden_Operation Node26 -- Overridden_Operation Node26
-- Package_Instantiation Node26 -- Package_Instantiation Node26
-- Related_Interface Node26 -- Related_Interface Node26
...@@ -842,6 +843,12 @@ package body Einfo is ...@@ -842,6 +843,12 @@ package body Einfo is
return Uint15 (Id); return Uint15 (Id);
end Discriminant_Number; 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 function DT_Entry_Count (Id : E) return U is
begin begin
pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
...@@ -3116,6 +3123,12 @@ package body Einfo is ...@@ -3116,6 +3123,12 @@ package body Einfo is
Set_Uint15 (Id, V); Set_Uint15 (Id, V);
end Set_Discriminant_Number; 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 procedure Set_DT_Entry_Count (Id : E; V : U) is
begin begin
pragma Assert (Ekind (Id) = E_Component); pragma Assert (Ekind (Id) = E_Component);
...@@ -8253,6 +8266,10 @@ package body Einfo is ...@@ -8253,6 +8266,10 @@ package body Einfo is
Write_Str ("Static_Initialization"); Write_Str ("Static_Initialization");
end if; end if;
when E_Record_Type |
E_Record_Type_With_Private =>
Write_Str ("Dispatch_Table_Wrapper");
when others => when others =>
Write_Str ("Field26??"); Write_Str ("Field26??");
end case; end case;
......
gcc/ada/einfo.ads
...@@ -819,6 +819,12 @@ package Einfo is ...@@ -819,6 +819,12 @@ package Einfo is
-- the list of discriminants of the type, i.e. a sequential integer -- the list of discriminants of the type, i.e. a sequential integer
-- index starting at 1 and ranging up to Number_Discriminants. -- 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) -- DTC_Entity (Node16)
-- Present in function and procedure entities. Set to Empty unless -- Present in function and procedure entities. Set to Empty unless
-- the subprogram is dispatching in which case it references the -- the subprogram is dispatching in which case it references the
...@@ -5120,6 +5126,7 @@ package Einfo is ...@@ -5120,6 +5126,7 @@ package Einfo is
-- E_Record_Subtype -- E_Record_Subtype
-- Primitive_Operations (Elist15) -- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only) -- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only) -- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17) -- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18) -- Corresponding_Concurrent_Type (Node18)
...@@ -5153,6 +5160,7 @@ package Einfo is ...@@ -5153,6 +5160,7 @@ package Einfo is
-- E_Record_Subtype_With_Private -- E_Record_Subtype_With_Private
-- Primitive_Operations (Elist15) -- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only) -- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- First_Entity (Node17) -- First_Entity (Node17)
-- Private_Dependents (Elist18) -- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19) -- Underlying_Full_View (Node19)
...@@ -5547,6 +5555,7 @@ package Einfo is ...@@ -5547,6 +5555,7 @@ package Einfo is
function Current_Value (Id : E) return N; function Current_Value (Id : E) return N;
function Debug_Info_Off (Id : E) return B; function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E; function Debug_Renaming_Link (Id : E) return E;
function Dispatch_Table_Wrapper (Id : E) return E;
function DTC_Entity (Id : E) return E; function DTC_Entity (Id : E) return E;
function DT_Entry_Count (Id : E) return U; function DT_Entry_Count (Id : E) return U;
function DT_Offset_To_Top_Func (Id : E) return E; function DT_Offset_To_Top_Func (Id : E) return E;
...@@ -6048,6 +6057,7 @@ package Einfo is ...@@ -6048,6 +6057,7 @@ package Einfo is
procedure Set_Abstract_Interfaces (Id : E; V : L); procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (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_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E); procedure Set_Alias (Id : E; V : E);
...@@ -6676,6 +6686,7 @@ package Einfo is ...@@ -6676,6 +6686,7 @@ package Einfo is
pragma Inline (Current_Value); pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off); pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link); pragma Inline (Debug_Renaming_Link);
pragma Inline (Dispatch_Table_Wrapper);
pragma Inline (DTC_Entity); pragma Inline (DTC_Entity);
pragma Inline (DT_Entry_Count); pragma Inline (DT_Entry_Count);
pragma Inline (DT_Offset_To_Top_Func); pragma Inline (DT_Offset_To_Top_Func);
...@@ -7080,6 +7091,7 @@ package Einfo is ...@@ -7080,6 +7091,7 @@ package Einfo is
pragma Inline (Set_Current_Value); pragma Inline (Set_Current_Value);
pragma Inline (Set_Debug_Info_Off); pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link); pragma Inline (Set_Debug_Renaming_Link);
pragma Inline (Set_Dispatch_Table_Wrapper);
pragma Inline (Set_DTC_Entity); pragma Inline (Set_DTC_Entity);
pragma Inline (Set_DT_Entry_Count); pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func); pragma Inline (Set_DT_Offset_To_Top_Func);
......
gcc/ada/exp_disp.adb
...@@ -10,14 +10,13 @@ ...@@ -10,14 +10,13 @@
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- 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- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- 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 -- -- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write -- -- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- http://www.gnu.org/licenses for a complete copy of the license. --
-- Boston, MA 02110-1301, USA. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
...@@ -67,10 +66,18 @@ package body Exp_Disp is ...@@ -67,10 +66,18 @@ package body Exp_Disp is
-- Local Subprograms -- -- 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; function Default_Prim_Op_Position (E : Entity_Id) return Uint;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations. -- 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; function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
-- Returns true if Prim is not a predefined dispatching primitive but it is -- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (ie. through a renaming) -- an alias of a predefined dispatching primitive (ie. through a renaming)
...@@ -90,6 +97,16 @@ package body Exp_Disp is ...@@ -90,6 +97,16 @@ package body Exp_Disp is
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value. -- 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 -- -- Build_Static_Dispatch_Tables --
---------------------------------- ----------------------------------
...@@ -1428,6 +1445,16 @@ package body Exp_Disp is ...@@ -1428,6 +1445,16 @@ package body Exp_Disp is
end if; end if;
end Expand_Interface_Thunk; 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 -- -- Is_Predefined_Dispatching_Alias --
------------------------------------- -------------------------------------
...@@ -2434,14 +2461,6 @@ package body Exp_Disp is ...@@ -2434,14 +2461,6 @@ package body Exp_Disp is
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ); 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 := Max_Predef_Prims : constant Int :=
UI_To_Int UI_To_Int
(Intval (Intval
...@@ -2460,6 +2479,10 @@ package body Exp_Disp is ...@@ -2460,6 +2479,10 @@ package body Exp_Disp is
-- freezes a tagged type, when one of its primitive operations has a -- freezes a tagged type, when one of its primitive operations has a
-- type in its profile whose full view has not been analyzed yet. -- 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 procedure Make_Secondary_DT
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
...@@ -2496,6 +2519,28 @@ package body Exp_Disp is ...@@ -2496,6 +2519,28 @@ package body Exp_Disp is
end if; end if;
end Check_Premature_Freezing; 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 -- -- Make_Secondary_DT --
----------------------- -----------------------
...@@ -2508,7 +2553,6 @@ package body Exp_Disp is ...@@ -2508,7 +2553,6 @@ package body Exp_Disp is
Result : List_Id) Result : List_Id)
is is
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
Name_DT : constant Name_Id := New_Internal_Name ('T'); Name_DT : constant Name_Id := New_Internal_Name ('T');
Iface_DT : constant Entity_Id := Iface_DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT); Make_Defining_Identifier (Loc, Name_DT);
...@@ -2533,7 +2577,7 @@ package body Exp_Disp is ...@@ -2533,7 +2577,7 @@ package body Exp_Disp is
-- Handle cases in which we do not generate statically allocated -- Handle cases in which we do not generate statically allocated
-- dispatch tables. -- dispatch tables.
if not Build_Static_DT then if not Building_Static_DT (Typ) then
Set_Ekind (Predef_Prims, E_Variable); Set_Ekind (Predef_Prims, E_Variable);
Set_Is_Statically_Allocated (Predef_Prims); Set_Is_Statically_Allocated (Predef_Prims);
...@@ -2576,7 +2620,7 @@ package body Exp_Disp is ...@@ -2576,7 +2620,7 @@ package body Exp_Disp is
-- Stage 1: Calculate the number of predefined primitives -- 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; Nb_Predef_Prims := Max_Predef_Prims;
else else
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
...@@ -2650,7 +2694,7 @@ package body Exp_Disp is ...@@ -2650,7 +2694,7 @@ package body Exp_Disp is
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims, Defining_Identifier => Predef_Prims,
Constant_Present => Build_Static_DT, Constant_Present => Building_Static_DT (Typ),
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc), New_Reference_To (RTE (RE_Address_Array), Loc),
...@@ -2858,7 +2902,7 @@ package body Exp_Disp is ...@@ -2858,7 +2902,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
elsif Is_Abstract_Type (Typ) elsif Is_Abstract_Type (Typ)
or else not Build_Static_DT or else not Building_Static_DT (Typ)
then then
for J in 1 .. Nb_Prim loop for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
...@@ -2963,7 +3007,7 @@ package body Exp_Disp is ...@@ -2963,7 +3007,7 @@ package body Exp_Disp is
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Interface_Tag), Loc), New_Reference_To (RTE (RE_Interface_Tag), Loc),
Expression => Expression =>
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -2978,14 +3022,13 @@ package body Exp_Disp is ...@@ -2978,14 +3022,13 @@ package body Exp_Disp is
-- Local variables -- Local variables
Elab_Code : constant List_Id := New_List; Elab_Code : constant List_Id := New_List;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
Result : constant List_Id := New_List; Result : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ); Tname : constant Name_Id := Chars (Typ);
AI : Elmt_Id; AI : Elmt_Id;
AI_Tag_Comp : Elmt_Id;
AI_Ptr_Elmt : Elmt_Id; AI_Ptr_Elmt : Elmt_Id;
DT_Constr_List : List_Id; AI_Tag_Comp : Elmt_Id;
DT_Aggr_List : List_Id; DT_Aggr_List : List_Id;
DT_Constr_List : List_Id;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
ITable : Node_Id; ITable : Node_Id;
I_Depth : Nat := 0; I_Depth : Nat := 0;
...@@ -3066,7 +3109,7 @@ package body Exp_Disp is ...@@ -3066,7 +3109,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True, Constant_Present => True,
Expression => Expression =>
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)))); New_Reference_To (RTE (RE_Null_Address), Loc))));
Analyze_List (Result, Suppress => All_Checks); Analyze_List (Result, Suppress => All_Checks);
...@@ -3096,10 +3139,10 @@ package body Exp_Disp is ...@@ -3096,10 +3139,10 @@ package body Exp_Disp is
-- be referenced (otherwise we have problems with the backend). It is -- be referenced (otherwise we have problems with the backend). It is
-- not a requirement with nonstatic dispatch tables because in this case -- not a requirement with nonstatic dispatch tables because in this case
-- we generate now an empty dispatch table; the extra code required to -- 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). -- each primitive is frozen (see Freeze_Subprogram).
if Build_Static_DT if Building_Static_DT (Typ)
and then not Is_CPP_Class (Typ) and then not Is_CPP_Class (Typ)
then then
declare declare
...@@ -3137,49 +3180,6 @@ package body Exp_Disp is ...@@ -3137,49 +3180,6 @@ package body Exp_Disp is
end; end;
end if; 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 -- Ada 2005 (AI-251): Build the secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then if Has_Abstract_Interfaces (Typ) then
...@@ -3204,24 +3204,15 @@ package body Exp_Disp is ...@@ -3204,24 +3204,15 @@ package body Exp_Disp is
end loop; end loop;
end if; end if;
-- Calculate the number of primitives of the dispatch table and the -- Get the _tag entity and the number of primitives of its dispatch
-- size of the Type_Specific_Data record. -- table.
if Has_DT then DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
end if;
Set_Ekind (SSD, E_Constant); Set_Is_Statically_Allocated (DT);
Set_Is_Statically_Allocated (SSD); Set_Is_Statically_Allocated (SSD);
Set_Is_True_Constant (SSD);
Set_Ekind (TSD, E_Constant);
Set_Is_Statically_Allocated (TSD); 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 -- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in -- order to avoid multiple registrations for tagged types defined in
...@@ -3246,14 +3237,14 @@ package body Exp_Disp is ...@@ -3246,14 +3237,14 @@ package body Exp_Disp is
-- initialization is done later by means of an assignment. This is -- initialization is done later by means of an assignment. This is
-- required to generate its External_Tag. -- required to generate its External_Tag.
if not Build_Static_DT then if not Building_Static_DT (Typ) then
-- Generate: -- Generate:
-- DT : No_Dispatch_Table_Wrapper; -- DT : No_Dispatch_Table_Wrapper;
-- for DT'Alignment use Address'Alignment; -- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
if not Has_DT then if not Has_DT (Typ) then
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT, Defining_Identifier => DT,
...@@ -3279,7 +3270,7 @@ package body Exp_Disp is ...@@ -3279,7 +3270,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True, Constant_Present => True,
Expression => Expression =>
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -3334,7 +3325,7 @@ package body Exp_Disp is ...@@ -3334,7 +3325,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True, Constant_Present => True,
Expression => Expression =>
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -3359,6 +3350,9 @@ package body Exp_Disp is ...@@ -3359,6 +3350,9 @@ package body Exp_Disp is
Make_String_Literal (Loc, Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ))))); 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 -- 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 -- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb). -- of all the implemented interfaces (as described in a-tags.adb).
...@@ -3711,7 +3705,7 @@ package body Exp_Disp is ...@@ -3711,7 +3705,7 @@ package body Exp_Disp is
-- Iface_Tag -- Iface_Tag
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Node (AI)))), (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
Loc)), Loc)),
...@@ -3787,7 +3781,7 @@ package body Exp_Disp is ...@@ -3787,7 +3781,7 @@ package body Exp_Disp is
if RTE_Record_Component_Available (RE_SSD) then if RTE_Record_Component_Available (RE_SSD) then
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Has_DT and then Has_DT (Typ)
and then Is_Concurrent_Record_Type (Typ) and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ) and then Has_Abstract_Interfaces (Typ)
and then Nb_Prim > 0 and then Nb_Prim > 0
...@@ -3845,48 +3839,18 @@ package body Exp_Disp is ...@@ -3845,48 +3839,18 @@ package body Exp_Disp is
-- must fill position 0 with null because we still have not -- must fill position 0 with null because we still have not
-- generated the tag of Typ. -- generated the tag of Typ.
if not Build_Static_DT if not Building_Static_DT (Typ)
or else Is_Interface (Typ) or else Is_Interface (Typ)
then then
Append_To (TSD_Tags_List, Append_To (TSD_Tags_List,
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc))); New_Reference_To (RTE (RE_Null_Address), Loc)));
-- Otherwise we can safely import the tag. The name must be unique -- Otherwise we can safely reference the tag.
-- 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 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, Append_To (TSD_Tags_List,
New_Reference_To (Imported_DT_Ptr, Loc)); New_Reference_To (DT_Ptr, Loc));
end;
end if; end if;
-- Fill the rest of the table with the tags of the ancestors -- Fill the rest of the table with the tags of the ancestors
...@@ -3936,7 +3900,7 @@ package body Exp_Disp is ...@@ -3936,7 +3900,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => TSD, Defining_Identifier => TSD,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Build_Static_DT, Constant_Present => Building_Static_DT (Typ),
Object_Definition => Object_Definition =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To ( Subtype_Mark => New_Reference_To (
...@@ -3949,6 +3913,8 @@ package body Exp_Disp is ...@@ -3949,6 +3913,8 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Expressions => TSD_Aggr_List))); Expressions => TSD_Aggr_List)));
Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
Append_To (Result, Append_To (Result,
Make_Attribute_Definition_Clause (Loc, Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (TSD, Loc), Name => New_Reference_To (TSD, Loc),
...@@ -3958,15 +3924,9 @@ package body Exp_Disp is ...@@ -3958,15 +3924,9 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); Attribute_Name => Name_Alignment)));
-- Generate the dummy Dispatch_Table object associated with tagged -- Initialize or declare the dispatch table object
-- types that have no dispatch table.
-- DT : No_Dispatch_Table := if not Has_DT (Typ) then
-- (NDT_TSD => TSD'Address;
-- NDT_Prims_Ptr => 0);
-- for DT'Alignment use Address'Alignment
if not Has_DT then
DT_Constr_List := New_List; DT_Constr_List := New_List;
DT_Aggr_List := New_List; DT_Aggr_List := New_List;
...@@ -3983,17 +3943,26 @@ package body Exp_Disp is ...@@ -3983,17 +3943,26 @@ package body Exp_Disp is
-- In case of locally defined tagged types we have already declared -- In case of locally defined tagged types we have already declared
-- and uninitialized object for the dispatch table, which is now -- 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, Append_To (Result,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc), Name => New_Reference_To (DT, Loc),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List))); Expressions => DT_Aggr_List)));
-- In case of library level tagged types we declare now the constant -- In case of library level tagged types we declare and export now
-- object containing the dispatch table. -- 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 else
Append_To (Result, Append_To (Result,
...@@ -4016,21 +3985,7 @@ package body Exp_Disp is ...@@ -4016,21 +3985,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Integer_Address), Loc), New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); Attribute_Name => Name_Alignment)));
Append_To (Result, Export_DT (Typ, DT);
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; end if;
-- Common case: Typ has a dispatch table -- Common case: Typ has a dispatch table
...@@ -4061,7 +4016,7 @@ package body Exp_Disp is ...@@ -4061,7 +4016,7 @@ package body Exp_Disp is
Pos : Nat; Pos : Nat;
begin begin
if not Build_Static_DT then if not Building_Static_DT (Typ) then
Nb_Predef_Prims := Max_Predef_Prims; Nb_Predef_Prims := Max_Predef_Prims;
else else
...@@ -4097,7 +4052,7 @@ package body Exp_Disp is ...@@ -4097,7 +4052,7 @@ package body Exp_Disp is
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
if Build_Static_DT if Building_Static_DT (Typ)
and then Is_Predefined_Dispatching_Operation (Prim) and then Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Abstract_Subprogram (Prim) and then not Is_Abstract_Subprogram (Prim)
and then not Present (Prim_Table and then not Present (Prim_Table
...@@ -4132,7 +4087,7 @@ package body Exp_Disp is ...@@ -4132,7 +4087,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims, Defining_Identifier => Predef_Prims,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Build_Static_DT, Constant_Present => Building_Static_DT (Typ),
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc), New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
...@@ -4208,7 +4163,7 @@ package body Exp_Disp is ...@@ -4208,7 +4163,7 @@ package body Exp_Disp is
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc)); 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 for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
...@@ -4279,15 +4234,15 @@ package body Exp_Disp is ...@@ -4279,15 +4234,15 @@ package body Exp_Disp is
-- and uninitialized object for the dispatch table, which is now -- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment. -- initialized by means of an assignment.
if not Build_Static_DT then if not Building_Static_DT (Typ) then
Append_To (Result, Append_To (Result,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc), Name => New_Reference_To (DT, Loc),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List))); Expressions => DT_Aggr_List)));
-- In case of library level tagged types we declare now the constant -- In case of library level tagged types we declare now and export
-- object containing the dispatch table. -- the constant object containing the dispatch table.
else else
Append_To (Result, Append_To (Result,
...@@ -4314,27 +4269,13 @@ package body Exp_Disp is ...@@ -4314,27 +4269,13 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Integer_Address), Loc), New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); Attribute_Name => Name_Alignment)));
Append_To (Result, Export_DT (Typ, DT);
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;
end if; end if;
-- Initialize the table of ancestor tags -- 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_Interface (Typ)
and then not Is_CPP_Class (Typ) and then not Is_CPP_Class (Typ)
then then
...@@ -4357,7 +4298,7 @@ package body Exp_Disp is ...@@ -4357,7 +4298,7 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if; end if;
if Build_Static_DT then if Building_Static_DT (Typ) then
null; null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables -- If the ancestor is a CPP_Class type we inherit the dispatch tables
...@@ -4376,10 +4317,10 @@ package body Exp_Disp is ...@@ -4376,10 +4317,10 @@ package body Exp_Disp is
Null_Parent_Tag := True; Null_Parent_Tag := True;
Old_Tag1 := Old_Tag1 :=
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
Make_Integer_Literal (Loc, 0)); Make_Integer_Literal (Loc, 0));
Old_Tag2 := Old_Tag2 :=
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (RTE (RE_Tag),
Make_Integer_Literal (Loc, 0)); Make_Integer_Literal (Loc, 0));
else else
...@@ -4763,14 +4704,14 @@ package body Exp_Disp is ...@@ -4763,14 +4704,14 @@ package body Exp_Disp is
function Make_Tags (Typ : Entity_Id) return List_Id is function Make_Tags (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ); 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); Tname : constant Name_Id := Chars (Typ);
Result : constant List_Id := New_List; Result : constant List_Id := New_List;
AI_Tag_Comp : Elmt_Id; AI_Tag_Comp : Elmt_Id;
DT : Node_Id;
DT_Constr_List : List_Id;
DT_Ptr : Node_Id; DT_Ptr : Node_Id;
Iface_DT_Ptr : Node_Id; Iface_DT_Ptr : Node_Id;
Nb_Prim : Nat;
Suffix_Index : Int; Suffix_Index : Int;
Typ_Name : Name_Id; Typ_Name : Name_Id;
Typ_Comps : Elist_Id; Typ_Comps : Elist_Id;
...@@ -4789,30 +4730,116 @@ package body Exp_Disp is ...@@ -4789,30 +4730,116 @@ package body Exp_Disp is
DT_Ptr := Make_Defining_Identifier (Loc, DT_Ptr := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'P')); New_External_Name (Tname, 'P'));
Set_Etype (DT_Ptr, RTE (RE_Tag)); 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 -- Import the forward declaration of the Dispatch Table wrapper record
-- its exportation) -- (Make_DT will take care of its exportation)
if Build_Static_DT then if Building_Static_DT (Typ)
Set_Is_Imported (DT_Ptr); and then not Is_CPP_Class (Typ)
Set_Is_True_Constant (DT_Ptr); then
Set_Scope (DT_Ptr, Current_Scope); DT := Make_Defining_Identifier (Loc,
Get_External_Name (DT_Ptr, True); New_External_Name (Tname, 'T'));
Set_Interface_Name (DT_Ptr,
-- 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, Make_String_Literal (Loc,
Strval => String_From_Name_Buffer)); Strval => String_From_Name_Buffer));
-- Set tag entity as internal to ensure proper Sprint output of its -- Ensure proper Sprint output of this implicit importation
-- 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))));
Set_Is_Internal (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),
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, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr, Defining_Identifier => DT_Ptr,
Constant_Present => True, Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); 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; end if;
pragma Assert (No (Access_Disp_Table (Typ))); pragma Assert (No (Access_Disp_Table (Typ)));
......
gcc/ada/freeze.adb
...@@ -1461,9 +1461,10 @@ package body Freeze is ...@@ -1461,9 +1461,10 @@ package body Freeze is
-- Set True if we find at least one component with a component -- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas). -- clause (used to warn about useless Bit_Order pragmas).
function Check_Allocator (N : Node_Id) return Boolean; function Check_Allocator (N : Node_Id) return Node_Id;
-- Returns True if N is an expression or a qualified expression with -- If N is an allocator, possibly wrapped in one or more level of
-- an allocator. -- qualified expression(s), return the inner allocator node, else
-- return Empty.
procedure Check_Itype (Typ : Entity_Id); procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of -- If the component subtype is an access to a constrained subtype of
...@@ -1479,15 +1480,22 @@ package body Freeze is ...@@ -1479,15 +1480,22 @@ package body Freeze is
-- Check_Allocator -- -- 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 begin
if Nkind (N) = N_Allocator then Inner := N;
return True;
elsif Nkind (N) = N_Qualified_Expression then loop
return Check_Allocator (Expression (N)); if Nkind (Inner) = N_Allocator then
return Inner;
elsif Nkind (Inner) = N_Qualified_Expression then
Inner := Expression (Inner);
else else
return False; return Empty;
end if; end if;
end loop;
end Check_Allocator; end Check_Allocator;
----------------- -----------------
...@@ -1838,26 +1846,22 @@ package body Freeze is ...@@ -1838,26 +1846,22 @@ package body Freeze is
elsif Is_Access_Type (Etype (Comp)) elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp)) and then Present (Parent (Comp))
and then Present (Expression (Parent (Comp))) and then Present (Expression (Parent (Comp)))
and then Check_Allocator (Expression (Parent (Comp)))
then then
declare declare
Alloc : Node_Id; Alloc : constant Node_Id :=
Check_Allocator (Expression (Parent (Comp)));
begin begin
-- Handle qualified expressions if Present (Alloc) then
Alloc := Expression (Parent (Comp)); -- If component is pointer to a classwide type, freeze
while Nkind (Alloc) /= N_Allocator loop -- the specific type in the expression being allocated.
pragma Assert (Nkind (Alloc) = N_Qualified_Expression); -- The expression may be a subtype indication, in which
Alloc := Expression (Alloc); -- case freeze the subtype mark.
end loop;
-- If component is pointer to a classwide type, freeze the if Is_Class_Wide_Type
-- specific type in the expression being allocated. The (Designated_Type (Etype (Comp)))
-- expression may be a subtype indication, in which case then
-- freeze the subtype mark.
if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
if Is_Entity_Name (Expression (Alloc)) then if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append Freeze_And_Append
(Entity (Expression (Alloc)), Loc, Result); (Entity (Expression (Alloc)), Loc, Result);
...@@ -1876,6 +1880,7 @@ package body Freeze is ...@@ -1876,6 +1880,7 @@ package body Freeze is
Freeze_And_Append Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result); (Designated_Type (Etype (Comp)), Loc, Result);
end if; end if;
end if;
end; end;
elsif Is_Access_Type (Etype (Comp)) elsif Is_Access_Type (Etype (Comp))
...@@ -4697,18 +4702,6 @@ package body Freeze is ...@@ -4697,18 +4702,6 @@ package body Freeze is
begin begin
Ensure_Type_Is_SA (Etype (E)); 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 exception
when Cannot_Be_Static => when Cannot_Be_Static =>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment