diff options
| -rw-r--r-- | gcc/ada/a-tags.adb | 248 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 120 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 636 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 6 |
4 files changed, 817 insertions, 193 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index a8d6cd0..cfce834 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,6 +34,8 @@ with Ada.Exceptions; with System.HTable; with System.Storage_Elements; use System.Storage_Elements; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; pragma Elaborate_All (System.HTable); @@ -42,6 +44,10 @@ package body Ada.Tags is -- Structure of the GNAT Primary Dispatch Table -- +----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | +-- +----------------------+ -- | Signature | -- +----------------------+ -- | Tagged_Kind | @@ -66,8 +72,6 @@ package body Ada.Tags is -- +-------------------+ -- | num prim ops | -- +-------------------+ --- | num interfaces | --- +-------------------+ -- | Ifaces_Table_Ptr --> Interface Data -- +-------------------+ +------------+ -- Select Specific Data <---- SSD_Ptr | | table | @@ -84,6 +88,10 @@ package body Ada.Tags is -- Structure of the GNAT Secondary Dispatch Table -- +-----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | +-- +-----------------------+ -- | Signature | -- +-----------------------+ -- | Tagged_Kind | @@ -126,9 +134,9 @@ package body Ada.Tags is -- Field_Type_Ptr in A-Tags.ads. -- Define the specifications of Get_<Field_Name> and Set_<Field_Name> - -- in A-Tags.ads. + -- in a-tags.ads. - -- Update the GNAT Dispatch Table structure in A-Tags.adb + -- Update the GNAT Dispatch Table structure in a-tags.adb -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines. -- The profile of a Get_<Field_Name> routine should resemble: @@ -184,9 +192,16 @@ package body Ada.Tags is -- Declarations for the table of interfaces type Interface_Data_Element is record - Iface_Tag : Tag; - Offset : System.Storage_Elements.Storage_Offset; + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : System.Storage_Elements.Storage_Offset; + Offset_To_Top_Func : System.Address; end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the address of the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; @@ -322,9 +337,6 @@ package body Ada.Tags is -- only to declare the corresponding access type. end record; - -- Run-time check types and subprograms: These subprograms are used only - -- when the run-time is compiled with assertions enabled. - type Signature_Type is (Must_Be_Primary_DT, Must_Be_Secondary_DT, @@ -356,6 +368,17 @@ package body Ada.Tags is function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); -- The profile of the implicitly defined _size primitive + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) + return System.Storage_Elements.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + function To_Offset_To_Top_Function_Ptr is + new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr); + type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; function To_Storage_Offset_Ptr is @@ -365,11 +388,6 @@ package body Ada.Tags is -- Local Subprograms -- ----------------------- - function Check_Index - (T : Tag; - Index : Natural) return Boolean; - -- Check that Index references a valid entry of the dispatch table of T - function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean; -- Check that the signature of T is valid and corresponds with the subset -- specified by the signature Kind. @@ -489,20 +507,6 @@ package body Ada.Tags is end HTable_Subprograms; - ----------------- - -- Check_Index -- - ----------------- - - function Check_Index - (T : Tag; - Index : Natural) return Boolean - is - Max_Entries : constant Natural := Get_Num_Prim_Ops (T); - - begin - return Index /= 0 and then Index <= Max_Entries; - end Check_Index; - --------------------- -- Check_Signature -- --------------------- @@ -624,7 +628,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -636,8 +640,25 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = T then - Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset; - Obj_DT := To_Tag_Ptr (Obj_Base).all; + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Table (Id).Static_Offset_To_Top then + Obj_Base := + Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value; + + -- Otherwise we call the function generated by the expander + -- to provide us with this value + + else + Obj_Base := + Obj_Base + + To_Offset_To_Top_Function_Ptr + (Iface_Table.Table (Id).Offset_To_Top_Func).all + (Obj_Base); + end if; + + Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert (Check_Signature (Obj_DT, Must_Be_Secondary_DT)); @@ -680,7 +701,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -782,12 +803,10 @@ package body Ada.Tags is --------------------- function Get_Entry_Index (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Index; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Index; end Get_Entry_Index; ---------------------- @@ -815,6 +834,21 @@ package body Ada.Tags is end if; end Get_Num_Prim_Ops; + -------------------------------- + -- Get_Predef_Prim_Op_Address -- + -------------------------------- + + function Get_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive) return System.Address + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position <= Default_Prim_Op_Count); + return Prim_Ops_DT.Prims_Ptr (Position); + end Get_Predefined_Prim_Op_Address; + ------------------------- -- Get_Prim_Op_Address -- ------------------------- @@ -825,7 +859,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); return T.Prims_Ptr (Position); end Get_Prim_Op_Address; @@ -837,12 +871,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Prim_Op_Kind is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Kind; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Kind; end Get_Prim_Op_Kind; ---------------------- @@ -853,12 +885,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return OSD (T).OSD_Table (Index); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return OSD (T).OSD_Table (Position); end Get_Offset_Index; ------------------- @@ -898,6 +928,9 @@ package body Ada.Tags is ---------------- procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is + Old_T_Prim_Ops : Tag; + New_T_Prim_Ops : Tag; + Size : Positive; begin pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT)); @@ -906,6 +939,11 @@ package body Ada.Tags is if Old_T /= null then New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); + Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size); + New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size); + Size := Default_Prim_Op_Count; + New_T_Prim_Ops.Prims_Ptr (1 .. Size) := + Old_T_Prim_Ops.Prims_Ptr (1 .. Size); end if; end Inherit_DT; @@ -1034,12 +1072,18 @@ package body Ada.Tags is ------------------- function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset + (This : System.Address) return System.Storage_Elements.Storage_Offset is - Offset_To_Top : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr - (To_Address (T) - K_Offset_To_Top); + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Offset_To_Top : Storage_Offset_Ptr; begin + Offset_To_Top := To_Storage_Offset_Ptr + (To_Address (Curr_DT) - K_Offset_To_Top); + + if Offset_To_Top.all = SSE.Storage_Offset'Last then + Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size); + end if; + return Offset_To_Top.all; end Offset_To_Top; @@ -1066,14 +1110,18 @@ package body Ada.Tags is Parent_Tag : Tag; -- The tag of the parent type through the dispatch table + Prim_Ops_DT : Tag; + -- The table of primitive operations of the parent + F : Acc_Size; -- Access to the _size primitive of the parent. We assume that it is -- always in the first slot of the dispatch table. begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - Parent_Tag := TSD (T).Tags_Table (1); - F := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + Parent_Tag := TSD (T).Tags_Table (1); + Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size); + F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1)); -- Here we compute the size of the _parent field of the object @@ -1156,12 +1204,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Index := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Index := Value; end Set_Entry_Index; ----------------------- @@ -1219,12 +1265,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - OSD (T).OSD_Table (Index) := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + OSD (T).OSD_Table (Position) := Value; end Set_Offset_Index; ----------------------- @@ -1234,7 +1278,9 @@ package body Ada.Tags is procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Offset_Value : System.Storage_Elements.Storage_Offset) + Is_Static : Boolean; + Offset_Value : System.Storage_Elements.Storage_Offset; + Offset_Func : System.Address) is Prim_DT : Tag; Sec_Base : System.Address; @@ -1257,7 +1303,7 @@ package body Ada.Tags is -- "This" points to the primary DT and we must save Offset_Value in the -- Offset_To_Top field of the corresponding secondary dispatch table. - Prim_DT := To_Tag_Ptr (This).all; + Prim_DT := To_Tag_Ptr (This).all; pragma Assert (Check_Signature (Prim_DT, Must_Be_Primary_DT)); @@ -1268,9 +1314,13 @@ package body Ada.Tags is To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); pragma Assert - (Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT)); + (Check_Signature (Sec_DT, Must_Be_Secondary_DT)); - Offset_To_Top.all := Offset_Value; + if Is_Static then + Offset_To_Top.all := Offset_Value; + else + Offset_To_Top.all := SSE.Storage_Offset'Last; + end if; -- Save Offset_Value in the table of interfaces of the primary DT. This -- data will be used by the subprogram "Displace" to give support to @@ -1284,7 +1334,14 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = Interface_T then - Iface_Table.Table (Id).Offset := Offset_Value; + Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static; + + if Is_Static then + Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value; + else + Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func; + end if; + return; end if; end loop; @@ -1307,6 +1364,22 @@ package body Ada.Tags is OSD_Ptr.all := Value; end Set_OSD; + ------------------------------------ + -- Set_Predefined_Prim_Op_Address -- + ------------------------------------ + + procedure Set_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : System.Address) + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count); + Prim_Ops_DT.Prims_Ptr (Position) := Value; + end Set_Predefined_Prim_Op_Address; + ------------------------- -- Set_Prim_Op_Address -- ------------------------- @@ -1318,7 +1391,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; @@ -1331,12 +1404,10 @@ package body Ada.Tags is Position : Positive; Value : Prim_Op_Kind) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Kind := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; ------------------- @@ -1359,6 +1430,19 @@ package body Ada.Tags is TSD (T).Remotely_Callable := Value; end Set_Remotely_Callable; + ------------------- + -- Set_Signature -- + ------------------- + + procedure Set_Signature (T : Tag; Value : Signature_Kind) is + Signature : constant System.Address := To_Address (T) - K_Signature; + Sig_Ptr : constant Signature_Values_Ptr := + To_Signature_Values_Ptr (Signature); + begin + Sig_Ptr.all (1) := Valid_Signature; + Sig_Ptr.all (2) := Value; + end Set_Signature; + ------------- -- Set_SSD -- ------------- @@ -1426,4 +1510,28 @@ package body Ada.Tags is return To_Type_Specific_Data_Ptr (TSD_Ptr.all); end TSD; + ------------------------ + -- Wide_Expanded_Name -- + ------------------------ + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Expanded_Name (T : Tag) return Wide_String is + begin + return String_To_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Expanded_Name; + + ----------------------------- + -- Wide_Wide_Expanded_Name -- + ----------------------------- + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + begin + return String_To_Wide_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Wide_Expanded_Name; + end Ada.Tags; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 25fed4f..bb69544 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -68,6 +68,12 @@ package Ada.Tags is Tag_Error : exception; + function Wide_Expanded_Name (T : Tag) return Wide_String; + pragma Ada_05 (Wide_Expanded_Name); + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Expanded_Name); + private -- The following subprogram specifications are placed here instead of -- the package body to see them from the frontend through rtsfind. @@ -151,11 +157,25 @@ private Default_Prim_Op_Count : constant Positive := 15; -- Number of predefined primitive operations added by the Expander for a - -- tagged type. It is utilized for indexing in the two auxiliary tables - -- used for dispatching asynchronous, conditional and timed selects. In - -- order to be space efficient, indexing is performed by subtracting this - -- constant value from the provided position in the auxiliary tables (must - -- match Exp_Disp.Default_Prim_Op_Count). + -- tagged type (must match Exp_Disp.Default_Prim_Op_Count). + + type Signature_Kind is + (Unknown, + Valid_Signature, + Primary_DT, + Secondary_DT, + Abstract_Interface); + for Signature_Kind'Size use 8; + -- Kind of signature found in the header of the dispatch table. These + -- signatures are generated by the frontend and are used by the Check_XXX + -- routines to ensure that the kind of dispatch table managed by each of + -- the routines in this package is correct. This additional check is only + -- performed with this run-time package is compiled with assertions enabled + + -- The signature is a sequence of two bytes. The first byte must have the + -- value Valid_Signature, and the second byte must have a value in the + -- range Primary_DT .. Abstract_Interface. The Unknown value is used by + -- the Check_XXX routines to indicate that the signature is wrong. package SSE renames System.Storage_Elements; @@ -200,6 +220,13 @@ private -- operation in the DT, retrieve the corresponding operation's position in -- the primary dispatch table from the Offset Specific Data table of T. + function Get_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive) return System.Address; + -- Given a pointer to a dispatch table (T) and a position in the DT + -- this function returns the address of the virtual function stored + -- in it (used for dispatching calls). + function Get_Prim_Op_Address (T : Tag; Position : Positive) return System.Address; @@ -239,9 +266,11 @@ private -- Initialize the TSD of a type knowing the tag of the direct ancestor function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset; + (This : System.Address) return System.Storage_Elements.Storage_Offset; -- Returns the current value of the offset_to_top component available in - -- the prologue of the dispatch table. + -- the prologue of the dispatch table. If the parent of the tagged type + -- has discriminants this value is stored in a record component just + -- immediately after the tag component. function OSD (T : Tag) return Object_Specific_Data_Ptr; -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, @@ -305,7 +334,9 @@ private procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Offset_Value : System.Storage_Elements.Storage_Offset); + Is_Static : Boolean; + Offset_Value : System.Storage_Elements.Storage_Offset; + Offset_Func : System.Address); -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of -- the dispatch table. In primary dispatch tables the value of "This" is -- not required (and the compiler passes always the Null_Address value) and @@ -319,6 +350,14 @@ private -- Given a pointer T to a secondary dispatch table, store the pointer to -- the record containing the Object Specific Data generated by GNAT. + procedure Set_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : System.Address); + -- Given a pointer to a dispatch Table (T) and a position in the dispatch + -- table associated with a predefined primitive operation, put the address + -- of the virtual function in it (used for overriding). + procedure Set_Prim_Op_Address (T : Tag; Position : Positive; @@ -342,6 +381,9 @@ private -- Set to true if the type has been declared in a context described -- in E.4 (18). + procedure Set_Signature (T : Tag; Value : Signature_Kind); + -- Given a pointer T to a dispatch table, store the signature id + procedure Set_SSD (T : Tag; Value : System.Address); -- Given a pointer T to a dispatch Table, stores the pointer to the record -- containing the Select Specific Data generated by GNAT. @@ -363,11 +405,15 @@ private -- record containing the Type Specific Data generated by GNAT. DT_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count (4 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the first part of the dispatch table + SSE.Storage_Count + ((Default_Prim_Op_Count + 4) * + (Standard'Address_Size / System.Storage_Unit)); + -- Size of the hidden part of the dispatch table. It contains the table of + -- predefined primitive operations plus the C++ ABI header. DT_Signature_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the Signature field of the dispatch table DT_Tagged_Kind_Size : constant SSE.Storage_Count := @@ -375,23 +421,35 @@ private -- Size of the Tagged_Type_Kind field of the dispatch table DT_Offset_To_Top_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the Offset_To_Top field of the Dispatch Table DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the Typeinfo_Ptr field of the Dispatch Table DT_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of each primitive operation entry in the Dispatch Table + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of each tag + TSD_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count (10 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (10 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the first part of the type specific data TSD_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of each ancestor tag entry in the TSD type Address_Array is array (Natural range <>) of System.Address; @@ -400,24 +458,6 @@ private -- of this type are declared with a dummy size of 1, the actual size -- depending on the number of primitive operations. - type Signature_Kind is - (Unknown, - Valid_Signature, - Primary_DT, - Secondary_DT, - Abstract_Interface); - for Signature_Kind'Size use 8; - -- Kind of signature found in the header of the dispatch table. These - -- signatures are generated by the frontend and are used by the Check_XXX - -- routines to ensure that the kind of dispatch table managed by each of - -- the routines in this package is correct. This additional check is only - -- performed with this run-time package is compiled with assertions enabled - - -- The signature is a sequence of two bytes. The first byte must have the - -- value Valid_Signature, and the second byte must have a value in the - -- range Primary_DT .. Abstract_Interface. The Unknown value is used by - -- the Check_XXX routines to indicate that the signature is wrong. - -- Unchecked Conversions type Addr_Ptr is access System.Address; @@ -427,6 +467,8 @@ private array (1 .. DT_Signature_Size) of Signature_Kind; -- Type used to see the signature as a sequence of Signature_Kind values + type Signature_Values_Ptr is access all Signature_Values; + function To_Addr_Ptr is new Unchecked_Conversion (System.Address, Addr_Ptr); @@ -455,6 +497,13 @@ private new Unchecked_Conversion (System.Storage_Elements.Storage_Offset, Signature_Values); + function To_Signature_Values_Ptr is + new Unchecked_Conversion (System.Address, + Signature_Values_Ptr); + + function To_Tag is + new Unchecked_Conversion (System.Address, Tag); + function To_Tag_Ptr is new Unchecked_Conversion (System.Address, Tag_Ptr); @@ -470,6 +519,7 @@ private pragma Inline_Always (Get_Access_Level); pragma Inline_Always (Get_Entry_Index); pragma Inline_Always (Get_Offset_Index); + pragma Inline_Always (Get_Predefined_Prim_Op_Address); pragma Inline_Always (Get_Prim_Op_Address); pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_RC_Offset); @@ -488,10 +538,12 @@ private pragma Inline_Always (Set_Num_Prim_Ops); pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); + pragma Inline_Always (Set_Predefined_Prim_Op_Address); pragma Inline_Always (Set_Prim_Op_Address); pragma Inline_Always (Set_Prim_Op_Kind); pragma Inline_Always (Set_RC_Offset); pragma Inline_Always (Set_Remotely_Callable); + pragma Inline_Always (Set_Signature); pragma Inline_Always (Set_OSD); pragma Inline_Always (Set_SSD); pragma Inline_Always (Set_TSD); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6a975e6..62cfb4e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,6 +51,7 @@ with Sem; use Sem; with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; @@ -237,6 +238,17 @@ package body Exp_Ch3 is -- discriminant_checking functions of the parent can be reused by -- a derived type. + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id); + -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions + -- associated with inherited functions with controlling results which + -- are not overridden. The body of each wrapper function consists solely + -- of a return statement whose expression is an extension aggregate + -- invoking the inherited subprogram's parent subprogram and extended + -- with a null association list. + function Predef_Spec_Or_Body (Loc : Source_Ptr; Tag_Typ : Entity_Id; @@ -1097,6 +1109,7 @@ package body Exp_Ch3 is -- honest. Actually it isn't quite type honest, because there can be -- conflicts of views in the private type case. That is why we set -- Conversion_OK in the conversion node. + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ) or else Is_Private_Type (Typ)) @@ -1241,6 +1254,7 @@ package body Exp_Ch3 is if With_Default_Init and then Nkind (Id_Ref) = N_Selected_Component + and then Nkind (Arg) = N_Identifier then Append_To (Args, Make_Selected_Component (Loc, @@ -1403,6 +1417,11 @@ package body Exp_Ch3 is -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. + procedure Build_Offset_To_Top_Functions; + -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec + -- and body of the Offset_To_Top function that is generated when the + -- parent of a type with discriminants has secondary dispatch tables. + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); -- Add range checks to components of disciminated records. S is a -- subtype indication of a record component. Check_List is a list @@ -1577,7 +1596,7 @@ package body Exp_Ch3 is while Present (D) loop -- Don't generate the assignment for discriminants in derived -- tagged types if the discriminant is a renaming of some - -- ancestor discriminant. This initialization will be done + -- ancestor discriminant. This initialization will be done -- when initializing the _parent field of the derived record. if Is_Tagged and then @@ -1726,6 +1745,127 @@ package body Exp_Ch3 is return Res; end Build_Init_Call_Thru; + ----------------------------------- + -- Build_Offset_To_Top_Functions -- + ----------------------------------- + + procedure Build_Offset_To_Top_Functions is + ADT : Elmt_Id; + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; + E : Entity_Id; + + procedure Build_Offset_To_Top_Internal (Typ : Entity_Id); + -- Internal subprogram used to recursively traverse all the ancestors + + ---------------------------------- + -- Build_Offset_To_Top_Internal -- + ---------------------------------- + + procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is + begin + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Build_Offset_To_Top_Internal (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Build_Offset_To_Top_Internal (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + while Present (E) loop + if Is_Tag (E) + and then Chars (E) /= Name_uTag + then + if Typ = Rec_Type then + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Func_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); + + Set_DT_Offset_To_Top_Func (E, Func_Id); + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc)))); + Set_Result_Definition (Spec_Node, + New_Reference_To (RTE (RE_Storage_Offset), Loc)); + + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uO), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Analyze (Body_Node); + + Append_Freeze_Action (Rec_Type, Body_Node); + end if; + + Next_Elmt (ADT); + end if; + + Next_Entity (E); + end loop; + end if; + end Build_Offset_To_Top_Internal; + + -- Start of processing for Build_Offset_To_Top_Functions + + begin + if Etype (Rec_Type) = Rec_Type + or else not Has_Discriminants (Etype (Rec_Type)) + or else No (Abstract_Interfaces (Rec_Type)) + or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type)) + then + return; + end if; + + -- Skip the first _Tag, which is the main tag of the + -- tagged type. Following tags correspond with abstract + -- interfaces. + + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); + + -- Handle private types + + if Present (Full_View (Rec_Type)) then + Build_Offset_To_Top_Internal (Full_View (Rec_Type)); + else + Build_Offset_To_Top_Internal (Rec_Type); + end if; + end Build_Offset_To_Top_Functions; + -------------------------- -- Build_Init_Procedure -- -------------------------- @@ -1758,9 +1898,10 @@ package body Exp_Ch3 is ---------------------------------- procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is - E : Entity_Id; - Aux_N : Node_Id; - Iface : Entity_Id; + Aux_N : Node_Id; + E : Entity_Id; + Iface : Entity_Id; + Prev_E : Entity_Id; begin -- Climb to the ancestor (if any) handling private types @@ -1800,33 +1941,132 @@ package body Exp_Ch3 is Expression => New_Reference_To (Aux_N, Loc))); - -- Generate: - -- Set_Offset_To_Top (Init, Iface'Tag, n); + -- Issue error if Set_Offset_To_Top is not available + -- in a configurable run-time environment. - Append_To (Body_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node (First_Elmt - (Access_Disp_Table (Iface))), - Loc)), - - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, - Name_uInit), - Selector_Name => New_Reference_To - (E, Loc)), - Attribute_Name => Name_Position))))); + if not RTE_Available (RE_Set_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", Typ); + return; + end if; + + -- We generate a different call to Set_Offset_To_Top + -- when the parent of the type has discriminants + + if Typ /= Etype (Typ) + and then Has_Discriminants (Etype (Typ)) + then + pragma Assert (Present (DT_Offset_To_Top_Func (E))); + + -- Generate: + -- Set_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => False, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), + + New_Occurrence_Of (Standard_False, Loc), + + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position)), + + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (DT_Offset_To_Top_Func (E), + Loc), + Attribute_Name => + Name_Address))))); + + -- In this case the next component stores the value + -- of the offset to the top + + Prev_E := E; + Next_Entity (E); + pragma Assert (Present (E)); + + Append_To (Body_Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => + New_Reference_To (E, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (Prev_E, Loc)), + Attribute_Name => Name_Position))); + + -- Normal case: No discriminants in the parent type + + else + -- Generate: + -- Set_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => True, + -- Offset_Value => n, + -- Offset_Func => null); + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), + + New_Occurrence_Of (Standard_True, Loc), + + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position)), + + New_Reference_To + (RTE (RE_Null_Address), Loc)))); + end if; Next_Elmt (ADT); end if; @@ -1897,8 +2137,9 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then -- N is a Derived_Type_Definition that renames the parameters - -- of the ancestor type. We init it by expanding our discrims - -- and call the ancestor _init_proc with a type-converted object + -- of the ancestor type. We initialize it by expanding our + -- discriminants and call the ancestor _init_proc with a + -- type-converted object Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); @@ -1945,7 +2186,9 @@ package body Exp_Ch3 is -- _Init._Tag := Typ'Tag; -- Suppress the tag assignment when Java_VM because JVM tags are - -- represented implicitly in objects. + -- represented implicitly in objects. It is also suppressed in + -- case of CPP_Class types because in this case the tag is + -- initialized in the C++ side. if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) @@ -2375,7 +2618,10 @@ package body Exp_Ch3 is Needs_Simple_Initialization (T) and then not Is_RTE (T, RE_Tag) and then not Is_RTE (T, RE_Vtable_Ptr) - and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251) + + -- Ada 2005 (AI-251): Check also the tag of abstract interfaces + + and then not Is_RTE (T, RE_Interface_Tag); end Component_Needs_Simple_Initialization; --------------------- @@ -2552,7 +2798,8 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing!) - -- Note: the reason we exclude the CPP_Class case is ??? + -- Note: the reason we exclude the CPP_Class case is because in this + -- case the initialization is performed in the C++ side. if Is_CPP_Class (Rec_Id) then return False; @@ -2647,6 +2894,7 @@ package body Exp_Ch3 is elsif Requires_Init_Proc (Rec_Type) or else Is_Unchecked_Union (Rec_Type) then + Build_Offset_To_Top_Functions; Build_Init_Procedure; Set_Is_Public (Proc_Id, Is_Public (Pe)); @@ -3342,7 +3590,7 @@ package body Exp_Ch3 is if Is_Access_Type (Def_Id) then -- Anonymous access types are created for the components of the - -- record parameter for an entry declaration. No master is created + -- record parameter for an entry declaration. No master is created -- for such a type. if Has_Task (Designated_Type (Def_Id)) @@ -3352,17 +3600,22 @@ package body Exp_Ch3 is Build_Master_Renaming (Parent (Def_Id), Def_Id); -- Create a class-wide master because a Master_Id must be generated - -- for access-to-limited-class-wide types, whose root may be extended - -- with task components. + -- for access-to-limited-class-wide types whose root may be extended + -- with task components, and for access-to-limited-interfaces because + -- they can be used to reference tasks implementing such interface. elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) - and then Is_Limited_Type (Designated_Type (Def_Id)) + and then (Is_Limited_Type (Designated_Type (Def_Id)) + or else + (Is_Interface (Designated_Type (Def_Id)) + and then + Is_Limited_Interface (Designated_Type (Def_Id)))) and then Tasking_Allowed - -- Don't create a class-wide master for types whose convention is + -- Do not create a class-wide master for types whose convention is -- Java since these types cannot embed Ada tasks anyway. Note that -- the following test cannot catch the following case: - -- + -- package java.lang.Object is -- type Typ is tagged limited private; -- type Ref is access all Typ'Class; @@ -3370,7 +3623,7 @@ package body Exp_Ch3 is -- type Typ is tagged limited ...; -- pragma Convention (Typ, Java) -- end; - -- + -- Because the convention appears after we have done the -- processing for type Ref. @@ -3487,7 +3740,7 @@ package body Exp_Ch3 is if No (Expr) then - -- Expand Initialize call for controlled objects. One may wonder why + -- Expand Initialize call for controlled objects. One may wonder why -- the Initialize Call is not done in the regular Init procedure -- attached to the record type. That's because the init procedure is -- recursively called on each component, including _Parent, thus the @@ -3591,21 +3844,27 @@ package body Exp_Ch3 is -- Generate attribute for Persistent_BSS if needed - declare - Prag : Node_Id; - begin - if Persistent_BSS_Mode - and then Comes_From_Source (N) - and then Is_Potentially_Persistent_Type (Typ) - and then Is_Library_Level_Entity (Def_Id) - then + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin Prag := Make_Linker_Section_Pragma (Def_Id, Sloc (N), ".persistent.bss"); Insert_After (N, Prag); Analyze (Prag); - end if; - end; + end; + end if; + + -- If access type, then we know it is null if not initialized + + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); + end if; -- Explicit initialization present @@ -3618,23 +3877,23 @@ package body Exp_Ch3 is Expr_Q := Expr; end if; - -- When we have the appropriate type of aggregate in the - -- expression (it has been determined during analysis of the - -- aggregate by setting the delay flag), let's perform in - -- place assignment and thus avoid creating a temporary. + -- When we have the appropriate type of aggregate in the expression + -- (it has been determined during analysis of the aggregate by + -- setting the delay flag), let's perform in place assignment and + -- thus avoid creating a temporary. if Is_Delayed_Aggregate (Expr_Q) then Convert_Aggr_In_Object_Decl (N); else - -- In most cases, we must check that the initial value meets - -- any constraint imposed by the declared type. However, there - -- is one very important exception to this rule. If the entity - -- has an unconstrained nominal subtype, then it acquired its - -- constraints from the expression in the first place, and not - -- only does this mean that the constraint check is not needed, - -- but an attempt to perform the constraint check can - -- cause order of elaboration problems. + -- In most cases, we must check that the initial value meets any + -- constraint imposed by the declared type. However, there is one + -- very important exception to this rule. If the entity has an + -- unconstrained nominal subtype, then it acquired its constraints + -- from the expression in the first place, and not only does this + -- mean that the constraint check is not needed, but an attempt to + -- perform the constraint check can cause order order of + -- elaboration problems. if not Is_Constr_Subt_For_U_Nominal (Typ) then @@ -3653,6 +3912,7 @@ package body Exp_Ch3 is -- If the type is controlled we attach the object to the final -- list and adjust the target after the copy. This + -- ??? incomplete sentence if Controlled_Type (Typ) then declare @@ -3662,10 +3922,10 @@ package body Exp_Ch3 is begin -- Attach the result to a dummy final list which will never -- be finalized if Delay_Finalize_Attachis set. It is - -- important to attach to a dummy final list rather than - -- not attaching at all in order to reset the pointers - -- coming from the initial value. Equivalent code exists - -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. + -- important to attach to a dummy final list rather than not + -- attaching at all in order to reset the pointers coming + -- from the initial value. Equivalent code exists in the + -- sec-stack case in Exp_Ch4.Expand_N_Allocator. if Delay_Finalize_Attach (N) then F := @@ -3694,11 +3954,11 @@ package body Exp_Ch3 is -- For tagged types, when an init value is given, the tag has to -- be re-initialized separately in order to avoid the propagation -- of a wrong tag coming from a view conversion unless the type - -- is class wide (in this case the tag comes from the init - -- value). Suppress the tag assignment when Java_VM because JVM - -- tags are represented implicitly in objects. Ditto for types - -- that are CPP_CLASS, and for initializations that are - -- aggregates, because they have to have the right tag. + -- is class wide (in this case the tag comes from the init value). + -- Suppress the tag assignment when Java_VM because JVM tags are + -- represented implicitly in objects. Ditto for types that are + -- CPP_CLASS, and for initializations that are aggregates, because + -- they have to have the right tag. if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) @@ -3706,8 +3966,8 @@ package body Exp_Ch3 is and then not Java_VM and then Nkind (Expr) /= N_Aggregate then - -- The re-assignment of the tag has to be done even if - -- the object is a constant + -- The re-assignment of the tag has to be done even if the + -- object is a constant. New_Ref := Make_Selected_Component (Loc, @@ -3731,9 +3991,7 @@ package body Exp_Ch3 is -- For discrete types, set the Is_Known_Valid flag if the -- initializing value is known to be valid. - elsif Is_Discrete_Type (Typ) - and then Expr_Known_Valid (Expr) - then + elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then Set_Is_Known_Valid (Def_Id); elsif Is_Access_Type (Typ) then @@ -3743,7 +4001,7 @@ package body Exp_Ch3 is -- Can_Never_Be_Null if this is a constant. if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id); + Set_Is_Known_Non_Null (Def_Id, True); if Constant_Present (N) then Set_Can_Never_Be_Null (Def_Id); @@ -3761,19 +4019,19 @@ package body Exp_Ch3 is end if; end if; - -- Cases where the back end cannot handle the initialization - -- directly. In such cases, we expand an assignment that will - -- be appropriately handled by Expand_N_Assignment_Statement. + -- Cases where the back end cannot handle the initialization directly + -- In such cases, we expand an assignment that will be appropriately + -- handled by Expand_N_Assignment_Statement. - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? if (Is_Possibly_Unaligned_Slice (Expr) or else (Is_Possibly_Unaligned_Object (Expr) and then not Represented_As_Scalar (Etype (Expr)))) - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now + -- it is too much trouble ??? and then not (Is_Array_Type (Etype (Expr)) and then not Is_Constrained (Etype (Expr))) @@ -4427,6 +4685,9 @@ package body Exp_Ch3 is Renamed_Eq : Node_Id := Empty; -- Could use some comments ??? + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + begin -- Build discriminant checking functions if not a derived type (for -- derived types that are not tagged types, we always use the @@ -4508,6 +4769,17 @@ package body Exp_Ch3 is if Is_Tagged_Type (Def_Id) then if Is_CPP_Class (Def_Id) then + + -- Because of the new C++ ABI compatibility we now allow the + -- programer to use the Ada tag (and in this case we must do + -- the normal expansion of the tag) + + if Etype (First_Component (Def_Id)) = RTE (RE_Tag) + and then Underlying_Type (Etype (Def_Id)) = Def_Id + then + Expand_Tagged_Root (Def_Id); + end if; + Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); @@ -4562,6 +4834,21 @@ package body Exp_Ch3 is (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- the parent function. + + if Ada_Version >= Ada_05 + and then not Is_Abstract (Def_Id) + and then Is_Null_Extension (Def_Id) + then + Make_Controlling_Function_Wrappers + (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + Set_Is_Frozen (Def_Id, True); Set_All_DT_Position (Def_Id); @@ -4752,11 +5039,19 @@ package body Exp_Ch3 is Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Def_Id, Wrapper_Body_List); + end if; + -- Populate the two auxiliary tables used for dispatching -- asynchronous, conditional and timed selects for synchronized -- types that implement a limited interface. if Ada_Version >= Ada_05 + and then not Restriction_Active (No_Dispatching_Calls) and then Is_Concurrent_Record_Type (Def_Id) and then Implements_Interface ( Typ => Def_Id, @@ -5022,7 +5317,7 @@ package body Exp_Ch3 is -- code requires both those types to be frozen if Is_Frozen (Desig_Type) - and then (not Present (Freeze_Node (Desig_Type)) + and then (No (Freeze_Node (Desig_Type)) or else Analyzed (Freeze_Node (Desig_Type))) then Freeze_Action_Typ := Def_Id; @@ -5608,6 +5903,167 @@ package body Exp_Ch3 is return Empty_List; end Init_Formals; + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Actual_List : List_Id; + Formal_List : List_Id; + Formal : Entity_Id; + Par_Formal : Entity_Id; + Formal_Node : Node_Id; + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + Return_Stmt : Node_Id; + + begin + Decl_List := New_List; + Body_List := New_List; + + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a primitive function with a controlling result of the type has + -- not been overridden by the user, then we must create a wrapper + -- function here that effectively overrides it and invokes the + -- abstract inherited function's nonabstract parent. This can only + -- occur for a null extension. Note that functions with anonymous + -- controlling access results don't qualify and must be overridden. + -- We also exclude Input attributes, since each type will have its + -- own version of Input constructed by the expander. The test for + -- Comes_From_Source is needed to distinguish inherited operations + -- from renamings (which also have Alias set). + + if Is_Abstract (Subp) + and then Present (Alias (Subp)) + and then not Comes_From_Source (Subp) + and then Ekind (Subp) = E_Function + and then Has_Controlling_Result (Subp) + and then not Is_Access_Type (Etype (Subp)) + and then not Is_TSS (Subp, TSS_Stream_Input) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + Append + (Make_Parameter_Specification + (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => + Formal_List, + Result_Definition => + New_Reference_To (Etype (Subp), Loc)); + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Append_To (Decl_List, Func_Decl); + + -- Build a wrapper body that calls the parent function. The body + -- contains a single return statement that returns an extension + -- aggregate whose ancestor part is a call to the parent function, + -- passing the formals as actuals (with any controlling arguments + -- converted to the types of the corresponding formals of the + -- parent function, which might be anonymous access types), and + -- having a null extension. + + Formal := First_Formal (Subp); + Par_Formal := First_Formal (Alias (Subp)); + Formal_Node := First (Formal_List); + + if Present (Formal) then + Actual_List := New_List; + else + Actual_List := No_List; + end if; + + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Reference_To + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, + New_Reference_To + (Defining_Identifier (Formal_Node), Loc)); + end if; + + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + + Return_Stmt := + Make_Return_Statement (Loc, + Expression => + Make_Extension_Aggregate (Loc, + Ancestor_Part => + Make_Function_Call (Loc, + Name => New_Reference_To (Alias (Subp), Loc), + Parameter_Associations => Actual_List), + Null_Record_Present => True)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + + Set_Defining_Unit_Name + (Specification (Func_Body), + Make_Defining_Identifier (Loc, Chars (Subp))); + + Append_To (Body_List, Func_Body); + + -- Replace the inherited function with the wrapper function + -- in the primitive operations list. + + Override_Dispatching_Operation + (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Make_Controlling_Function_Wrappers; + ------------------ -- Make_Eq_Case -- ------------------ @@ -6371,6 +6827,8 @@ package body Exp_Ch3 is if Ada_Version >= Ada_05 and then + not Restriction_Active (No_Dispatching_Calls) + and then ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) or else (Is_Concurrent_Record_Type (Tag_Typ) diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 3b4522c..acc7ac92 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -502,6 +502,7 @@ package Rtsfind is RE_Get_Entry_Index, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags RE_Get_Offset_Index, -- Ada.Tags + RE_Get_Predefined_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags @@ -539,11 +540,13 @@ package Rtsfind is RE_Set_Offset_Index, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_OSD, -- Ada.Tags + RE_Set_Predefined_Prim_Op_Address, -- Ada.Tags RE_Set_Prim_Op_Address, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_SSD, -- Ada.Tags + RE_Set_Signature, -- Ada.Tags RE_Set_Tagged_Kind, -- Ada.Tags RE_Set_TSD, -- Ada.Tags RE_Tag, -- Ada.Tags @@ -1656,6 +1659,7 @@ package Rtsfind is RE_Get_Entry_Index => Ada_Tags, RE_Get_External_Tag => Ada_Tags, RE_Get_Offset_Index => Ada_Tags, + RE_Get_Predefined_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, @@ -1693,11 +1697,13 @@ package Rtsfind is RE_Set_Offset_Index => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, RE_Set_OSD => Ada_Tags, + RE_Set_Predefined_Prim_Op_Address => Ada_Tags, RE_Set_Prim_Op_Address => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, RE_Set_RC_Offset => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags, RE_Set_SSD => Ada_Tags, + RE_Set_Signature => Ada_Tags, RE_Set_Tagged_Kind => Ada_Tags, RE_Set_TSD => Ada_Tags, RE_Tag => Ada_Tags, |