diff options
| -rw-r--r-- | gcc/ada/a-tags.adb | 653 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 517 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.adb | 738 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.ads | 132 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 4262 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 101 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 142 |
8 files changed, 3566 insertions, 3043 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 556265ac2fa..622087a08ad 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -41,32 +41,40 @@ pragma Elaborate_All (System.HTable); package body Ada.Tags is - -- Object specific data types (see description in a-tags.ads) + ----------------------- + -- Local Subprograms -- + ----------------------- + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. - type Object_Specific_Data_Array is array (Positive range <>) of Positive; + function Get_External_Tag (T : Tag) return System.Address; + -- Returns address of a null terminated string containing the external name - type Object_Specific_Data (Nb_Prim : Positive) is record - OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim); - -- Table used in secondary DT to reference their counterpart in the - -- select specific data (in the TSD of the primary DT). This construct - -- is used in the handling of dispatching triggers in select statements. - -- Nb_Prim is the number of non-predefined primitive operations. - end record; + function Is_Primary_DT (T : Tag) return Boolean; + -- Given a tag returns True if it has the signature of a primary dispatch + -- table. This is Inline_Always since it is called from other Inline_ + -- Always subprograms where we want no out of line code to be generated. - -- Select specific data types + function Length (Str : Cstring_Ptr) return Natural; + -- Length of string represented by the given pointer (treating the string + -- as a C-style string, which is Nul terminated). - type Select_Specific_Data_Element is record - Index : Positive; - Kind : Prim_Op_Kind; - end record; + function OSD (T : Tag) return Object_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- retrieve the address of the record containing the Object Specific + -- Data table. - type Select_Specific_Data_Array is - array (Positive range <>) of Select_Specific_Data_Element; + function SSD (T : Tag) return Select_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the + -- address of the record containing the Select Specific Data in T's TSD. - type Select_Specific_Data (Nb_Prim : Positive) is record - SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); - -- NOTE: Nb_Prim is the number of non-predefined primitive operations - end record; + pragma Inline_Always (CW_Membership); + pragma Inline_Always (Get_External_Tag); + pragma Inline_Always (Is_Primary_DT); + pragma Inline_Always (OSD); + pragma Inline_Always (SSD); --------------------------------------------- -- Unchecked Conversions for String Fields -- @@ -78,6 +86,17 @@ package body Ada.Tags is function To_Cstring_Ptr is new Unchecked_Conversion (System.Address, Cstring_Ptr); + -- Disable warnings on possible aliasing problem because we only use + -- use this function to convert tags found in the External_Tag of + -- locally defined tagged types. + + pragma Warnings (off); + + function To_Tag is + new Unchecked_Conversion (Integer_Address, Tag); + + pragma Warnings (on); + ------------------------------------------------ -- Unchecked Conversions for other components -- ------------------------------------------------ @@ -88,47 +107,93 @@ 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. + ------------------------------- + -- Inline_Always Subprograms -- + ------------------------------- - function To_Offset_To_Top_Function_Ptr is - new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr); + -- Inline_always subprograms must be placed before their first call to + -- avoid defeating the frontend inlining mechanism and thus ensure the + -- generation of their correct debug info. - type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; + ------------------- + -- CW_Membership -- + ------------------- - function To_Storage_Offset_Ptr is - new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); + -- Canonical implementation of Classwide Membership corresponding to: - ----------------------- - -- Local Subprograms -- - ----------------------- + -- Obj in Typ'Class - function Is_Primary_DT (T : Tag) return Boolean; - pragma Inline_Always (Is_Primary_DT); - -- Given a tag returns True if it has the signature of a primary dispatch - -- table. This is Inline_Always since it is called from other Inline_ - -- Always subprograms where we want no out of line code to be generated. + -- Each dispatch table contains a reference to a table of ancestors (stored + -- in the first part of the Tags_Table) and a count of the level of + -- inheritance "Idepth". - function Length (Str : Cstring_Ptr) return Natural; - -- Length of string represented by the given pointer (treating the string - -- as a C-style string, which is Nul terminated). + -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are + -- contained in the dispatch table referenced by Obj'Tag . Knowing the + -- level of inheritance of both types, this can be computed in constant + -- time by the formula: + + -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) + -- = Typ'tag + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is + Obj_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); + Typ_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); + Obj_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); + Typ_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); + Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; + begin + return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; + end CW_Membership; + + ---------------------- + -- Get_External_Tag -- + ---------------------- - function Predefined_DT (T : Tag) return Tag; - pragma Inline_Always (Predefined_DT); - -- Displace the Tag to reference the dispatch table containing the - -- predefined primitives. + function Get_External_Tag (T : Tag) return System.Address is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return To_Address (TSD.External_Tag); + end Get_External_Tag; - function Typeinfo_Ptr (T : Tag) return System.Address; - -- Returns the current value of the typeinfo_ptr component available in - -- the prologue of the dispatch table. + ------------------- + -- Is_Primary_DT -- + ------------------- - pragma Unreferenced (Typeinfo_Ptr); - -- These functions will be used for full compatibility with the C++ ABI + function Is_Primary_DT (T : Tag) return Boolean is + begin + return DT (T).Signature = Primary_DT; + end Is_Primary_DT; + + --------- + -- OSD -- + --------- + + function OSD (T : Tag) return Object_Specific_Data_Ptr is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + begin + return To_Object_Specific_Data_Ptr (OSD_Ptr.all); + end OSD; + + --------- + -- SSD -- + --------- + + function SSD (T : Tag) return Select_Specific_Data_Ptr is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.SSD; + end SSD; ------------------------- -- External_Tag_HTable -- @@ -192,8 +257,12 @@ package body Ada.Tags is ----------------- function Get_HT_Link (T : Tag) return Tag is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); begin - return TSD (T).HT_Link; + return TSD.HT_Link; end Get_HT_Link; ---------- @@ -213,39 +282,16 @@ package body Ada.Tags is ----------------- procedure Set_HT_Link (T : Tag; Next : Tag) is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); begin - TSD (T).HT_Link := Next; + TSD.HT_Link := Next; end Set_HT_Link; end HTable_Subprograms; - ------------------- - -- CW_Membership -- - ------------------- - - -- Canonical implementation of Classwide Membership corresponding to: - - -- Obj in Typ'Class - - -- Each dispatch table contains a reference to a table of ancestors (stored - -- in the first part of the Tags_Table) and a count of the level of - -- inheritance "Idepth". - - -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are - -- contained in the dispatch table referenced by Obj'Tag . Knowing the - -- level of inheritance of both types, this can be computed in constant - -- time by the formula: - - -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) - -- = Typ'tag - - function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is - Pos : Integer; - begin - Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; - return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag; - end CW_Membership; - ------------------ -- Base_Address -- ------------------ @@ -265,14 +311,18 @@ package body Ada.Tags is is Iface_Table : Interface_Data_Ptr; Obj_Base : System.Address; - Obj_DT : Tag; - Obj_TSD : Type_Specific_Data_Ptr; + Obj_DT : Dispatch_Table_Ptr; + Obj_DT_Tag : Tag; begin - Obj_Base := This - Offset_To_Top (This); - Obj_DT := To_Tag_Ptr (Obj_Base).all; - Obj_TSD := TSD (Obj_DT); - Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); + if System."=" (This, System.Null_Address) then + return System.Null_Address; + end if; + + Obj_Base := Base_Address (This); + Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop @@ -288,14 +338,11 @@ package body Ada.Tags is -- to provide us with this value else - Obj_Base := - Obj_Base + - To_Offset_To_Top_Function_Ptr - (Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all - (Obj_Base); + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all + (Obj_Base); end if; - Obj_DT := To_Tag_Ptr (Obj_Base).all; return Obj_Base; end if; end loop; @@ -304,7 +351,7 @@ package body Ada.Tags is -- Check if T is an immediate ancestor. This is required to handle -- conversion of class-wide interfaces to tagged types. - if CW_Membership (Obj_DT, T) then + if CW_Membership (Obj_DT_Tag, T) then return Obj_Base; end if; @@ -313,6 +360,17 @@ package body Ada.Tags is raise Constraint_Error; end Displace; + -------- + -- DT -- + -------- + + function DT (T : Tag) return Dispatch_Table_Ptr is + Offset : constant SSE.Storage_Offset := + To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; + begin + return To_Dispatch_Table_Ptr (To_Address (T) - Offset); + end DT; + ------------------- -- IW_Membership -- ------------------- @@ -329,20 +387,15 @@ package body Ada.Tags is function IW_Membership (This : System.Address; T : Tag) return Boolean is Iface_Table : Interface_Data_Ptr; - Last_Id : Natural; Obj_Base : System.Address; - Obj_DT : Tag; + Obj_DT : Dispatch_Table_Ptr; Obj_TSD : Type_Specific_Data_Ptr; begin - Obj_Base := This - Offset_To_Top (This); - Obj_DT := To_Tag_Ptr (Obj_Base).all; - Obj_TSD := TSD (Obj_DT); - Last_Id := Obj_TSD.Idepth; - - -- Look for the tag in the table of interfaces - - Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); + Obj_Base := Base_Address (This); + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); + Iface_Table := Obj_TSD.Interfaces_Table; if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop @@ -355,7 +408,7 @@ package body Ada.Tags is -- Look for the tag in the ancestor tags table. This is required for: -- Iface_CW in Typ'Class - for Id in 0 .. Last_Id loop + for Id in 0 .. Obj_TSD.Idepth loop if Obj_TSD.Tags_Table (Id) = T then return True; end if; @@ -384,14 +437,18 @@ package body Ada.Tags is ------------------- function Expanded_Name (T : Tag) return String is - Result : Cstring_Ptr; + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; begin if T = No_Tag then raise Tag_Error; end if; - Result := TSD (T).Expanded_Name; + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.Expanded_Name; return Result (1 .. Length (Result)); end Expanded_Name; @@ -400,14 +457,18 @@ package body Ada.Tags is ------------------ function External_Tag (T : Tag) return String is - Result : Cstring_Ptr; + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; begin if T = No_Tag then raise Tag_Error; end if; - Result := TSD (T).External_Tag; + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.External_Tag; return Result (1 .. Length (Result)); end External_Tag; @@ -421,15 +482,6 @@ package body Ada.Tags is end Get_Entry_Index; ---------------------- - -- Get_External_Tag -- - ---------------------- - - function Get_External_Tag (T : Tag) return System.Address is - begin - return To_Address (TSD (T).External_Tag); - end Get_External_Tag; - - ---------------------- -- Get_Prim_Op_Kind -- ---------------------- @@ -462,8 +514,12 @@ package body Ada.Tags is ------------------- function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); begin - return TSD (T).RC_Offset; + return TSD.RC_Offset; end Get_RC_Offset; --------------------- @@ -471,10 +527,8 @@ package body Ada.Tags is --------------------- function Get_Tagged_Kind (T : Tag) return Tagged_Kind is - Tagged_Kind_Ptr : constant System.Address := - To_Address (T) - K_Tagged_Kind; begin - return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all; + return DT (T).Tag_Kind; end Get_Tagged_Kind; ----------------------------- @@ -482,11 +536,13 @@ package body Ada.Tags is ----------------------------- function Interface_Ancestor_Tags (T : Tag) return Tag_Array is - Iface_Table : Interface_Data_Ptr; + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; begin - Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr); - if Iface_Table = null then declare Table : Tag_Array (1 .. 0); @@ -510,17 +566,67 @@ package body Ada.Tags is -- Internal_Tag -- ------------------ + -- Internal tags have the following format: + -- "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>" + + Internal_Tag_Header : constant String := "Internal tag at "; + Header_Separator : constant Character := '#'; + function Internal_Tag (External : String) return Tag is Ext_Copy : aliased String (External'First .. External'Last + 1); - Res : Tag; + Res : Tag := null; begin - -- Make a copy of the string representing the external tag with - -- a null at the end. + -- Handle locally defined tagged types + + if External'Length > Internal_Tag_Header'Length + and then + External (External'First .. + External'First + Internal_Tag_Header'Length - 1) + = Internal_Tag_Header + then + declare + Addr_First : constant Natural := + External'First + Internal_Tag_Header'Length; + Addr_Last : Natural; + Addr : Integer_Address; + + begin + -- Search the second separator (#) to identify the address + + Addr_Last := Addr_First; + + for J in 1 .. 2 loop + while Addr_Last <= External'Last + and then External (Addr_Last) /= Header_Separator + loop + Addr_Last := Addr_Last + 1; + end loop; + + -- Skip the first separator + + if J = 1 then + Addr_Last := Addr_Last + 1; + end if; + end loop; + + if Addr_Last <= External'Last then + Addr := + Integer_Address'Value (External (Addr_First .. Addr_Last)); + return To_Tag (Addr); + end if; + end; + + -- Handle library-level tagged types + + else + -- Make a copy of the string representing the external tag with + -- a null at the end. - Ext_Copy (External'Range) := External; - Ext_Copy (Ext_Copy'Last) := ASCII.NUL; - Res := External_Tag_HTable.Get (Ext_Copy'Address); + Ext_Copy (External'Range) := External; + Ext_Copy (Ext_Copy'Last) := ASCII.NUL; + Res := External_Tag_HTable.Get (Ext_Copy'Address); + end if; if Res = null then declare @@ -546,32 +652,30 @@ package body Ada.Tags is (Descendant : Tag; Ancestor : Tag) return Boolean is + D_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Descendant) + - DT_Typeinfo_Ptr_Size); + A_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); + D_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); + A_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); + begin return CW_Membership (Descendant, Ancestor) - and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level; + and then D_TSD.Access_Level = A_TSD.Access_Level; end Is_Descendant_At_Same_Level; - ------------------- - -- Is_Primary_DT -- - ------------------- - - function Is_Primary_DT (T : Tag) return Boolean is - Signature : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - K_Signature); - Sig_Values : constant Signature_Values := - To_Signature_Values (Signature.all); - begin - return Sig_Values (2) = Primary_DT; - end Is_Primary_DT; - ------------ -- Length -- ------------ function Length (Str : Cstring_Ptr) return Natural is - Len : Integer := 1; + Len : Integer; begin + Len := 1; while Str (Len) /= ASCII.Nul loop Len := Len + 1; end loop; @@ -584,31 +688,26 @@ package body Ada.Tags is ------------------- function Offset_To_Top - (This : System.Address) return System.Storage_Elements.Storage_Offset + (This : System.Address) return SSE.Storage_Offset is - 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; + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - return Offset_To_Top.all; - end Offset_To_Top; + type Storage_Offset_Ptr is access SSE.Storage_Offset; + function To_Storage_Offset_Ptr is + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); - --------- - -- OSD -- - --------- + Curr_DT : Dispatch_Table_Ptr; - function OSD (T : Tag) return Object_Specific_Data_Ptr is - OSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - return To_Object_Specific_Data_Ptr (OSD_Ptr.all); - end OSD; + Curr_DT := DT (To_Tag_Ptr (This).all); + + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + return To_Storage_Offset_Ptr (This + Tag_Size).all; + else + return Curr_DT.Offset_To_Top; + end if; + end Offset_To_Top; ----------------- -- Parent_Size -- @@ -626,16 +725,28 @@ package body Ada.Tags is -- The pointer to the _size primitive is always in the first slot of -- the dispatch table. - Parent_Tag : Tag; - -- The tag of the parent type through the dispatch table - - F : Acc_Size; + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + -- Pointer to the TSD + + Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); + Parent_Predef_Prims_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Parent_Tag) + - DT_Predef_Prims_Offset); + Parent_Predef_Prims : constant Predef_Prims_Table_Ptr := + To_Predef_Prims_Table_Ptr + (Parent_Predef_Prims_Ptr.all); + + -- The tag of the parent type through the dispatch table and its + -- Predef_Prims field. + + F : constant Acc_Size := + To_Acc_Size (Parent_Predef_Prims (Size_Slot)); -- Access to the _size primitive of the parent begin - Parent_Tag := TSD (T).Tags_Table (Parent_Slot); - F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot)); - -- Here we compute the size of the _parent field of the object return SSE.Storage_Count (F.all (Obj)); @@ -646,50 +757,29 @@ package body Ada.Tags is ---------------- function Parent_Tag (T : Tag) return Tag is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + begin if T = No_Tag then raise Tag_Error; end if; + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. -- The first entry in the Ancestors_Tags array will be null for such -- a type, but it's better to be explicit about returning No_Tag in -- this case. - if TSD (T).Idepth = 0 then + if TSD.Idepth = 0 then return No_Tag; else - return TSD (T).Tags_Table (1); + return TSD.Tags_Table (1); end if; end Parent_Tag; - ------------------- - -- Predefined_DT -- - ------------------- - - function Predefined_DT (T : Tag) return Tag is - begin - return To_Tag (To_Address (T) - DT_Prologue_Size); - end Predefined_DT; - - ---------------------------- - -- Register_Interface_Tag -- - ---------------------------- - - procedure Register_Interface_Tag - (T : Tag; - Interface_T : Tag; - Position : Positive) - is - New_T_TSD : Type_Specific_Data_Ptr; - Iface_Table : Interface_Data_Ptr; - - begin - New_T_TSD := TSD (T); - Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr); - Iface_Table.Ifaces_Table (Position).Iface_Tag := Interface_T; - end Register_Interface_Tag; - ------------------ -- Register_Tag -- ------------------ @@ -712,86 +802,54 @@ package body Ada.Tags is SSD (T).SSD_Table (Position).Index := Value; end Set_Entry_Index; - ------------------------- - -- Set_Interface_Table -- - ------------------------- - - procedure Set_Interface_Table (T : Tag; Value : System.Address) is - begin - TSD (T).Ifaces_Table_Ptr := Value; - end Set_Interface_Table; - - ---------------------- - -- Set_Offset_Index -- - ---------------------- - - procedure Set_Offset_Index - (T : Tag; - Position : Positive; - Value : Positive) - is - begin - OSD (T).OSD_Table (Position) := Value; - end Set_Offset_Index; - ----------------------- -- Set_Offset_To_Top -- ----------------------- procedure Set_Offset_To_Top - (This : System.Address; - Interface_T : Tag; - Is_Static : Boolean; - Offset_Value : System.Storage_Elements.Storage_Offset; - Offset_Func : System.Address) + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) is - Prim_DT : Tag; - Sec_Base : System.Address; - Sec_DT : Tag; - Offset_To_Top : Storage_Offset_Ptr; - Iface_Table : Interface_Data_Ptr; - Obj_TSD : Type_Specific_Data_Ptr; - begin - if System."=" (This, System.Null_Address) then - Offset_To_Top := - To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top); - Offset_To_Top.all := Offset_Value; - return; - end if; - - -- "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 : Dispatch_Table_Ptr; + Sec_Base : System.Address; + Sec_DT : Dispatch_Table_Ptr; + Iface_Table : Interface_Data_Ptr; - -- Save the offset to top field in the secondary dispatch table. + begin + -- Save the offset to top field in the secondary dispatch table if Offset_Value /= 0 then Sec_Base := This + Offset_Value; - Sec_DT := To_Tag_Ptr (Sec_Base).all; - Offset_To_Top := - To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); + Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); if Is_Static then - Offset_To_Top.all := Offset_Value; + Sec_DT.Offset_To_Top := Offset_Value; else - Offset_To_Top.all := SSE.Storage_Offset'Last; + Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; end if; 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 - -- backward abstract interface type conversions. + -- "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 := DT (To_Tag_Ptr (This).all); + Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; - Obj_TSD := TSD (Prim_DT); - Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); + -- 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 backward abstract interface type conversions. -- Register the offset in the table of interfaces if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := Is_Static; + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := + Is_Static; if Is_Static then Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value @@ -811,17 +869,6 @@ package body Ada.Tags is raise Program_Error; end Set_Offset_To_Top; - ------------- - -- Set_OSD -- - ------------- - - procedure Set_OSD (T : Tag; Value : System.Address) is - OSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - K_Typeinfo); - begin - OSD_Ptr.all := Value; - end Set_OSD; - ---------------------- -- Set_Prim_Op_Kind -- ---------------------- @@ -835,70 +882,6 @@ package body Ada.Tags is SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; - ------------------- - -- 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 -- - ------------- - - procedure Set_SSD (T : Tag; Value : System.Address) is - begin - TSD (T).SSD_Ptr := Value; - end Set_SSD; - - --------------------- - -- Set_Tagged_Kind -- - --------------------- - - procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is - Tagged_Kind_Ptr : constant System.Address := - To_Address (T) - K_Tagged_Kind; - begin - To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value; - end Set_Tagged_Kind; - - --------- - -- SSD -- - --------- - - function SSD (T : Tag) return Select_Specific_Data_Ptr is - begin - return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr); - end SSD; - - ------------------ - -- Typeinfo_Ptr -- - ------------------ - - function Typeinfo_Ptr (T : Tag) return System.Address is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - K_Typeinfo); - begin - return TSD_Ptr.all; - end Typeinfo_Ptr; - - --------- - -- TSD -- - --------- - - function TSD (T : Tag) return Type_Specific_Data_Ptr is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - K_Typeinfo); - begin - return To_Type_Specific_Data_Ptr (TSD_Ptr.all); - end TSD; - ------------------------ -- Wide_Expanded_Name -- ------------------------ diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index bc39cd509e2..538c3e97af2 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -37,7 +37,7 @@ with System; with System.Storage_Elements; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package Ada.Tags is pragma Preelaborate_05; @@ -84,17 +84,15 @@ private -- Structure of the GNAT Primary Dispatch Table -- +--------------------+ - -- | table of | - -- :predefined primitive: - -- | ops pointers | - -- +--------------------+ -- | Signature | -- +--------------------+ -- | Tagged_Kind | - -- +--------------------+ - -- | Offset_To_Top | - -- +--------------------+ - -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+ -- Tag ---> +--------------------+ +-------------------+ -- | table of | | inheritance depth | -- : primitive ops : +-------------------+ @@ -110,16 +108,14 @@ private -- +-------------------+ -- | rec ctrler offset | -- +-------------------+ - -- | num prim ops | - -- +-------------------+ - -- | Ifaces_Table_Ptr --> Interface Data + -- | Ifaces_Table ---> Interface Data -- +-------------------+ +------------+ - -- Select Specific Data <---- SSD_Ptr | | table | - -- +------------------+ +-------------------+ : of : - -- |table of primitive| | table of | | interfaces | - -- : operation : : ancestor : +------------+ - -- | kinds | | tags | - -- +------------------+ +-------------------+ + -- Select Specific Data <---- SSD | | Nb_Ifaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of primitive| | table of | | table | + -- : operation : : ancestor : : of : + -- | kinds | | tags | | interfaces | + -- +------------------+ +-------------------+ +------------+ -- |table of | -- : entry : -- | indices | @@ -148,77 +144,88 @@ private -- +---------------+ -- The runtime information kept for each tagged type is separated into two - -- objects: the Dispatch Table and the Type Specific Data record. These - -- two objects are allocated statically using the constants: - - -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size - - -- where Nb_prim is the number of primitive operations of the given - -- type and Idepth its inheritance depth. - - type Address_Array is array (Natural range <>) of System.Address; - pragma Suppress (Index_Check, On => Address_Array); - -- The reason we suppress index checks is that in the dispatch table, - -- the component of this type is declared with a dummy size of 1, the - -- actual size depending on the number of primitive operations. - - type Dispatch_Table is record - - -- According to the C++ ABI the components Offset_To_Top and - -- Typeinfo_Ptr are stored just "before" the dispatch table (that is, - -- the Prims_Ptr table), and they are referenced with negative offsets - -- referring to the base of the dispatch table. The _Tag (or the - -- VTable_Ptr in C++ terminology) must point to the base of the virtual - -- table, just after these components, to point to the Prims_Ptr table. - -- For this purpose the expander generates a Prims_Ptr table that has - -- enough space for these additional components, and generates code that - -- displaces the _Tag to point after these components. - - -- Signature : Signature_Kind; - -- Tagged_Kind : Tagged_Kind; - -- Offset_To_Top : Natural; - -- Typeinfo_Ptr : System.Address; - - Prims_Ptr : Address_Array (1 .. 1); - -- The size of the Prims_Ptr array actually depends on the tagged type - -- to which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly, - -- and generates code that displaces the base of the record after the - -- Typeinfo_Ptr component. For this reason the first two components have - -- been commented in the previous declaration. The access to these - -- components is done by means of local functions. - -- - -- To avoid the use of discriminants to define the actual size of the - -- dispatch table, we used to declare the tag as a pointer to a record - -- that contains an arbitrary array of addresses, using Positive as its - -- index. This ensures that there are never range checks when accessing - -- the dispatch table, but it prevents GDB from displaying tagged types - -- properly. A better approach is to declare this record type as holding - -- small number of addresses, and to explicitly suppress checks on it. - -- - -- Note that in both cases, this type is never allocated, and serves - -- only to declare the corresponding access type. - end record; + -- objects: the Dispatch Table and the Type Specific Data record. + + package SSE renames System.Storage_Elements; subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; pragma No_Strict_Aliasing (Cstring_Ptr); - -- We suppress index checks because the declared size in the record below - -- is a dummy size of one (see below). + -- Declarations for the table of interfaces - type Tag_Table is array (Natural range <>) of Tag; - pragma Suppress_Initialization (Tag_Table); - pragma Suppress (Index_Check, On => Tag_Table); + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) return SSE.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. - package SSE renames System.Storage_Elements; + type Interface_Data_Element is record + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : SSE.Storage_Offset; + Offset_To_Top_Func : Offset_To_Top_Function_Ptr; + 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 access to 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 specific data types + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + -- Table of abstract interfaces used to give support to backward interface + -- conversions and also to IW_Membership. + + -- Primitive operation kinds. These values differentiate the kinds of + -- callable entities stored in the dispatch table. Certain kinds may + -- not be used, but are added for completeness. + + type Prim_Op_Kind is + (POK_Function, + POK_Procedure, + POK_Protected_Entry, + POK_Protected_Function, + POK_Protected_Procedure, + POK_Task_Entry, + POK_Task_Function, + POK_Task_Procedure); + + -- Select specific data types + + type Select_Specific_Data_Element is record + Index : Positive; + Kind : Prim_Op_Kind; + end record; + + type Select_Specific_Data_Array is + array (Positive range <>) of Select_Specific_Data_Element; + + type Select_Specific_Data (Nb_Prim : Positive) is record + SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); + -- NOTE: Nb_Prim is the number of non-predefined primitive operations + end record; + + type Select_Specific_Data_Ptr is access all Select_Specific_Data; + -- A table used to store the primitive operation kind and entry index of + -- primitive subprograms of a type that implements a limited interface. + -- The Select Specific Data table resides in the Type Specific Data of a + -- type. This construct is used in the handling of dispatching triggers + -- in select statements. + + type Tag_Table is array (Natural range <>) of Tag; type Type_Specific_Data (Idepth : Natural) is record - -- Inheritance Depth Level: Used to implement the membership test - -- associated with single inheritance of tagged types in constant-time. - -- It also indicates the size of the Tags_Table component. + -- The discriminant Idepth is the Inheritance Depth Level: Used to + -- implement the membership test associated with single inheritance of + -- tagged types in constant-time. It also indicates the size of the + -- Tags_Table component. Access_Level : Natural; -- Accessibility level required to give support to Ada 2005 nested type @@ -232,22 +239,29 @@ private Expanded_Name : Cstring_Ptr; External_Tag : Cstring_Ptr; HT_Link : Tag; - -- Components used to support to the Ada.Tags subprograms in RM 3.9. - -- Note: Expanded_Name is referenced by GDB ??? + -- Components used to support to the Ada.Tags subprograms in RM 3.9 + + -- Note: Expanded_Name is referenced by GDB to determine the actual name + -- of the tagged type. Its requirements are: 1) it must have this exact + -- name, and 2) its contents must point to a C-style Nul terminated + -- string containing its expanded name. GDB has no requirement on a + -- given position inside the record. - Remotely_Callable : Boolean; - -- Used to check ARM E.4 (18) + Transportable : Boolean; + -- Used to check RM E.4(18), set for types that satisfy the requirements + -- for being used in remote calls as actuals for classwide formals or as + -- return values for classwide functions. RC_Offset : SSE.Storage_Offset; -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) - Ifaces_Table_Ptr : System.Address; + Interfaces_Table : Interface_Data_Ptr; -- Pointer to the table of interface tags. It is used to implement the -- membership test associated with interfaces and also for backward -- abstract interface type conversions (Ada 2005:AI-251) - SSD_Ptr : System.Address; + SSD : Select_Specific_Data_Ptr; -- Pointer to a table of records used in dispatching selects. This -- field has a meaningful value for all tagged types that implement -- a limited, protected, synchronized or task interfaces and have @@ -258,66 +272,14 @@ private -- depth level of the tagged type. end record; - -- Declarations for the table of interfaces - - type Interface_Data_Element is record - 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; - - type Interface_Data (Nb_Ifaces : Positive) is record - Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); - end record; - - -- Declaration of tag types - - type Tag is access all Dispatch_Table; - type Tag_Ptr is access Tag; - type Interface_Tag is access all Dispatch_Table; type Type_Specific_Data_Ptr is access all Type_Specific_Data; - No_Tag : constant Tag := null; + -- Declarations for the dispatch table record - type Interface_Data_Ptr is access all Interface_Data; - -- Table of abstract interfaces used to give support to backward interface - -- conversions and also to IW_Membership. - - type Object_Specific_Data (Nb_Prim : Positive); - type Object_Specific_Data_Ptr is access all Object_Specific_Data; - -- Information associated with the secondary dispatch table of tagged-type - -- objects implementing abstract interfaces. - - type Select_Specific_Data (Nb_Prim : Positive); - type Select_Specific_Data_Ptr is access all Select_Specific_Data; - -- A table used to store the primitive operation kind and entry index of - -- primitive subprograms of a type that implements a limited interface. - -- The Select Specific Data table resides in the Type Specific Data of a - -- type. This construct is used in the handling of dispatching triggers - -- in select statements. - - -- Primitive operation kinds. These values differentiate the kinds of - -- callable entities stored in the dispatch table. Certain kinds may - -- not be used, but are added for completeness. - - type Prim_Op_Kind is - (POK_Function, - POK_Procedure, - POK_Protected_Entry, - POK_Protected_Function, - POK_Protected_Procedure, - POK_Task_Entry, - POK_Task_Function, - POK_Task_Procedure); + type Signature_Kind is + (Unknown, + Primary_DT, + Secondary_DT); -- Tagged type kinds with respect to concurrency and limitedness @@ -329,53 +291,66 @@ private TK_Tagged, TK_Task); - type Tagged_Kind_Ptr is access all Tagged_Kind; + type Address_Array is array (Positive range <>) of System.Address; + + type Dispatch_Table_Wrapper (Num_Prims : Natural) is record + Signature : Signature_Kind; + Tag_Kind : Tagged_Kind; + Predef_Prims : System.Address; + -- Pointer to the dispatch table of predefined Ada primitives + + -- According to the C++ ABI the components Offset_To_Top and TSD are + -- stored just "before" the dispatch table, and they are referenced with + -- negative offsets referring to the base of the dispatch table. The + -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base + -- of the virtual table, just after these components, to point to the + -- Prims_Ptr table. + + Offset_To_Top : SSE.Storage_Offset; + TSD : System.Address; + + Prims_Ptr : aliased Address_Array (1 .. Num_Prims); + -- The size of the Prims_Ptr array actually depends on the tagged type + -- to which it applies. For each tagged type, the expander computes the + -- actual array size, allocates the Dispatch_Table record accordingly. + end record; + + subtype Dispatch_Table is Address_Array (1 .. 1); + -- Used by GDB to identify the _tags and traverse the run-time structure + -- associated with tagged types. For compatibility with older versions of + -- gdb, its name must not be changed. + + type Tag is access all Dispatch_Table; + type Interface_Tag is access all Dispatch_Table; + + No_Tag : constant Tag := null; + + -- The expander ensures that Tag objects reference the Prims_Ptr component + -- of the wrapper. + + type Tag_Ptr is access all Tag; + type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; + + -- The following type declaration is used by the compiler when the program + -- is compiled with restriction No_Dispatching_Calls. It is also used with + -- interface types to generate the tag and run-time information associated + -- with them. + + type No_Dispatch_Table_Wrapper is record + NDT_TSD : System.Address; + NDT_Prims_Ptr : Natural; + end record; Default_Prim_Op_Count : constant Positive := 15; - -- Maximum number of predefined primitive operations of a tagged type. + -- Number of predefined ada primitives: Size, Alignment, Read, Write, + -- Input, Output, "=", assignment, deep adjust, deep finalize, async + -- select, conditional select, prim_op kind, task_id, and timed select. - 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. - - DT_Min_Prologue_Size : constant SSE.Storage_Count := + DT_Predef_Prims_Size : constant SSE.Storage_Count := SSE.Storage_Count - (2 * (Standard'Address_Size / + (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the hidden part of the dispatch table used when the program - -- is compiled under restriction No_Dispatching_Calls. It contains the - -- pointer to the TSD record plus a dummy entry whose address is used - -- at run-time as the Tag. - - DT_Prologue_Size : constant SSE.Storage_Count := - 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)); - -- Size of the Signature field of the dispatch table - - DT_Tagged_Kind_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the Tagged_Type_Kind field of the dispatch table + -- Size of the Predef_Prims field of the Dispatch_Table DT_Offset_To_Top_Size : constant SSE.Storage_Count := SSE.Storage_Count @@ -389,28 +364,27 @@ private 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)); - -- 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 - - -- Constants used by the code generated by the frontend to get access - -- to the header of the dispatch table. - - K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size; - K_Offset_To_Top : constant SSE.Storage_Count := - System.Storage_Elements."+" - (K_Typeinfo, DT_Offset_To_Top_Size); - K_Tagged_Kind : constant SSE.Storage_Count := - System.Storage_Elements."+" - (K_Offset_To_Top, DT_Tagged_Kind_Size); - K_Signature : constant SSE.Storage_Count := - System.Storage_Elements."+" - (K_Tagged_Kind, DT_Signature_Size); + use type System.Storage_Elements.Storage_Offset; + + DT_Predef_Prims_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size + + DT_Predef_Prims_Size; + -- Offset from Prims_Ptr to Predef_Prims component + + -- Object Specific Data record of secondary dispatch tables + + type Object_Specific_Data_Array is array (Positive range <>) of Positive; + + type Object_Specific_Data (OSD_Num_Prims : Positive) is record + OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims); + -- Table used in secondary DT to reference their counterpart in the + -- select specific data (in the TSD of the primary DT). This construct + -- is used in the handling of dispatching triggers in select statements. + -- Nb_Prim is the number of non-predefined primitive operations. + end record; + + type Object_Specific_Data_Ptr is access all Object_Specific_Data; -- The following subprogram specifications are placed here instead of -- the package body to see them from the frontend through rtsfind. @@ -419,21 +393,17 @@ private -- Ada 2005 (AI-251): Displace "This" to point to the base address of -- the object (that is, the address of the primary tag of the object). - function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; - -- Given the tag of an object and the tag associated to a type, return - -- true if Obj is in Typ'Class. - function Displace (This : System.Address; T : Tag) return System.Address; -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch -- table of T. + function DT (T : Tag) return Dispatch_Table_Ptr; + -- Return the pointer to the TSD record associated with T + function Get_Entry_Index (T : Tag; Position : Positive) return Positive; -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) -- given a dispatch table T and a position of a primitive operation in T. - function Get_External_Tag (T : Tag) return System.Address; - -- Returns address of a null terminated string containing the external name - function Get_Offset_Index (T : Tag; Position : Positive) return Positive; @@ -450,7 +420,7 @@ private function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; -- Return the Offset of the implicit record controller when the object - -- has controlled components. O otherwise. + -- has controlled components, returns zero if no controlled components. pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset"); -- This procedure is used in s-finimp to compute the deep routines @@ -477,17 +447,12 @@ private -- end Test; function Offset_To_Top - (This : System.Address) return System.Storage_Elements.Storage_Offset; + (This : System.Address) return SSE.Storage_Offset; -- Ada 2005 (AI-251): Returns the current value of the offset_to_top -- component available in 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, - -- retrieve the address of the record containing the Object Specific - -- Data table. - function Parent_Size (Obj : System.Address; T : Tag) return SSE.Storage_Count; @@ -499,14 +464,6 @@ private pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually - procedure Register_Interface_Tag - (T : Tag; - Interface_T : Tag; - Position : Positive); - -- Ada 2005 (AI-251): Used to initialize the table of interfaces - -- implemented by a type. Required to give support to backward interface - -- conversions and also to IW_Membership. - procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag @@ -515,23 +472,12 @@ private -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's -- TSD table indexed by Position. - procedure Set_Interface_Table (T : Tag; Value : System.Address); - -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the - -- pointer to the table of interfaces. - - procedure Set_Offset_Index - (T : Tag; - Position : Positive; - Value : Positive); - -- Ada 2005 (AI-345): Set the offset value of a primitive operation in a - -- secondary dispatch table denoted by T, indexed by Position. - procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; Is_Static : Boolean; - Offset_Value : System.Storage_Elements.Storage_Offset; - Offset_Func : System.Address); + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); -- 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 @@ -541,11 +487,6 @@ private -- distance from "This" to the object component containing the tag of the -- secondary dispatch table. - procedure Set_OSD (T : Tag; Value : System.Address); - -- Ada 2005 (AI-251): 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_Prim_Op_Kind (T : Tag; Position : Positive; @@ -553,94 +494,52 @@ private -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD -- table indexed by Position. - 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); - -- Ada 2005 (AI-345): Given a pointer T to a dispatch Table, stores the - -- pointer to the record containing the Select Specific Data generated by - -- GNAT. - - procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind); - -- Ada 2005 (AI-345): Set the tagged kind of a type in either a primary or - -- a secondary dispatch table denoted by T. - - function SSD (T : Tag) return Select_Specific_Data_Ptr; - -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the - -- address of the record containing the Select Specific Data in T's TSD. - - function TSD (T : Tag) return Type_Specific_Data_Ptr; - -- Given a pointer T to a dispatch Table, retrieves the address of the - -- record containing the Type Specific Data generated by GNAT. - -- Unchecked Conversions - type Addr_Ptr is access System.Address; + Max_Predef_Prims : constant Natural := 16; + -- Compiler should check this constant is OK ??? - type Signature_Values is - array (1 .. DT_Signature_Size) of Signature_Kind; - -- Type used to see the signature as a sequence of Signature_Kind values + subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; - type Signature_Values_Ptr is access all Signature_Values; + type Addr_Ptr is access System.Address; function To_Addr_Ptr is - new Unchecked_Conversion (System.Address, Addr_Ptr); - - function To_Type_Specific_Data_Ptr is - new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); function To_Address is - new Unchecked_Conversion (Tag, System.Address); + new Ada.Unchecked_Conversion (Tag, System.Address); - function To_Interface_Data_Ptr is - new Unchecked_Conversion (System.Address, Interface_Data_Ptr); + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); - function To_Object_Specific_Data_Ptr is - new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - - function To_Select_Specific_Data_Ptr is - new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr); - - function To_Signature_Values is - new Unchecked_Conversion (System.Storage_Elements.Storage_Offset, - Signature_Values); + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); - function To_Signature_Values_Ptr is - new Unchecked_Conversion (System.Address, - Signature_Values_Ptr); + function To_Object_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - function To_Tag is - new Unchecked_Conversion (System.Address, Tag); + function To_Predef_Prims_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr); function To_Tag_Ptr is - new Unchecked_Conversion (System.Address, Tag_Ptr); + new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); - function To_Tagged_Kind_Ptr is - new Unchecked_Conversion (System.Address, Tagged_Kind_Ptr); + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - -- Primitive dispatching operations are always inlined, to facilitate - -- use in a minimal/no run-time environment for high integrity use. + -- Primitive dispatching operations are always inlined, to facilitate use + -- in a minimal/no run-time environment for high integrity use. - pragma Inline_Always (CW_Membership); pragma Inline_Always (Displace); pragma Inline_Always (IW_Membership); pragma Inline_Always (Get_Entry_Index); pragma Inline_Always (Get_Offset_Index); pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_Tagged_Kind); - pragma Inline_Always (OSD); - pragma Inline_Always (Register_Interface_Tag); pragma Inline_Always (Register_Tag); pragma Inline_Always (Set_Entry_Index); - pragma Inline_Always (Set_Interface_Table); - pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); pragma Inline_Always (Set_Prim_Op_Kind); - pragma Inline_Always (Set_Signature); - pragma Inline_Always (Set_OSD); - pragma Inline_Always (Set_SSD); - pragma Inline_Always (Set_Tagged_Kind); - pragma Inline_Always (SSD); - pragma Inline_Always (TSD); end Ada.Tags; diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 8756136a15a..54bf33fb02f 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2007, 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- -- @@ -24,16 +24,15 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; with Einfo; use Einfo; +with Elists; use Elists; with Exp_Util; use Exp_Util; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; -with Sinfo; use Sinfo; +with Stand; use Stand; with Snames; use Snames; with Tbuild; use Tbuild; -with Uintp; use Uintp; package body Exp_Atag is @@ -41,33 +40,107 @@ package body Exp_Atag is -- Local Subprograms -- ----------------------- - function Build_Predefined_DT + function Build_DT (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; - -- Build code that displaces the Tag to reference the dispatch table - -- containing the predefined primitives. + -- Build code that displaces the Tag to reference the base of the wrapper + -- record -- - -- Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size); - pragma Inline (Build_Predefined_DT); - - function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id; - -- Build code that gives access to the distance from the tag to the - -- Typeinfo component of the dispatch table. - -- - -- Generates: DT_Typeinfo_Ptr_Size - pragma Inline (Build_Typeinfo_Offset); + -- Generates: + -- To_Dispatch_Table_Ptr + -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position); function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; -- Build code that retrieves the address of the record containing the Type -- Specific Data generated by GNAT. -- -- Generate: To_Type_Specific_Data_Ptr - -- (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all); - pragma Inline (Build_TSD); + -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); + + function Build_Predef_Prims + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that retrieves the address of the dispatch table containing + -- the predefined Ada primitives: + -- + -- Generate: To_Predef_Prims_Table_Ptr + -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); + + ------------------------------------------------ + -- Build_Common_Dispatching_Select_Statements -- + ------------------------------------------------ - function RTE_Tag_Node return Entity_Id; - -- Returns the entity associated with Ada.Tags.Tag - pragma Inline (RTE_Tag_Node); + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + DT_Ptr : Entity_Id; + Stmts : List_Id) + is + begin + -- Generate: + -- C := get_prim_op_kind (tag! (<type>VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + -- Generate: + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + + -- where F is the out parameter capturing the status of a potential + -- entry call. + + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_True, Loc)), + Make_Return_Statement (Loc)))); + end Build_Common_Dispatching_Select_Statements; ------------------------- -- Build_CW_Membership -- @@ -103,27 +176,42 @@ package body Exp_Atag is begin return Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ge (Loc, - Left_Opnd => Build_Pos, - Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Obj_Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Tags_Table), Loc)), - Expressions => - New_List (Build_Pos)), - - Right_Opnd => Typ_Tag_Node)); + Left_Opnd => + Make_Op_Ge (Loc, + Left_Opnd => Build_Pos, + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Build_TSD (Loc, Obj_Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Tags_Table), Loc)), + Expressions => + New_List (Build_Pos)), + + Right_Opnd => Typ_Tag_Node)); end Build_CW_Membership; + -------------- + -- Build_DT -- + -------------- + + function Build_DT + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id is + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_DT), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Tag_Node))); + end Build_DT; + ---------------------------- -- Build_Get_Access_Level -- ---------------------------- @@ -146,125 +234,18 @@ package body Exp_Atag is ------------------------------------------ function Build_Get_Predefined_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id) return Node_Id - is - begin - return - Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Build_Predefined_DT (Loc, Tag_Node), - - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - - Expressions => - New_List (Position_Node)); - end Build_Get_Predefined_Prim_Op_Address; - - ------------------------------- - -- Build_Get_Prim_Op_Address -- - ------------------------------- - - function Build_Get_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id) return Node_Id + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint) return Node_Id is begin return Make_Indexed_Component (Loc, Prefix => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE_Tag_Node, Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - - Expressions => New_List (Position_Node)); - end Build_Get_Prim_Op_Address; - - ------------------------- - -- Build_Get_RC_Offset -- - ------------------------- - - function Build_Get_RC_Offset - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id - is - begin - return - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_RC_Offset), Loc)); - end Build_Get_RC_Offset; - - --------------------------------- - -- Build_Get_Remotely_Callable -- - --------------------------------- - - function Build_Get_Remotely_Callable - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id - is - begin - return - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Remotely_Callable), Loc)); - end Build_Get_Remotely_Callable; - - ------------------------------------ - -- Build_Inherit_Predefined_Prims -- - ------------------------------------ - - function Build_Inherit_Predefined_Prims - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id) return Node_Id - is - begin - return - Make_Assignment_Statement (Loc, - Name => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Build_Predefined_DT (Loc, New_Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))), - - Expression => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Build_Predefined_DT (Loc, Old_Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - Discrete_Range => - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => - New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc)))); - - end Build_Inherit_Predefined_Prims; + Build_Predef_Prims (Loc, Tag_Node), + Expressions => + New_List (Make_Integer_Literal (Loc, Position))); + end Build_Get_Predefined_Prim_Op_Address; ------------------------- -- Build_Inherit_Prims -- @@ -284,7 +265,7 @@ package body Exp_Atag is Prefix => Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node), + Build_DT (Loc, New_Tag_Node), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Prims_Ptr), Loc)), @@ -298,7 +279,7 @@ package body Exp_Atag is Prefix => Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node), + Build_DT (Loc, Old_Tag_Node), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Prims_Ptr), Loc)), @@ -308,281 +289,139 @@ package body Exp_Atag is High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); end Build_Inherit_Prims; - ------------------- - -- Build_New_TSD -- - ------------------- + ------------------------------- + -- Build_Get_Prim_Op_Address -- + ------------------------------- - function Build_New_TSD - (Loc : Source_Ptr; - New_Tag_Node : Node_Id) return List_Id + function Build_Get_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint) return Node_Id is begin - return New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Tags_Table), Loc)), - Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))), - - Expression => New_Tag_Node)); - end Build_New_TSD; + pragma Assert + (Position <= DT_Entry_Count (First_Tag_Component (Typ))); - ----------------------- - -- Build_Inherit_TSD -- - ----------------------- - - function Build_Inherit_TSD - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id; - I_Depth : Nat; - Parent_Num_Ifaces : Nat) return Node_Id - is - function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id; - -- Generates: Interface_Data_Ptr! (TSD (Tag).Ifaces_Table_Ptr).all + -- At the end of the Access_Disp_Table list we have the type + -- declaration required to convert the tag into a pointer to + -- the prims_ptr table (see Freeze_Record_Type). - ---------------------------- - -- Build_Iface_Table_Ptr -- - ---------------------------- - - function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is - begin - return - Unchecked_Convert_To (RTE (RE_Interface_Data_Ptr), - Make_Selected_Component (Loc, - Prefix => Tag_Node, - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc))); - end Build_Iface_Table_Ptr; - - -- Local variables - - L : constant List_Id := New_List; - Old_TSD : Node_Id; - New_TSD : Node_Id; + return + Make_Indexed_Component (Loc, + Prefix => + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node), + Expressions => New_List (Make_Integer_Literal (Loc, Position))); + end Build_Get_Prim_Op_Address; - -- Start of processing for Build_Inherit_TSD + ----------------------------- + -- Build_Get_Transportable -- + ----------------------------- + function Build_Get_Transportable + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id + is begin - Old_TSD := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), - Object_Definition => - New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc), - Expression => - Build_TSD (Loc, Duplicate_Subexpr (Old_Tag_Node))); - - New_TSD := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), - Object_Definition => - New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc), - Expression => - Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node))); - - Append_List_To (L, New_List ( + return + Make_Selected_Component (Loc, + Prefix => Build_TSD (Loc, Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Transportable), Loc)); + end Build_Get_Transportable; - -- Copy the table of ancestors of the parent - -- TSD (New_Tag).Tags_Table (1 .. I_Depth) := - -- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1); + ------------------------------------ + -- Build_Inherit_Predefined_Prims -- + ------------------------------------ - Make_Assignment_Statement (Loc, - Name => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Reference_To (Defining_Identifier (New_TSD), Loc)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Tags_Table), Loc)), - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - Make_Integer_Literal (Loc, I_Depth))), - - Expression => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Reference_To (Defining_Identifier (Old_TSD), Loc)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Tags_Table), Loc)), - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_0), - Make_Integer_Literal (Loc, I_Depth - 1)))))); - - -- Copy the table of interfaces of the parent - - -- if not System."=" (TSD (Old_Tag).Ifaces_Table_Ptr, - -- System.Null_Address) - -- then - -- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):= - -- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces); - -- end if; - - -- The table of interfaces is not available under certified run-time - - if RTE_Record_Component_Available (RE_Nb_Ifaces) then - Append_To (L, - Make_If_Statement (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Reference_To - (Defining_Identifier (Old_TSD), Loc)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Ifaces_Table_Ptr), - Loc)), - Right_Opnd => - New_Reference_To (RTE (RE_Null_Address), Loc))), - - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Build_Iface_Table_Ptr - (New_Reference_To - (Defining_Identifier (New_TSD), Loc)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Ifaces_Table), Loc)), - - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - Make_Integer_Literal (Loc, Parent_Num_Ifaces))), - - Expression => - Make_Slice (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Build_Iface_Table_Ptr - (New_Reference_To - (Defining_Identifier (Old_TSD), Loc)), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Ifaces_Table), Loc)), - - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - Make_Integer_Literal (Loc, Parent_Num_Ifaces))))))); - end if; - - -- TSD (New_Tag).Tags_Table (0) := New_Tag; - - Append_To (L, - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => + function Build_Inherit_Predefined_Prims + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), Make_Selected_Component (Loc, Prefix => - Make_Explicit_Dereference (Loc, - New_Reference_To - (Defining_Identifier (New_TSD), Loc)), + Build_DT (Loc, New_Tag_Node), Selector_Name => New_Reference_To - (RTE_Record_Component (RE_Tags_Table), Loc)), - Expressions => - New_List (Make_Integer_Literal (Loc, Uint_0))), - - Expression => New_Tag_Node)); - - return - Make_Block_Statement (Loc, - Declarations => New_List ( - Old_TSD, - New_TSD), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, L)); + (RTE_Record_Component (RE_Predef_Prims), Loc)))), + Discrete_Range => Make_Range (Loc, + Make_Integer_Literal (Loc, Uint_1), + New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))), - end Build_Inherit_TSD; + Expression => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Selected_Component (Loc, + Prefix => + Build_DT (Loc, Old_Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Predef_Prims), Loc)))), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc)))); + end Build_Inherit_Predefined_Prims; - ------------------------- - -- Build_Predefined_DT -- - ------------------------- + ------------------------ + -- Build_Predef_Prims -- + ------------------------ - function Build_Predefined_DT + function Build_Predef_Prims (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is begin return - Unchecked_Convert_To (RTE_Tag_Node, - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Subtract, - Prefix => - New_Reference_To (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, - Chars => Name_Op_Subtract)), - - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), Tag_Node), - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))); - end Build_Predefined_DT; - - ---------------------------- - -- Build_Set_External_Tag -- - ---------------------------- - - function Build_Set_External_Tag - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Value_Node : Node_Id) return Node_Id - is - begin - return - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RO_TA_External_Tag), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node)); - end Build_Set_External_Tag; + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), + Loc)))))); + end Build_Predef_Prims; ------------------------------------------ -- Build_Set_Predefined_Prim_Op_Address -- ------------------------------------------ function Build_Set_Predefined_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id; - Address_Node : Node_Id) return Node_Id + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id is begin return Make_Assignment_Statement (Loc, - Name => Build_Get_Predefined_Prim_Op_Address - (Loc, Tag_Node, Position_Node), + Name => Build_Get_Predefined_Prim_Op_Address (Loc, + Tag_Node, Position), Expression => Address_Node); end Build_Set_Predefined_Prim_Op_Address; @@ -591,52 +430,20 @@ package body Exp_Atag is ------------------------------- function Build_Set_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id; - Address_Node : Node_Id) return Node_Id + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id is begin return - Make_Assignment_Statement (Loc, - Name => Build_Get_Prim_Op_Address (Loc, - Tag_Node, Position_Node), - Expression => Address_Node); + Make_Assignment_Statement (Loc, + Name => Build_Get_Prim_Op_Address + (Loc, Typ, Tag_Node, Position), + Expression => Address_Node); end Build_Set_Prim_Op_Address; - ------------------- - -- Build_Set_TSD -- - ------------------- - - function Build_Set_TSD - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Value_Node : Node_Id) return Node_Id - is - begin - return - Make_Assignment_Statement (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Subtract, - Prefix => - New_Reference_To - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, - Chars => Name_Op_Subtract)), - - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), Tag_Node), - Build_Typeinfo_Offset (Loc))))), - - Expression => Value_Node); - end Build_Set_TSD; - --------------- -- Build_TSD -- --------------- @@ -647,42 +454,21 @@ package body Exp_Atag is Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), Make_Explicit_Dereference (Loc, Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Subtract, - Prefix => - New_Reference_To - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, - Chars => Name_Op_Subtract)), - - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), Tag_Node), - Build_Typeinfo_Offset (Loc)))))); + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + New_Reference_To + (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); end Build_TSD; - --------------------------- - -- Build_Typeinfo_Offset -- - --------------------------- - - function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id is - begin - return New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc); - end Build_Typeinfo_Offset; - - --------------- - -- Tag_Node -- - --------------- - - function RTE_Tag_Node return Entity_Id is - E : constant Entity_Id := RTE (RE_Tag); - begin - if Atree.Present (Full_View (E)) then - return Full_View (E); - else - return E; - end if; - end RTE_Tag_Node; end Exp_Atag; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 8eb456b0612..6b0fce75c9e 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2007, 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- -- @@ -28,18 +28,24 @@ -- subprograms of package Ada.Tags with Types; use Types; +with Uintp; use Uintp; package Exp_Atag is + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + DT_Ptr : Entity_Id; + Stmts : List_Id); + -- Ada 2005 (AI-345): Generate statements that are common between timed, + -- asynchronous, and conditional select expansion. + function Build_CW_Membership (Loc : Source_Ptr; Obj_Tag_Node : Node_Id; Typ_Tag_Node : Node_Id) return Node_Id; - -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each - -- dispatch table contains a reference to a table of ancestors (stored - -- in the first part of the Tags_Table) and a count of the level of - -- inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table - -- of ancestors that are contained in the dispatch table referenced by + -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT + -- has a table of ancestors and its inheritance level (Idepth). Obj is in + -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by -- Obj'Tag. Knowing the level of inheritance of both types, this can be -- computed in constant time by the formula: -- @@ -54,9 +60,9 @@ package Exp_Atag is -- Generates: TSD (Tag).Access_Level function Build_Get_Predefined_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint) return Node_Id; -- Given a pointer to a dispatch table (T) and a position in the DT, build -- code that gets the address of the predefined virtual function stored in -- it (used for dispatching calls). @@ -64,29 +70,22 @@ package Exp_Atag is -- Generates: Predefined_DT (Tag).D (Position); function Build_Get_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint) return Node_Id; -- Build code that retrieves the address of the virtual function stored in -- a given position of the dispatch table (used for dispatching calls). -- -- Generates: To_Tag (Tag).D (Position); - function Build_Get_RC_Offset - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id; - -- Build code that retrieves the Offset of the implicit record controller - -- when the object has controlled components. O otherwise. - -- - -- Generates: TSD (T).RC_Offset; - - function Build_Get_Remotely_Callable - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id; - -- Build code that retrieves the value previously saved by Set_Remotely - -- Callable + function Build_Get_Transportable + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that retrieves the value of the Transportable flag for + -- the given Tag. -- - -- Generates: TSD (Tag).Remotely_Callable + -- Generates: TSD (Tag).Transportable; function Build_Inherit_Predefined_Prims (Loc : Source_Ptr; @@ -96,6 +95,8 @@ package Exp_Atag is -- -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Predefined_DT (Old_T).D (All_Predefined_Prims); + -- + -- Required to build the dispatch tables with the 3.4 backend. function Build_Inherit_Prims (Loc : Source_Ptr; @@ -103,80 +104,39 @@ package Exp_Atag is New_Tag_Node : Node_Id; Num_Prims : Nat) return Node_Id; -- Build code that inherits Num_Prims user-defined primitives from the - -- dispatch table of the parent type. + -- dispatch table of the parent type. It is used to copy the dispatch + -- table of the parent in case of derivations of CPP_Class types. -- -- Generates: -- New_Tag.Prims_Ptr (1 .. Num_Prims) := -- Old_Tag.Prims_Ptr (1 .. Num_Prims); - function Build_Inherit_TSD - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id; - I_Depth : Nat; - Parent_Num_Ifaces : Nat) return Node_Id; - -- Generates code that initializes the TSD of a type knowing the tag, - -- inheritance depth, and number of interface types of the parent type. - -- - -- Generates: - -- -- Copy the table of ancestors of the parent - -- - -- TSD (New_Tag).Tags_Table (1 .. I_Depth) := - -- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1); - -- - -- -- Copy the table of interfaces of the parent - -- - -- if TSD (Old_Tag).Ifaces_Table_Ptr /= null then - -- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):= - -- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces); - -- end if; - -- - -- TSD (New_Tag).Tags_Table (0) := New_Tag; - - function Build_New_TSD - (Loc : Source_Ptr; - New_Tag_Node : Node_Id) return List_Id; - -- Build code that initializes the TSD of a root type. - -- Generates: TSD (New_Tag).Tags_Table (0) := New_Tag; - - function Build_Set_External_Tag - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Value_Node : Node_Id) return Node_Id; - -- Build code that saves the address of the string containing the external - -- tag in the dispatch table. - -- - -- Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value); - function Build_Set_Predefined_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id; - Address_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id; -- Build code that saves the address of a virtual function in a given -- Position of the portion of the dispatch table associated with the - -- predefined primitives of Tag (used for overriding). + -- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry + -- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for: + -- 1) Filling the dispatch table of CPP_Class types. + -- 2) Late overriding (see Check_Dispatching_Operation). -- -- Generates: Predefined_DT (Tag).D (Position) := Value function Build_Set_Prim_Op_Address - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Position_Node : Node_Id; - Address_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id; -- Build code that saves the address of a virtual function in a given - -- Position of the dispatch table associated with the Tag (used for - -- overriding). + -- Position of the dispatch table associated with the Tag. Called from + -- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for: + -- 1) Filling the dispatch table of CPP_Class types. + -- 2) Late overriding (see Check_Dispatching_Operation). -- -- Generates: Tag.D (Position) := Value - function Build_Set_TSD - (Loc : Source_Ptr; - Tag_Node : Node_Id; - Value_Node : Node_Id) return Node_Id; - -- Build code that saves the address of the record containing the Type - -- Specific Data generated by GNAT. - -- - -- Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value - end Exp_Atag; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index f8dc4caa2ef..1c079893d5d 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -37,6 +37,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; +with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; @@ -46,309 +47,26 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Disp is - -------------------------------- - -- Select_Expansion_Utilities -- - -------------------------------- - - -- The following package contains helper routines used in the expansion of - -- dispatching asynchronous, conditional and timed selects. - - package Select_Expansion_Utilities is - procedure Build_B - (Loc : Source_Ptr; - Params : List_Id); - -- Generate: - -- B : out Communication_Block - - procedure Build_C - (Loc : Source_Ptr; - Params : List_Id); - -- Generate: - -- C : out Prim_Op_Kind - - procedure Build_Common_Dispatching_Select_Statements - (Loc : Source_Ptr; - Typ : Entity_Id; - DT_Ptr : Entity_Id; - Stmts : List_Id); - -- Ada 2005 (AI-345): Generate statements that are common between - -- asynchronous, conditional and timed select expansion. - - procedure Build_F - (Loc : Source_Ptr; - Params : List_Id); - -- Generate: - -- F : out Boolean - - procedure Build_P - (Loc : Source_Ptr; - Params : List_Id); - -- Generate: - -- P : Address - - procedure Build_S - (Loc : Source_Ptr; - Params : List_Id); - -- Generate: - -- S : Integer - - procedure Build_T - (Loc : Source_Ptr; - Typ : Entity_Id; - Params : List_Id); - -- Generate: - -- T : in out Typ - end Select_Expansion_Utilities; - - package body Select_Expansion_Utilities is - - ------------- - -- Build_B -- - ------------- - - procedure Build_B - (Loc : Source_Ptr; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uB), - Parameter_Type => - New_Reference_To (RTE (RE_Communication_Block), Loc), - Out_Present => True)); - end Build_B; - - ------------- - -- Build_C -- - ------------- - - procedure Build_C - (Loc : Source_Ptr; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uC), - Parameter_Type => - New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), - Out_Present => True)); - end Build_C; - - ------------------------------------------------ - -- Build_Common_Dispatching_Select_Statements -- - ------------------------------------------------ - - procedure Build_Common_Dispatching_Select_Statements - (Loc : Source_Ptr; - Typ : Entity_Id; - DT_Ptr : Entity_Id; - Stmts : List_Id) - is - begin - -- Generate: - -- C := get_prim_op_kind (tag! (<type>VP), S); - - -- where C is the out parameter capturing the call kind and S is the - -- dispatch table slot number. - - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uC), - Expression => - Make_DT_Access_Action (Typ, - Action => - Get_Prim_Op_Kind, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))); - - -- Generate: - - -- if C = POK_Procedure - -- or else C = POK_Protected_Procedure - -- or else C = POK_Task_Procedure; - -- then - -- F := True; - -- return; - - -- where F is the out parameter capturing the status of a potential - -- entry call. - - Append_To (Stmts, - Make_If_Statement (Loc, - - Condition => - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Identifier (Loc, Name_uC), - Right_Opnd => - New_Reference_To (RTE (RE_POK_Procedure), Loc)), - Right_Opnd => - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Identifier (Loc, Name_uC), - Right_Opnd => - New_Reference_To (RTE ( - RE_POK_Protected_Procedure), Loc)), - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Identifier (Loc, Name_uC), - Right_Opnd => - New_Reference_To (RTE ( - RE_POK_Task_Procedure), Loc)))), - - Then_Statements => - New_List ( - Make_Assignment_Statement (Loc, - Name => Make_Identifier (Loc, Name_uF), - Expression => New_Reference_To (Standard_True, Loc)), - - Make_Return_Statement (Loc)))); - end Build_Common_Dispatching_Select_Statements; - - ------------- - -- Build_F -- - ------------- - - procedure Build_F - (Loc : Source_Ptr; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Reference_To (Standard_Boolean, Loc), - Out_Present => True)); - end Build_F; - - ------------- - -- Build_P -- - ------------- - - procedure Build_P - (Loc : Source_Ptr; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uP), - Parameter_Type => - New_Reference_To (RTE (RE_Address), Loc))); - end Build_P; - - ------------- - -- Build_S -- - ------------- - - procedure Build_S - (Loc : Source_Ptr; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uS), - Parameter_Type => - New_Reference_To (Standard_Integer, Loc))); - end Build_S; - - ------------- - -- Build_T -- - ------------- - - procedure Build_T - (Loc : Source_Ptr; - Typ : Entity_Id; - Params : List_Id) - is - begin - Append_To (Params, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Reference_To (Typ, Loc), - In_Present => True, - Out_Present => True)); - end Build_T; - end Select_Expansion_Utilities; - - package SEU renames Select_Expansion_Utilities; - - Ada_Actions : constant array (DT_Access_Action) of RE_Id := - (IW_Membership => RE_IW_Membership, - Get_Entry_Index => RE_Get_Entry_Index, - Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, - Get_Tagged_Kind => RE_Get_Tagged_Kind, - Register_Interface_Tag => RE_Register_Interface_Tag, - Register_Tag => RE_Register_Tag, - Set_Entry_Index => RE_Set_Entry_Index, - Set_Offset_Index => RE_Set_Offset_Index, - Set_OSD => RE_Set_OSD, - Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, - Set_Signature => RE_Set_Signature, - Set_SSD => RE_Set_SSD, - Set_Tagged_Kind => RE_Set_Tagged_Kind); - - Action_Is_Proc : constant array (DT_Access_Action) of Boolean := - (IW_Membership => False, - Get_Entry_Index => False, - Get_Prim_Op_Kind => False, - Get_Tagged_Kind => False, - Register_Interface_Tag => True, - Register_Tag => True, - Set_Entry_Index => True, - Set_Offset_Index => True, - Set_OSD => True, - Set_Prim_Op_Kind => True, - Set_Signature => True, - Set_SSD => True, - Set_Tagged_Kind => True); - - Action_Nb_Arg : constant array (DT_Access_Action) of Int := - (IW_Membership => 2, - Get_Entry_Index => 2, - Get_Prim_Op_Kind => 2, - Get_Tagged_Kind => 1, - Register_Interface_Tag => 3, - Register_Tag => 1, - Set_Entry_Index => 3, - Set_Offset_Index => 3, - Set_OSD => 2, - Set_Prim_Op_Kind => 3, - Set_Signature => 2, - Set_SSD => 2, - Set_Tagged_Kind => 2); + ----------------------- + -- Local Subprograms -- + ----------------------- function Default_Prim_Op_Position (E : Entity_Id) return Uint; -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table @@ -485,6 +203,11 @@ package body Exp_Disp is -- Start of processing for Expand_Dispatching_Call begin + if No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Call_Node); + return; + end if; + -- Expand_Dispatching_Call is called directly from the semantics, -- so we need a check to see whether expansion is active before -- proceeding. In addition, there is no need to expand the call @@ -527,11 +250,16 @@ package body Exp_Disp is then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); + -- Class_Wide_Type is applied to the expressions used to initialize + -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since + -- there are cases where the controlling type is resolved to a specific + -- type (such as for designated types of arguments such as CW'Access). + elsif Is_Access_Type (Etype (Ctrl_Arg)) then - CW_Typ := Designated_Type (Etype (Ctrl_Arg)); + CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); else - CW_Typ := Etype (Ctrl_Arg); + CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg)); end if; Typ := Root_Type (CW_Typ); @@ -665,7 +393,7 @@ package body Exp_Disp is declare Old_Formal : Entity_Id := First_Formal (Subp); New_Formal : Entity_Id; - Extra : Entity_Id; + Extra : Entity_Id := Empty; begin if Present (Old_Formal) then @@ -707,27 +435,16 @@ package body Exp_Disp is Set_Next_Entity (New_Formal, Empty); Set_Last_Entity (Subp_Typ, Extra); + end if; - -- Copy extra formals - - New_Formal := First_Entity (Subp_Typ); - while Present (New_Formal) loop - if Present (Extra_Constrained (New_Formal)) then - Set_Extra_Formal (Extra, - New_Copy (Extra_Constrained (New_Formal))); - Extra := Extra_Formal (Extra); - Set_Extra_Constrained (New_Formal, Extra); - - elsif Present (Extra_Accessibility (New_Formal)) then - Set_Extra_Formal (Extra, - New_Copy (Extra_Accessibility (New_Formal))); - Extra := Extra_Formal (Extra); - Set_Extra_Accessibility (New_Formal, Extra); - end if; + -- Now that the explicit formals have been duplicated, any extra + -- formals needed by the subprogram must be created. - Next_Formal (New_Formal); - end loop; + if Present (Extra) then + Set_Extra_Formal (Extra, Empty); end if; + + Create_Extra_Formals (Subp_Typ); end; Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); @@ -782,8 +499,7 @@ package body Exp_Disp is Unchecked_Convert_To (Subp_Ptr_Typ, Build_Get_Predefined_Prim_Op_Address (Loc, Tag_Node => Controlling_Tag, - Position_Node => Make_Integer_Literal (Loc, - DT_Position (Subp)))); + Position => DT_Position (Subp))); -- Handle dispatching calls to user-defined primitives @@ -791,70 +507,43 @@ package body Exp_Disp is New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, Build_Get_Prim_Op_Address (Loc, - Tag_Node => Controlling_Tag, - Position_Node => Make_Integer_Literal (Loc, - DT_Position (Subp)))); + Typ => Find_Dispatching_Type (Subp), + Tag_Node => Controlling_Tag, + Position => DT_Position (Subp))); end if; if Nkind (Call_Node) = N_Function_Call then - -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface - -- just requires the comparison of the tags. + New_Call := + Make_Function_Call (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); - if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type - and then Is_Interface (Etype (Ctrl_Arg)) - and then Subp = Eq_Prim_Op - then - Param := First_Actual (Call_Node); + -- If this is a dispatching "=", we must first compare the tags so + -- we generate: x.tag = y.tag and then x = y + if Subp = Eq_Prim_Op then + Param := First_Actual (Call_Node); New_Call := - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Value (Param), - Selector_Name => - New_Reference_To (First_Tag_Component (Typ), Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Typ, - New_Value (Next_Actual (Param))), - Selector_Name => - New_Reference_To (First_Tag_Component (Typ), Loc))); + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc)), - else - New_Call := - Make_Function_Call (Loc, - Name => New_Call_Name, - Parameter_Associations => New_Params); - - -- If this is a dispatching "=", we must first compare the tags so - -- we generate: x.tag = y.tag and then x = y - - if Subp = Eq_Prim_Op then - Param := First_Actual (Call_Node); - New_Call := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Value (Param), - Selector_Name => - New_Reference_To (First_Tag_Component (Typ), - Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Typ, - New_Value (Next_Actual (Param))), - Selector_Name => - New_Reference_To (First_Tag_Component (Typ), - Loc))), - Right_Opnd => New_Call); - end if; + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc))), + Right_Opnd => New_Call); end if; else @@ -865,7 +554,11 @@ package body Exp_Disp is end if; Rewrite (Call_Node, New_Call); - Analyze_And_Resolve (Call_Node, Call_Typ); + + -- Suppress all checks during the analysis of the expanded code + -- to avoid the generation of spureous warnings under ZFP run-time. + + Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); end Expand_Dispatching_Call; --------------------------------- @@ -885,10 +578,9 @@ package body Exp_Disp is Iface_Typ : Entity_Id := Etype (N); Iface_Tag : Entity_Id; New_Itype : Entity_Id; + Stats : List_Id; begin - pragma Assert (Nkind (Operand) /= N_Attribute_Reference); - -- Ada 2005 (AI-345): Handle synchronized interface type derivations if Is_Concurrent_Type (Operand_Typ) then @@ -905,13 +597,22 @@ package body Exp_Disp is -- explicitly in the source code. Example: I'Class (Obj) if Is_Class_Wide_Type (Iface_Typ) then - Iface_Typ := Etype (Iface_Typ); + Iface_Typ := Root_Type (Iface_Typ); end if; pragma Assert (not Is_Static or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); + if VM_Target /= No_VM then + + -- For VM, just do a conversion ??? + + Rewrite (N, Unchecked_Convert_To (Etype (N), N)); + Analyze (N); + return; + end if; + if not Is_Static then -- Give error if configurable run time and Displace not available @@ -921,9 +622,9 @@ package body Exp_Disp is return; end if; - -- Handle conversion of access to class-wide interface types. The - -- target can be an access to object or an access to another class - -- wide interfac (see -1- and -2- in the following example): + -- Handle conversion of access-to-class-wide interface types. Target + -- can be an access to an object or an access to another class-wide + -- interface (see -1- and -2- in the following example): -- type Iface1_Ref is access all Iface1'Class; -- type Iface2_Ref is access all Iface1'Class; @@ -934,9 +635,7 @@ package body Exp_Disp is if Is_Access_Type (Operand_Typ) then pragma Assert - (Is_Class_Wide_Type (Directly_Designated_Type (Operand_Typ)) - and then - Is_Interface (Directly_Designated_Type (Operand_Typ))); + (Is_Interface (Directly_Designated_Type (Operand_Typ))); Rewrite (N, Unchecked_Convert_To (Etype (N), @@ -1019,7 +718,6 @@ package body Exp_Disp is -- end Func; Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F')); - Set_Is_Internal (Fent); declare Desig_Typ : Entity_Id; @@ -1037,6 +735,36 @@ package body Exp_Disp is Set_Directly_Designated_Type (New_Itype, Desig_Typ); end; + Stats := New_List ( + Make_Return_Statement (Loc, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (New_Itype, + Make_Identifier (Loc, Name_uO)), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address)))); + + -- If the type is null-excluding, no need for the null branch. + -- Otherwise we need to check for it and return null. + + if not Can_Never_Be_Null (Etype (N)) then + Stats := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uO), + Right_Opnd => New_Reference_To + (RTE (RE_Null_Address), Loc)), + + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Make_Null (Loc))), + Else_Statements => Stats)); + end if; + Func := Make_Subprogram_Body (Loc, Specification => @@ -1056,36 +784,16 @@ package body Exp_Disp is Declarations => Empty_List, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Make_Identifier (Loc, Name_uO), - Right_Opnd => New_Reference_To - (RTE (RE_Null_Address), Loc)), - - Then_Statements => New_List ( - Make_Return_Statement (Loc, - Make_Null (Loc))), - - Else_Statements => New_List ( - Make_Return_Statement (Loc, - Unchecked_Convert_To (Etype (N), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (New_Itype, - Make_Identifier (Loc, Name_uO)), - Selector_Name => - New_Occurrence_Of (Iface_Tag, Loc)), - Attribute_Name => Name_Address)))))))); + Make_Handled_Sequence_Of_Statements (Loc, Stats)); - -- Place function body before the expression containing - -- the conversion + -- Place function body before the expression containing the + -- conversion. We suppress all checks because the body of the + -- internally generated function already takes care of the case + -- in which the actual is null; therefore there is no need to + -- double check that the pointer is not null when the program + -- executes the alternative that performs the type conversion). - Insert_Action (N, Func); - Analyze (Func); + Insert_Action (N, Func, Suppress => All_Checks); if Is_Access_Type (Etype (Expression (N))) then @@ -1155,14 +863,13 @@ package body Exp_Disp is Subp := Entity (Name (Call_Node)); end if; + -- Ada 2005 (AI-251): Look for interface type formals to force "this" + -- displacement + Formal := First_Formal (Subp); Actual := First_Actual (Call_Node); while Present (Formal) loop - - -- Ada 2005 (AI-251): Conversion to interface to force "this" - -- displacement. - - Formal_Typ := Etype (Etype (Formal)); + Formal_Typ := Etype (Formal); if Ekind (Formal_Typ) = E_Record_Type_With_Private then Formal_Typ := Full_View (Formal_Typ); @@ -1178,49 +885,42 @@ package body Exp_Disp is Actual_DDT := Directly_Designated_Type (Actual_Typ); end if; - if Is_Interface (Formal_Typ) then - + if Is_Interface (Formal_Typ) + and then Is_Class_Wide_Type (Formal_Typ) + then -- No need to displace the pointer if the type of the actual - -- is class-wide of the formal-type interface; in this case the - -- displacement of the pointer was already done at the point of - -- the call to the enclosing subprogram. This case corresponds - -- with the call to P (Obj) in the following example: - - -- type I is interface; - -- procedure P (X : I) is abstract; - - -- procedure General_Op (Obj : I'Class) is - -- begin - -- P (Obj); - -- end General_Op; + -- coindices with the type of the formal. - if Is_Class_Wide_Type (Actual_Typ) - and then Etype (Actual_Typ) = Formal_Typ - then + if Actual_Typ = Formal_Typ then null; - -- No need to displace the pointer if the type of the actual is a - -- derivation of the formal-type interface because in this case - -- the interface primitives are located in the primary dispatch - -- table. + -- No need to displace the pointer if the interface type is + -- a parent of the type of the actual because in this case the + -- interface primitives are located in the primary dispatch table. elsif Is_Parent (Formal_Typ, Actual_Typ) then null; + -- Implicit conversion to the class-wide formal type to force + -- the displacement of the pointer. + else Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); - Rewrite (Actual, Conversion); + Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_Typ); end if; - -- Anonymous access type + -- Access to class-wide interface type elsif Is_Access_Type (Formal_Typ) - and then Is_Interface (Etype (Formal_DDT)) + and then Is_Interface (Formal_DDT) + and then Is_Class_Wide_Type (Formal_DDT) and then Interface_Present_In_Ancestor (Typ => Actual_DDT, Iface => Etype (Formal_DDT)) then + -- Handle attributes 'Access and 'Unchecked_Access + if Nkind (Actual) = N_Attribute_Reference and then (Attribute_Name (Actual) = Name_Access @@ -1228,33 +928,26 @@ package body Exp_Disp is then Nam := Attribute_Name (Actual); - Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual)); - + Conversion := Convert_To (Formal_DDT, Prefix (Actual)); Rewrite (Actual, Conversion); - Analyze_And_Resolve (Actual, Etype (Formal_DDT)); + Analyze_And_Resolve (Actual, Formal_DDT); Rewrite (Actual, Unchecked_Convert_To (Formal_Typ, Make_Attribute_Reference (Loc, Prefix => Relocate_Node (Actual), Attribute_Name => Nam))); - Analyze_And_Resolve (Actual, Formal_Typ); - -- No need to displace the pointer if the actual is a class-wide - -- type of the formal-type interface because in this case the - -- displacement of the pointer was already done at the point of - -- the call to the enclosing subprogram (this case is similar - -- to the example described above for the non access-type case) + -- No need to displace the pointer if the type of the actual + -- coincides with the type of the formal. - elsif Is_Class_Wide_Type (Actual_DDT) - and then Etype (Actual_DDT) = Formal_DDT - then + elsif Actual_DDT = Formal_DDT then null; - -- No need to displace the pointer if the type of the actual is a - -- derivation of the interface (because in this case the interface - -- primitives are located in the primary dispatch table) + -- No need to displace the pointer if the interface type is + -- a parent of the type of the actual because in this case the + -- interface primitives are located in the primary dispatch table. elsif Is_Parent (Formal_DDT, Actual_DDT) then null; @@ -1320,24 +1013,35 @@ package body Exp_Disp is -- Expand_Interface_Thunk -- ---------------------------- - function Expand_Interface_Thunk + procedure Expand_Interface_Thunk (N : Node_Id; Thunk_Alias : Entity_Id; - Thunk_Id : Entity_Id) return Node_Id + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Actuals : constant List_Id := New_List; - Decl : constant List_Id := New_List; - Formals : constant List_Id := New_List; - Target : Entity_Id; - New_Code : Node_Id; - Formal : Node_Id; - New_Formal : Node_Id; - Decl_1 : Node_Id; - Decl_2 : Node_Id; - E : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + + Controlling_Typ : Entity_Id; + Decl_1 : Node_Id; + Decl_2 : Node_Id; + Formal : Node_Id; + Target : Entity_Id; + Target_Formal : Entity_Id; begin + Thunk_Id := Empty; + Thunk_Code := Empty; + + -- Give message if configurable run-time and Offset_To_Top unavailable + + if not RTE_Available (RE_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", N); + return; + end if; + -- Traverse the list of alias to find the final target Target := Thunk_Alias; @@ -1345,167 +1049,182 @@ package body Exp_Disp is Target := Alias (Target); end loop; + -- In case of primitives that are functions without formals and + -- a controlling result there is no need to build the thunk. + + if not Present (First_Formal (Target)) then + pragma Assert (Ekind (Target) = E_Function + and then Has_Controlling_Result (Target)); + return; + end if; + -- Duplicate the formals Formal := First_Formal (Target); - E := First_Formal (N); while Present (Formal) loop - New_Formal := Copy_Separate_Tree (Parent (Formal)); - - -- Propagate the parameter type to the copy. This is required to - -- properly handle the case in which the subprogram covering the - -- interface has been inherited: - - -- Example: - -- type I is interface; - -- procedure P (X : I) is abstract; - - -- type T is tagged null record; - -- procedure P (X : T); - - -- type DT is new T and I with ... - - Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc)); - Append_To (Formals, New_Formal); + Append_To (Formals, + 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))))); Next_Formal (Formal); - Next_Formal (E); end loop; - -- Give message if configurable run-time and Offset_To_Top unavailable - - if not RTE_Available (RE_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", N); - return Empty; - end if; - if Ekind (First_Formal (Target)) = E_In_Parameter and then Ekind (Etype (First_Formal (Target))) = E_Anonymous_Access_Type then - -- Generate: - - -- type T is access all <<type of the first formal>> - -- S1 := Storage_Offset!(First_formal) - -- - Offset_To_Top (First_Formal.Tag) + Controlling_Typ := + Directly_Designated_Type (Etype (First_Formal (Target))); + else + Controlling_Typ := Etype (First_Formal (Target)); + end if; - -- ... and the first actual of the call is generated as T!(S1) + Target_Formal := First_Formal (Target); + Formal := First (Formals); + while Present (Formal) loop + if Ekind (Target_Formal) = E_In_Parameter + and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type + and then Directly_Designated_Type (Etype (Target_Formal)) + = Controlling_Typ + then + -- Generate: - Decl_2 := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Null_Exclusion_Present => False, - Constant_Present => False, - Subtype_Indication => - New_Reference_To - (Directly_Designated_Type - (Etype (First_Formal (Target))), Loc))); - - Decl_1 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_Storage_Offset), Loc), - Expression => - Make_Op_Subtract (Loc, - Left_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), + -- type T is access all <<type of the first formal>> + -- S1 := Storage_Offset!(formal) + -- - Offset_To_Top (Formal.Tag) + + -- ... and the first actual of the call is generated as T!(S1) + + Decl_2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => New_Reference_To - (Defining_Identifier (First (Formals)), Loc)), - Right_Opnd => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To - (RTE (RE_Address), - New_Reference_To - (Defining_Identifier (First (Formals)), Loc)))))); + (Directly_Designated_Type + (Etype (Target_Formal)), Loc))); - Append_To (Decl, Decl_2); - Append_To (Decl, Decl_1); + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + New_Reference_To (Defining_Identifier (Formal), Loc)), + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To + (RTE (RE_Address), + New_Reference_To + (Defining_Identifier (Formal), Loc)))))); + + Append_To (Decl, Decl_2); + Append_To (Decl, Decl_1); + + -- Reference the new first actual + + Append_To (Actuals, + Unchecked_Convert_To + (Defining_Identifier (Decl_2), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + elsif Etype (Target_Formal) = Controlling_Typ then + -- Generate: + + -- S1 := Storage_Offset!(Formal'Address) + -- - Offset_To_Top (Formal.Tag) + -- S2 := Tag_Ptr!(S3) + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (Formal), Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (Formal), Loc), + Attribute_Name => Name_Address))))); - -- Reference the new first actual + Decl_2 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => + Unchecked_Convert_To + (RTE (RE_Addr_Ptr), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); - Append_To (Actuals, - Unchecked_Convert_To - (Defining_Identifier (Decl_2), - New_Reference_To (Defining_Identifier (Decl_1), Loc))); + Append_To (Decl, Decl_1); + Append_To (Decl, Decl_2); - else - -- Generate: + -- Reference the new first actual - -- S1 := Storage_Offset!(First_formal'Address) - -- - Offset_To_Top (First_Formal.Tag) - -- S2 := Tag_Ptr!(S3) + Append_To (Actuals, + Unchecked_Convert_To + (Etype (First_Entity (Target)), + Make_Explicit_Dereference (Loc, + New_Reference_To (Defining_Identifier (Decl_2), Loc)))); - Decl_1 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_Storage_Offset), Loc), - Expression => - Make_Op_Subtract (Loc, - Left_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (First (Formals)), Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To - (Defining_Identifier (First (Formals)), - Loc), - Attribute_Name => Name_Address))))); + -- No special management required for this actual - Decl_2 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), - Expression => - Unchecked_Convert_To - (RTE (RE_Addr_Ptr), - New_Reference_To (Defining_Identifier (Decl_1), Loc))); - - Append_To (Decl, Decl_1); - Append_To (Decl, Decl_2); - - -- Reference the new first actual - - Append_To (Actuals, - Unchecked_Convert_To - (Etype (First_Entity (Target)), - Make_Explicit_Dereference (Loc, - New_Reference_To (Defining_Identifier (Decl_2), Loc)))); - end if; + else + Append_To (Actuals, + New_Reference_To (Defining_Identifier (Formal), Loc)); + end if; - Formal := Next (First (Formals)); - while Present (Formal) loop - Append_To (Actuals, - New_Reference_To (Defining_Identifier (Formal), Loc)); + Next_Formal (Target_Formal); Next (Formal); end loop; + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + if Ekind (Target) = E_Procedure then - New_Code := + Thunk_Code := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, @@ -1516,12 +1235,12 @@ package body Exp_Disp is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Target, Loc), - Parameter_Associations => Actuals)))); + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals)))); else pragma Assert (Ekind (Target) = E_Function); - New_Code := + Thunk_Code := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, @@ -1538,98 +1257,8 @@ package body Exp_Disp is Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals))))); end if; - - -- Analyze the code of the thunk with checks suppressed because we are - -- in the middle of building the dispatch information itself and some - -- characteristics of the type may not be fully available. - - Analyze (New_Code, Suppress => All_Checks); - return New_Code; end Expand_Interface_Thunk; - ------------------- - -- Fill_DT_Entry -- - ------------------- - - function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id) return Node_Id - is - Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); - DT_Ptr : constant Entity_Id := - Node (First_Elmt (Access_Disp_Table (Typ))); - Pos : constant Uint := DT_Position (Prim); - Tag : constant Entity_Id := First_Tag_Component (Typ); - - begin - pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - - if Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim) - then - return - Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (DT_Ptr, Loc), - Position_Node => Make_Integer_Literal (Loc, Pos), - Address_Node => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address)); - - else - pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); - - return - Build_Set_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (DT_Ptr, Loc), - Position_Node => Make_Integer_Literal (Loc, Pos), - Address_Node => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address)); - end if; - end Fill_DT_Entry; - - ----------------------------- - -- Fill_Secondary_DT_Entry -- - ----------------------------- - - function Fill_Secondary_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id; - Thunk_Id : Entity_Id; - Iface_DT_Ptr : Entity_Id) return Node_Id - is - Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim); - Pos : constant Uint := DT_Position (Iface_Prim); - Tag : constant Entity_Id := - First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); - - begin - if Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim) - then - return - Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => - New_Reference_To (Iface_DT_Ptr, Loc), - Position_Node => - Make_Integer_Literal (Loc, Pos), - Address_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address)); - else - pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); - - return - Build_Set_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), - Position_Node => Make_Integer_Literal (Loc, Pos), - Address_Node => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address)); - end if; - end Fill_Secondary_DT_Entry; - ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- @@ -1662,11 +1291,12 @@ package body Exp_Disp is function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id is - Conc_Typ : Entity_Id := Empty; - Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : constant List_Id := New_List; + Com_Block : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : constant List_Id := New_List; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -1703,24 +1333,35 @@ package body Exp_Disp is Object_Definition => New_Reference_To (Standard_Integer, Loc), Expression => - Make_DT_Access_Action (Typ, - Action => - Get_Entry_Index, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then -- Generate: + -- Com_Block : Communication_Block; + + Com_Block := + Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Com_Block, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Generate: -- Protected_Entry_Call ( -- T._object'access, -- protected_entry_index! (I), -- P, -- Asynchronous_Call, - -- B); + -- Com_Block); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters and B is the name of the communication @@ -1752,7 +1393,24 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uP), -- parameter block New_Reference_To ( -- Asynchronous_Call RTE (RE_Asynchronous_Call), Loc), - Make_Identifier (Loc, Name_uB)))); -- comm block + + New_Reference_To (Com_Block, Loc)))); -- comm block + + -- Generate: + -- B := Dummy_Communication_Bloc (Com_Block); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uB), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To ( + RTE (RE_Dummy_Communication_Block), Loc), + Expression => + New_Reference_To (Com_Block, Loc)))); + else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); @@ -1819,24 +1477,52 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- "T" - Object parameter - -- "S" - Primitive operation slot - -- "P" - Wrapped parameters - -- "B" - Communication block - -- "F" - Status flag + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- B : out Dummy_Communication_Block; -- Communication block dummy + -- F : out Boolean; -- Status flag + + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), - SEU.Build_T (Loc, Typ, Params); - SEU.Build_S (Loc, Params); - SEU.Build_P (Loc, Params); - SEU.Build_B (Loc, Params); - SEU.Build_F (Loc, Params); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uB), + Parameter_Type => + New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc), + Out_Present => True), - Set_Is_Internal (Def_Id); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True))); return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Def_Id, - Parameter_Specifications => Params); + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); end Make_Disp_Asynchronous_Select_Spec; --------------------------------------- @@ -1899,8 +1585,7 @@ package body Exp_Disp is -- return; -- end if; - SEU.Build_Common_Dispatching_Select_Statements - (Loc, Typ, DT_Ptr, Stmts); + Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); -- Generate: -- Bnn : Communication_Block; @@ -1927,14 +1612,12 @@ package body Exp_Disp is Name => Make_Identifier (Loc, Name_uI), Expression => - Make_DT_Access_Action (Typ, - Action => - Get_Entry_Index, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -2064,19 +1747,47 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- "T" - Object parameter - -- "S" - Primitive operation slot - -- "P" - Wrapped parameters - -- "C" - Call kind - -- "F" - Status flag + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- C : out Prim_Op_Kind; -- Call kind + -- F : out Boolean; -- Status flag - SEU.Build_T (Loc, Typ, Params); - SEU.Build_S (Loc, Params); - SEU.Build_P (Loc, Params); - SEU.Build_C (Loc, Params); - SEU.Build_F (Loc, Params); + Append_List_To (Params, New_List ( - Set_Is_Internal (Def_Id); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True))); return Make_Procedure_Specification (Loc, @@ -2130,14 +1841,13 @@ package body Exp_Disp is Name => Make_Identifier (Loc, Name_uC), Expression => - Make_DT_Access_Action (Typ, - Action => - Get_Prim_Op_Kind, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))))); + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))))); end Make_Disp_Get_Prim_Op_Kind_Body; ------------------------------------- @@ -2156,15 +1866,32 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- "T" - Object parameter - -- "S" - Primitive operation slot - -- "C" - Call kind + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- C : out Prim_Op_Kind; -- Call kind + + Append_List_To (Params, New_List ( - SEU.Build_T (Loc, Typ, Params); - SEU.Build_S (Loc, Params); - SEU.Build_C (Loc, Params); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), - Set_Is_Internal (Def_Id); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True))); return Make_Procedure_Specification (Loc, @@ -2188,22 +1915,32 @@ package body Exp_Disp is if Is_Concurrent_Record_Type (Typ) and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type then + -- Generate: + -- return To_Address (_T._task_id); + Ret := Make_Return_Statement (Loc, Expression => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id))); + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Address), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)))); -- A null body is constructed for non-task types else + -- Generate: + -- return Null_Address; + Ret := Make_Return_Statement (Loc, Expression => - New_Reference_To (RTE (RO_ST_Null_Task), Loc)); + New_Reference_To (RTE (RE_Null_Address), Loc)); end if; return @@ -2224,19 +1961,15 @@ package body Exp_Disp is function Make_Disp_Get_Task_Id_Spec (Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Def_Id : constant Node_Id := - Make_Defining_Identifier (Loc, - Name_uDisp_Get_Task_Id); + Loc : constant Source_Ptr := Sloc (Typ); begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - Set_Is_Internal (Def_Id); - return Make_Function_Specification (Loc, - Defining_Unit_Name => Def_Id, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => @@ -2244,7 +1977,7 @@ package body Exp_Disp is Parameter_Type => New_Reference_To (Typ, Loc))), Result_Definition => - New_Reference_To (RTE (RO_ST_Task_Id), Loc)); + New_Reference_To (RTE (RE_Address), Loc)); end Make_Disp_Get_Task_Id_Spec; --------------------------------- @@ -2306,8 +2039,7 @@ package body Exp_Disp is -- return; -- end if; - SEU.Build_Common_Dispatching_Select_Statements - (Loc, Typ, DT_Ptr, Stmts); + Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); -- Generate: -- I := Get_Entry_Index (tag! (<type>VP), S); @@ -2319,14 +2051,12 @@ package body Exp_Disp is Name => Make_Identifier (Loc, Name_uI), Expression => - Make_DT_Access_Action (Typ, - Action => - Get_Entry_Index, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -2439,36 +2169,62 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- "T" - Object parameter - -- "S" - Primitive operation slot - -- "P" - Wrapped parameters - -- "D" - Delay - -- "M" - Delay Mode - -- "C" - Call kind - -- "F" - Status flag + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- D : Duration; -- Delay + -- M : Integer; -- Delay Mode + -- C : out Prim_Op_Kind; -- Call kind + -- F : out Boolean; -- Status flag - SEU.Build_T (Loc, Typ, Params); - SEU.Build_S (Loc, Params); - SEU.Build_P (Loc, Params); + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), - Append_To (Params, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD), Parameter_Type => - New_Reference_To (Standard_Duration, Loc))); + New_Reference_To (Standard_Duration, Loc)), - Append_To (Params, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM), Parameter_Type => - New_Reference_To (Standard_Integer, Loc))); + New_Reference_To (Standard_Integer, Loc)), - SEU.Build_C (Loc, Params); - SEU.Build_F (Loc, Params); + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True))); - Set_Is_Internal (Def_Id); + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True)); return Make_Procedure_Specification (Loc, @@ -2480,316 +2236,894 @@ package body Exp_Disp is -- Make_DT -- ------------- + -- The frontend supports two models for expanding dispatch tables + -- associated with library-level defined tagged types: statically + -- and non-statically allocated dispatch tables. In the former case + -- the object containing the dispatch table is constant and it is + -- initialized by means of a positional aggregate. In the latter case, + -- the object containing the dispatch table is a variable which is + -- initialized by means of assignments. + + -- In case of locally defined tagged types, the object containing the + -- object containing the dispatch table is always a variable (instead + -- of a constant). This is currently required to give support to late + -- overriding of primitives. For example: + + -- procedure Example is + -- package Pkg is + -- type T1 is tagged null record; + -- procedure Prim (O : T1); + -- end Pkg; + + -- type T2 is new Pkg.T1 with null record; + -- procedure Prim (X : T2) is -- late overriding + -- begin + -- ... + -- ... + -- end; + function Make_DT (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Result : constant List_Id := New_List; - Elab_Code : constant List_Id := New_List; - - Tname : constant Name_Id := Chars (Typ); - Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); - Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); - Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); - Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); - Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); - Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); - - -- The following external name is only generated if Typ has interfaces - Name_ITable : Name_Id; - - DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); - DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); - SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD); - TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); - Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); - No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); + Loc : constant Source_Ptr := Sloc (Typ); + Is_Local_DT : constant Boolean := + Ekind (Cunit_Entity (Get_Source_Unit (Typ))) + /= E_Package; + Max_Predef_Prims : constant Int := + UI_To_Int + (Intval + (Expression + (Parent (RTE (RE_Default_Prim_Op_Count))))); + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Result : List_Id); + -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch + -- Table of Typ associated with Iface (each abstract interface of Typ + -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ + -- and Suffix_Index are used to generate an unique external name which + -- is added at the end of Acc_Disp_Tables; this external name will be + -- used later by the subprogram Exp_Ch3.Build_Init_Procedure. - Generalized_Tag : constant Entity_Id := RTE (RE_Tag); - Ancestor_Ifaces : Elist_Id; - AI : Elmt_Id; - Has_Dispatch_Table : Boolean := True; - I_Depth : Nat := 0; - ITable : Node_Id; - Iface_Table_Node : Node_Id; - Nb_Prim : Nat := 0; - Null_Parent_Tag : Boolean := False; - Num_Ifaces : Nat := 0; - Old_Tag1 : Node_Id; - Old_Tag2 : Node_Id; - Parent : Entity_Id; - Parent_Num_Ifaces : Nat := 0; - Remotely_Callable : Entity_Id; - RC_Offset_Node : Node_Id; - Size_Expr_Node : Node_Id; - Typ_Ifaces : Elist_Id; - TSD_Aggr_List : List_Id; + ----------------------- + -- Make_Secondary_DT -- + ----------------------- - begin - if not RTE_Available (RE_Tag) then - Error_Msg_CRT ("tagged types", Typ); - return New_List; - end if; + procedure Make_Secondary_DT + (Typ : Entity_Id; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Result : List_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); + + Name_DT : constant Name_Id := New_Internal_Name ('T'); + Iface_DT : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT); + Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); + Predef_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_Predef_Prims); + DT_Constr_List : List_Id; + DT_Aggr_List : List_Id; + Empty_DT : Boolean := False; + Nb_Predef_Prims : Nat := 0; + Nb_Prim : Nat; + New_Node : Node_Id; + OSD : Entity_Id; + OSD_Aggr_List : List_Id; + Pos : Nat; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Ops_Aggr_List : List_Id; - -- Ensure that the unit System_Storage_Elements is loaded. This is - -- required to properly expand the routines of Ada.Tags + begin + -- Handle the case where the backend does not support statically + -- allocated dispatch tables. - if not RTU_Loaded (System_Storage_Elements) - and then not Present (RTE (RE_Storage_Offset)) - then - raise Program_Error; - end if; + if not Static_Dispatch_Tables + or else Is_Local_DT + then + Set_Ekind (Predef_Prims, E_Variable); + Set_Is_Statically_Allocated (Predef_Prims); + + Set_Ekind (Iface_DT, E_Variable); + Set_Is_Statically_Allocated (Iface_DT); - if Ada_Version >= Ada_05 then + -- Statically allocated dispatch tables and related entities are + -- constants. - -- Count the interface types of the parents + else + Set_Ekind (Predef_Prims, E_Constant); + Set_Is_Statically_Allocated (Predef_Prims); + Set_Is_True_Constant (Predef_Prims); + + Set_Ekind (Iface_DT, E_Constant); + Set_Is_Statically_Allocated (Iface_DT); + Set_Is_True_Constant (Iface_DT); + end if; - Parent := Empty; + -- Generate code to create the storage for the Dispatch_Table object. + -- If the number of primitives of Typ is 0 we reserve a dummy single + -- entry for its DT because at run-time the pointer to this dummy + -- entry will be used as the tag. - if Typ /= Etype (Typ) then - Parent := Etype (Typ); + Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); - elsif Is_Concurrent_Record_Type (Typ) then - Parent := Etype (First (Abstract_Interface_List (Typ))); + if Nb_Prim = 0 then + Empty_DT := True; + Nb_Prim := 1; end if; - if Present (Parent) then - Collect_Abstract_Interfaces (Parent, Ancestor_Ifaces); + -- Generate: + + -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := + -- (predef-prim-op-thunk-1'address, + -- predef-prim-op-thunk-2'address, + -- ... + -- predef-prim-op-thunk-n'address); + -- for Predef_Prims'Alignment use Address'Alignment + + -- Stage 1: Calculate the number of predefined primitives - AI := First_Elmt (Ancestor_Ifaces); - while Present (AI) loop - Parent_Num_Ifaces := Parent_Num_Ifaces + 1; - Next_Elmt (AI); + if not Static_Dispatch_Tables then + Nb_Predef_Prims := Max_Predef_Prims; + else + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos > Nb_Predef_Prims then + Nb_Predef_Prims := Pos; + end if; + end if; + + Next_Elmt (Prim_Elmt); end loop; end if; - -- Count the additional interfaces implemented by Typ + -- Stage 2: Create the thunks associated with the predefined + -- primitives and save their entity to fill the aggregate. - Collect_Abstract_Interfaces (Typ, Typ_Ifaces); + declare + Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; - AI := First_Elmt (Typ_Ifaces); - while Present (AI) loop - Num_Ifaces := Num_Ifaces + 1; - Next_Elmt (AI); - end loop; - end if; + begin + Prim_Ops_Aggr_List := New_List; + Prim_Table := (others => Empty); - -- Count ancestors to compute the inheritance depth. For private - -- extensions, always go to the full view in order to compute the - -- real inheritance depth. + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - declare - Parent_Type : Entity_Id := Typ; - P : Entity_Id; + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + and then not Present (Prim_Table + (UI_To_Int (DT_Position (Prim)))) + then + while Present (Alias (Prim)) loop + Prim := Alias (Prim); + end loop; - begin - I_Depth := 0; - loop - P := Etype (Parent_Type); + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Prim, + Thunk_Id => Thunk_Id, + Thunk_Code => Thunk_Code); - if Is_Private_Type (P) then - P := Full_View (Base_Type (P)); - end if; + if Present (Thunk_Id) then + Append_To (Result, Thunk_Code); + Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id; + end if; + end if; - exit when P = Parent_Type; + Next_Elmt (Prim_Elmt); + end loop; - I_Depth := I_Depth + 1; - Parent_Type := P; - end loop; - end; + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Address); + else + New_Node := + New_Reference_To (RTE (RE_Null_Address), Loc); + end if; - -- Calculate the number of primitives of the dispatch table and the - -- size of the Type_Specific_Data record. + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; - -- Abstract interfaces don't need the dispatch table. In addition, - -- compiling with restriction No_Dispatching_Calls we do not generate - -- the dispatch table. + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims, + Constant_Present => Static_Dispatch_Tables, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Address_Array), Loc), + Expression => Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List))); - Has_Dispatch_Table := - not Is_Interface (Typ) - and then not Restriction_Active (No_Dispatching_Calls); + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Predef_Prims, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + end; - if Has_Dispatch_Table then - Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - end if; + -- Generate - -- Dispatch table and related entities are allocated statically + -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := + -- (OSD_Table => (1 => <value>, + -- ... + -- N => <value>)); - Set_Ekind (DT, E_Variable); - Set_Is_Statically_Allocated (DT); + -- Iface_DT : Dispatch_Table (Nb_Prims) := + -- ([ Signature => <sig-value> ], + -- Tag_Kind => <tag_kind-value>, + -- Predef_Prims => Predef_Prims'Address, + -- Offset_To_Top => 0, + -- OSD => OSD'Address, + -- Prims_Ptr => (prim-op-1'address, + -- prim-op-2'address, + -- ... + -- prim-op-n'address)); - Set_Ekind (DT_Ptr, E_Variable); - Set_Is_Statically_Allocated (DT_Ptr); + -- Stage 3: Initialize the discriminant and the record components - if Num_Ifaces > 0 then - Name_ITable := New_External_Name (Tname, 'I'); - ITable := Make_Defining_Identifier (Loc, Name_ITable); + DT_Constr_List := New_List; + DT_Aggr_List := New_List; - Set_Ekind (ITable, E_Variable); - Set_Is_Statically_Allocated (ITable); - end if; + -- Nb_Prim. If the tagged type has no primitives we add a dummy + -- slot whose address will be the tag of this type. - Set_Ekind (SSD, E_Variable); - Set_Is_Statically_Allocated (SSD); + if Nb_Prim = 0 then + New_Node := Make_Integer_Literal (Loc, 1); + else + New_Node := Make_Integer_Literal (Loc, Nb_Prim); + end if; - Set_Ekind (TSD, E_Variable); - Set_Is_Statically_Allocated (TSD); + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); - Set_Ekind (Exname, E_Variable); - Set_Is_Statically_Allocated (Exname); + -- Signature - Set_Ekind (No_Reg, E_Variable); - Set_Is_Statically_Allocated (No_Reg); + if RTE_Record_Component_Available (RE_Signature) then + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Secondary_DT), Loc)); + end if; - -- Generate code to create the storage for the Dispatch_Table object: + -- Tag_Kind - -- DT : Storage_Array (1 .. Size_Expr); - -- for DT'Alignment use Address'Alignment + if RTE_Record_Component_Available (RE_Tag_Kind) then + Append_To (DT_Aggr_List, Tagged_Kind (Typ)); + end if; - -- Under No_Dispatching_Calls the size of the table is small just - -- containing: - -- 1) the pointer to the TSD - -- 2) a dummy entry used as the Tag of the type (see a-tags.ads). + -- Predef_Prims - if not Has_Dispatch_Table then - Size_Expr_Node := - New_Reference_To (RTE (RE_DT_Min_Prologue_Size), Loc); + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Predef_Prims, Loc), + Attribute_Name => Name_Address)); - -- If the object has no primitives we ensure that the table will - -- have at least a dummy entry which will be used as the Tag. + -- Note: The correct value of Offset_To_Top will be set by the init + -- subprogram - -- Size_Expr := DT_Prologue_Size + DT_Entry_Size + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); - elsif Nb_Prim = 0 then - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc), - Right_Opnd => - New_Reference_To (RTE (RE_DT_Entry_Size), Loc)); + -- Generate the Object Specific Data table required to dispatch calls + -- through synchronized interfaces. - -- Common case. The dispatch table has space to save the pointers to - -- all the predefined primitives, the C++ ABI header of the DT, and - -- the pointers to the primitives of Typ. That is, + if Empty_DT + or else Is_Abstract_Type (Typ) + or else Is_Controlled (Typ) + or else Restriction_Active (No_Dispatching_Calls) + or else not Is_Limited_Type (Typ) + or else not Has_Abstract_Interfaces (Typ) + then + -- No OSD table required - -- Size_Expr := DT_Prologue_Size + nb_prim * DT_Entry_Size + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); - else - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc), - Right_Opnd => - Make_Op_Multiply (Loc, - Left_Opnd => - New_Reference_To (RTE (RE_DT_Entry_Size), Loc), - Right_Opnd => - Make_Integer_Literal (Loc, Nb_Prim))); - end if; + else + OSD_Aggr_List := New_List; - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To - (RTE (RE_Storage_Array), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Size_Expr_Node)))))); + declare + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + E : Entity_Id; + Count : Nat := 0; + Pos : Nat; - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (DT, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); + begin + Prim_Table := (others => Empty); + Prim_Alias := Empty; - -- Generate code to create the pointer to the dispatch table + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - -- DT_Ptr : Tag := Tag!(DT'Address); + if Present (Abstract_Interface_Alias (Prim)) + and then Find_Dispatching_Type + (Abstract_Interface_Alias (Prim)) = Iface + then + Prim_Alias := Abstract_Interface_Alias (Prim); - -- According to the C++ ABI, the base of the vtable is located after a - -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move - -- down the pointer to the real base of the vtable + E := Prim; + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + Pos := UI_To_Int (DT_Position (Prim_Alias)); + + if Present (Prim_Table (Pos)) then + pragma Assert (Prim_Table (Pos) = E); + null; + + else + Prim_Table (Pos) := E; + + Append_To (OSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + DT_Position (Prim_Alias))), + Expression => + Make_Integer_Literal (Loc, + DT_Position (Alias (Prim))))); + + Count := Count + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + pragma Assert (Count = Nb_Prim); + end; + + OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => OSD, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Object_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))), + Expression => Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); + + -- In secondary dispatch tables the Typeinfo component contains + -- the address of the Object Specific Data (see a-tags.ads) + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (OSD, Loc), + Attribute_Name => Name_Address)); + end if; + + -- Initialize the table of primitive operations + + Prim_Ops_Aggr_List := New_List; + + if Empty_DT then + Append_To (Prim_Ops_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); + + elsif Is_Abstract_Type (Typ) + or else not Static_Dispatch_Tables + then + for J in 1 .. Nb_Prim loop + Append_To (Prim_Ops_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); + end loop; + + else + declare + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Pos : Nat; + Thunk_Code : Node_Id; + Thunk_Id : Entity_Id; + + begin + Prim_Table := (others => Empty); + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if not Is_Predefined_Dispatching_Operation (Prim) + and then Present (Abstract_Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (Alias (Prim)) + and then not Is_Imported (Alias (Prim)) + and then Find_Dispatching_Type + (Abstract_Interface_Alias (Prim)) = Iface + + -- Generate the code of the thunk only if the abstract + -- interface type is not an immediate ancestor of + -- Tagged_Type; otherwise the DT associated with the + -- interface is the primary DT. + + and then not Is_Parent (Iface, Typ) + then + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Alias (Prim), + Thunk_Id => Thunk_Id, + Thunk_Code => Thunk_Code); + + if Present (Thunk_Id) then + Pos := + UI_To_Int + (DT_Position (Abstract_Interface_Alias (Prim))); + + Prim_Table (Pos) := Thunk_Id; + Append_To (Result, Thunk_Code); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Address); + else + New_Node := + New_Reference_To (RTE (RE_Null_Address), Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + end; + end if; + + Append_To (DT_Aggr_List, + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List)); - if not Has_Dispatch_Table then Append_To (Result, Make_Object_Declaration (Loc, - Defining_Identifier => DT_Ptr, + Defining_Identifier => Iface_DT, + Aliased_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)), + + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + -- Generate code to create the pointer to the dispatch table + + -- Iface_DT_Ptr : Tag := Tag!(DT'Address); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, Constant_Present => True, - Object_Definition => New_Reference_To (Generalized_Tag, Loc), - Expression => + Object_Definition => + New_Reference_To (RTE (RE_Interface_Tag), Loc), + Expression => Unchecked_Convert_To (Generalized_Tag, - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (DT, Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))); + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + end Make_Secondary_DT; + + -- Local variables + + -- Seems a huge list, shouldn't some of these be commented??? + -- Seems like we are counting too much on guessing from names here??? + + Elab_Code : constant List_Id := New_List; + Generalized_Tag : constant Entity_Id := RTE (RE_Tag); + Result : constant List_Id := New_List; + Tname : constant Name_Id := Chars (Typ); + Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); + Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); + Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R'); + Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); + Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); + DT : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT); + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Exname); + Predef_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Predef_Prims); + SSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_TSD); + AI : Elmt_Id; + AI_Tag_Comp : Elmt_Id; + AI_Ptr_Elmt : Elmt_Id; + DT_Constr_List : List_Id; + DT_Aggr_List : List_Id; + DT_Ptr : Entity_Id; + Has_Dispatch_Table : Boolean := True; + ITable : Node_Id; + I_Depth : Nat := 0; + Iface_Table_Node : Node_Id; + Name_ITable : Name_Id; + Name_No_Reg : Name_Id; + Nb_Predef_Prims : Nat := 0; + Nb_Prim : Nat := 0; + New_Node : Node_Id; + No_Reg : Node_Id; + Null_Parent_Tag : Boolean := False; + Num_Ifaces : Nat := 0; + Old_Tag1 : Node_Id; + Old_Tag2 : Node_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Ops_Aggr_List : List_Id; + Transportable : Entity_Id; + RC_Offset_Node : Node_Id; + Suffix_Index : Int; + Typ_Comps : Elist_Id; + Typ_Ifaces : Elist_Id; + TSD_Aggr_List : List_Id; + TSD_Tags_List : List_Id; + TSD_Ifaces_List : List_Id; + + -- Start of processing for Make_DT + + begin + -- Fill the contents of Access_Disp_Table + + -- 1) Generate the primary and secondary tag entities + + declare + DT_Ptr : Node_Id; + Name_DT_Ptr : Name_Id; + Typ_Name : Name_Id; + Iface_DT_Ptr : Node_Id; + Suffix_Index : Int; + AI_Tag_Comp : Elmt_Id; + + begin + -- Collect the components associated with secondary dispatch tables + + if Has_Abstract_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); + end if; + + -- Generate the primary tag entity + + Name_DT_Ptr := New_External_Name (Tname, 'P'); + DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); + Set_Ekind (DT_Ptr, E_Constant); + Set_Is_Statically_Allocated (DT_Ptr); + Set_Is_True_Constant (DT_Ptr); + + pragma Assert (No (Access_Disp_Table (Typ))); + Set_Access_Disp_Table (Typ, New_Elmt_List); + Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + + -- Generate the secondary tag entities + + if Has_Abstract_Interfaces (Typ) then + Suffix_Index := 0; + + -- For each interface type we build an unique external name + -- associated with its corresponding secondary dispatch table. + -- This external name will be used to declare an object that + -- references this secondary dispatch table, value that will be + -- used for the elaboration of Typ's objects and also for the + -- elaboration of objects of derivations of Typ that do not + -- override the primitive operation of this interface type. + + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index); + + Typ_Name := Name_Find; + Name_DT_Ptr := New_External_Name (Typ_Name, "P"); + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); + + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_True_Constant (Iface_DT_Ptr); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + Next_Elmt (AI_Tag_Comp); + end loop; + end if; + end; + + -- 2) At the end of Access_Disp_Table we add the entity of an access + -- type declaration. It is used by Build_Get_Prim_Op_Address to + -- expand dispatching calls through the primary dispatch table. + + -- Generate: + -- type Typ_DT is array (1 .. Nb_Prims) of Address; + -- type Typ_DT_Acc is access Typ_DT; + + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Address), Loc))))); + + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (DT_Prims, Loc)))); + + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + end; + + if Is_CPP_Class (Typ) then + return Result; + end if; + + if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - else Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Constant_Present => True, - Object_Definition => New_Reference_To (Generalized_Tag, Loc), - Expression => + Expression => Unchecked_Convert_To (Generalized_Tag, - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (DT, Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))))); + New_Reference_To (RTE (RE_Null_Address), Loc)))); + + Analyze_List (Result, Suppress => All_Checks); + Error_Msg_CRT ("tagged types", Typ); + return Result; + end if; + + if not Static_Dispatch_Tables + or else Is_Local_DT + then + Set_Ekind (DT, E_Variable); + Set_Is_Statically_Allocated (DT); + else + Set_Ekind (DT, E_Constant); + Set_Is_Statically_Allocated (DT); + Set_Is_True_Constant (DT); end if; - -- Save the tag in the Access_Disp_Table attribute + pragma Assert (Present (Access_Disp_Table (Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if No (Access_Disp_Table (Typ)) then - Set_Access_Disp_Table (Typ, New_Elmt_List); + -- Ada 2005 (AI-251): Build the secondary dispatch tables + + if Has_Abstract_Interfaces (Typ) then + Suffix_Index := 0; + AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Make_Secondary_DT + (Typ => Typ, + Iface => Base_Type + (Related_Interface (Node (AI_Tag_Comp))), + AI_Tag => Node (AI_Tag_Comp), + Iface_DT_Ptr => Node (AI_Ptr_Elmt), + Result => Result); + + Suffix_Index := Suffix_Index + 1; + Next_Elmt (AI_Ptr_Elmt); + Next_Elmt (AI_Tag_Comp); + end loop; + end if; + + -- Evaluate if we generate the dispatch table + + Has_Dispatch_Table := + not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls); + + -- Calculate the number of primitives of the dispatch table and the + -- size of the Type_Specific_Data record. + + if Has_Dispatch_Table then + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); end if; - Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + if not Static_Dispatch_Tables then + Set_Ekind (Predef_Prims, E_Variable); + Set_Is_Statically_Allocated (Predef_Prims); + else + Set_Ekind (Predef_Prims, E_Constant); + Set_Is_Statically_Allocated (Predef_Prims); + Set_Is_True_Constant (Predef_Prims); + end if; + + Set_Ekind (SSD, E_Constant); + Set_Is_Statically_Allocated (SSD); + Set_Is_True_Constant (SSD); + + Set_Ekind (TSD, E_Constant); + Set_Is_Statically_Allocated (TSD); + Set_Is_True_Constant (TSD); + + Set_Ekind (Exname, E_Constant); + Set_Is_Statically_Allocated (Exname); + Set_Is_True_Constant (Exname); -- Generate code to define the boolean that controls registration, in -- order to avoid multiple registrations for tagged types defined in -- multiple-called scopes. - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => No_Reg, - Object_Definition => New_Reference_To (Standard_Boolean, Loc), - Expression => New_Reference_To (Standard_True, Loc))); + if not Is_Interface (Typ) then + Name_No_Reg := New_External_Name (Tname, 'F'); + No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); - -- Generate: - -- Set_Signature (DT_Ptr, Value); + Set_Ekind (No_Reg, E_Variable); + Set_Is_Statically_Allocated (No_Reg); - if Has_Dispatch_Table - and then RTE_Available (RE_Set_Signature) - then - if Is_Interface (Typ) then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Signature, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), - New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => No_Reg, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + 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 Is_Local_DT then + + -- Generate: + -- DT : No_Dispatch_Table_Wrapper; + -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); + + if not Has_Dispatch_Table then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => False, + Object_Definition => + New_Reference_To + (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + -- Generate: + -- DT : Dispatch_Table_Wrapper (Nb_Prim); + -- for DT'Alignment use Address'Alignment; + -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); else - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Signature, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), - New_Reference_To (RTE (RE_Primary_DT), Loc)))); + -- 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 => False, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); end if; end if; @@ -2806,21 +3140,332 @@ package body Exp_Disp is Make_String_Literal (Loc, Full_Qualified_Name (First_Subtype (Typ))))); - -- Calculate the value of the RC_Offset component. These are the - -- valid valiues and their meaning: + -- Generate code to create the storage for the type specific data object + -- with enough space to store the tags of the ancestors plus the tags + -- of all the implemented interfaces (as described in a-tags.adb). + + -- TSD : Type_Specific_Data (I_Depth) := + -- (Idepth => I_Depth, + -- Access_Level => Type_Access_Level (Typ), + -- Expanded_Name => Cstring_Ptr!(Exname'Address)) + -- External_Tag => Cstring_Ptr!(Exname'Address)) + -- HT_Link => null, + -- Transportable => <<boolean-value>>, + -- RC_Offset => <<integer-value>>, + -- [ Interfaces_Table => <<access-value>> ] + -- [ SSD => SSD_Table'Address ] + -- Tags_Table => (0 => null, + -- 1 => Parent'Tag + -- ...); + -- for TSD'Alignment use Address'Alignment + + TSD_Aggr_List := New_List; + + -- Idepth: Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the real + -- inheritance depth. + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + I_Depth := 0; + Current_Typ := Typ; + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + I_Depth := I_Depth + 1; + Current_Typ := Parent_Typ; + end loop; + end; + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), + Expression => + Make_Integer_Literal (Loc, I_Depth))); + + -- Access_Level + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)), + Expression => + Make_Integer_Literal (Loc, Type_Access_Level (Typ)))); + + -- Expanded_Name + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)), + Expression => + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- External_Tag of a local tagged type + + -- Exname : constant String := + -- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; + + -- The reason we generate this strange name is that we do not want to + -- enter local tagged types in the global hash table used to compute + -- the Internal_Tag attribute for two reasons: + + -- 1. It is hard to avoid a tasking race condition for entering the + -- entry into the hash table. + + -- 2. It would cause a storage leak, unless we rig up considerable + -- mechanism to remove the entry from the hash table on exit. + + -- So what we do is to generate the above external tag name, where the + -- hex address is the address of the local dispatch table (i.e. exactly + -- the value we want if Internal_Tag is computed from this string). + + -- Of course this value will only be valid if the tagged type is still + -- in scope, but it clearly must be erroneous to compute the internal + -- tag of a tagged type that is out of scope! + + if Is_Local_DT then + declare + Name_Exname : constant Name_Id := New_External_Name (Tname, 'L'); + Name_Str1 : constant Name_Id := New_Internal_Name ('I'); + Name_Str2 : constant Name_Id := New_Internal_Name ('I'); + Name_Str3 : constant Name_Id := New_Internal_Name ('I'); + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Exname); + Str1 : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Str1); + Str2 : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Str2); + Str3 : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Str3); + Full_Name : constant String_Id := + Full_Qualified_Name (First_Subtype (Typ)); + Str1_Id : String_Id; + Str2_Id : String_Id; + Str3_Id : String_Id; + + begin + -- Generate: + -- Str1 : constant String := "Internal tag at 16#"; + + Set_Ekind (Str1, E_Constant); + Set_Is_Statically_Allocated (Str1); + Set_Is_True_Constant (Str1); + + Start_String; + Store_String_Chars ("Internal tag at 16#"); + Str1_Id := End_String; + + -- Generate: + -- Str2 : constant String := "#: "; + + Set_Ekind (Str2, E_Constant); + Set_Is_Statically_Allocated (Str2); + Set_Is_True_Constant (Str2); + + Start_String; + Store_String_Chars ("#: "); + Str2_Id := End_String; + + -- Generate: + -- Str3 : constant String := <full-name-of-typ>; + + Set_Ekind (Str3, E_Constant); + Set_Is_Statically_Allocated (Str3); + Set_Is_True_Constant (Str3); + + Start_String; + Store_String_Chars (Full_Name); + Str3_Id := End_String; + + -- Generate: + -- Exname : constant String := + -- Str1 & Address_Image (Tag) & Str2 & Str3; + + if RTE_Available (RE_Address_Image) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To + (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str1_Id), + Right_Opnd => + Make_Op_Concat (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (RTE (RE_Address_Image), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Reference_To (DT_Ptr, Loc)))), + Right_Opnd => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str2_Id), + Right_Opnd => + Make_String_Literal (Loc, Str3_Id)))))); + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To + (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str1_Id), + Right_Opnd => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str2_Id), + Right_Opnd => + Make_String_Literal (Loc, Str3_Id))))); + end if; + + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)); + end; + + -- External tag of a library-level tagged type: Check for a definition + -- of External_Tag. The clause is considered only if it applies to this + -- specific tagged type, as opposed to one of its ancestors. + + else + declare + Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ, + Attribute_External_Tag); + Old_Val : String_Id; + New_Val : String_Id; + E : Entity_Id; + + begin + if not Present (Def) + or else Entity (Name (Def)) /= Typ + then + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)); + else + Old_Val := Strval (Expr_Value_S (Expression (Def))); + + -- For the rep clause "for x'external_tag use y" generate: + + -- xV : constant string := y; + -- Set_External_Tag (x'tag, xV'Address); + -- Register_Tag (x'tag); + + -- Create a new nul terminated string if it is not already + + if String_Length (Old_Val) > 0 + and then + Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 + then + New_Val := Old_Val; + else + Start_String (Old_Val); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + New_Val := End_String; + end if; + + E := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Typ), 'A')); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, New_Val))); + + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (E, Loc), + Attribute_Name => Name_Address)); + end if; + end; + end if; + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_External_Tag), Loc)), + Expression => New_Node)); + + -- HT_Link + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_HT_Link), Loc)), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + + -- Transportable: Set for types that can be used in remote calls + -- with respect to E.4(18) legality rules. + + Transportable := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Transportable), Loc)), + Expression => New_Occurrence_Of (Transportable, Loc))); + + -- RC_Offset: These are the valid values and their meaning: + -- >0: For simple types with controlled components is -- type._record_controller'position + -- 0: For types with no controlled components + -- -1: For complex types with controlled components where the position -- of the record controller is not statically computable but there -- are controlled components at this level. The _Controller field -- is available right after the _parent. + -- -2: There are no controlled components at this level. We need to -- get the position from the parent. - if Is_Interface (Typ) - or else not Has_Controlled_Component (Typ) - then + if not Has_Controlled_Component (Typ) then RC_Offset_Node := Make_Integer_Literal (Loc, 0); elsif Etype (Typ) /= Typ @@ -2856,131 +3501,259 @@ package body Exp_Disp is Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); end if; - -- Set the pointer to the Interfaces_Table (if any). Otherwise the - -- corresponding access component is set to null. The table of - -- interfaces is required for AI-405 + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)), + Expression => RC_Offset_Node)); + + -- Interfaces_Table (required for AI-405) + + if RTE_Record_Component_Available (RE_Interfaces_Table) then + + -- Count the number of interface types implemented by Typ + + Collect_Abstract_Interfaces (Typ, Typ_Ifaces); + + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; - if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then if Num_Ifaces = 0 then - Iface_Table_Node := - New_Reference_To (RTE (RE_Null_Address), Loc); + Iface_Table_Node := Make_Null (Loc); - -- Generate the Interface_Table object. + -- Generate the Interface_Table object else + TSD_Ifaces_List := New_List; + + declare + Pos : Nat := 1; + Aggr_List : List_Id; + + begin + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + Aggr_List := New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Iface_Tag), Loc)), + Expression => + Unchecked_Convert_To (Generalized_Tag, + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Node (AI)))), + Loc))), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Static_Offset_To_Top), + Loc)), + Expression => + New_Reference_To (Standard_True, Loc)), + + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True)); + + Append_To (TSD_Ifaces_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Pos)), + Expression => Make_Aggregate (Loc, + Component_Associations => Aggr_List))); + + Pos := Pos + 1; + Next_Elmt (AI); + end loop; + end; + + Name_ITable := New_External_Name (Tname, 'I'); + ITable := Make_Defining_Identifier (Loc, Name_ITable); + + Set_Ekind (ITable, E_Constant); + Set_Is_Statically_Allocated (ITable); + Set_Is_True_Constant (ITable); + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => ITable, Aliased_Present => True, Object_Definition => Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To - (RTE (RE_Interface_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Interface_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( - Make_Integer_Literal (Loc, - Num_Ifaces)))))); + Make_Integer_Literal (Loc, Num_Ifaces)))), + + Expression => Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Nb_Ifaces), Loc)), + Expression => + Make_Integer_Literal (Loc, Num_Ifaces)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Ifaces_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => TSD_Ifaces_List)))))); Iface_Table_Node := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (ITable, Loc), - Attribute_Name => Name_Address); + Attribute_Name => Name_Unchecked_Access); end if; + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_Interfaces_Table), Loc)), + Expression => Iface_Table_Node)); end if; - -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is - -- described in E.4 (18) + -- Generate the Select Specific Data table for synchronized types that + -- implement synchronized interfaces. The size of the table is + -- constrained by the number of non-predefined primitive operations. - Remotely_Callable := - Boolean_Literals - (Is_Pure (Typ) - or else Is_Shared_Passive (Typ) - or else - ((Is_Remote_Types (Typ) - or else Is_Remote_Call_Interface (Typ)) - and then Original_View_In_Visible_Part (Typ)) - or else not Comes_From_Source (Typ)); + if RTE_Record_Component_Available (RE_SSD) then + if Ada_Version >= Ada_05 + and then Has_Dispatch_Table + and then Is_Concurrent_Record_Type (Typ) + and then Has_Abstract_Interfaces (Typ) + and then Nb_Prim > 0 + and then not Is_Abstract_Type (Typ) + and then not Is_Controlled (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))))); + + -- This table is initialized by Make_Select_Specific_Data_Table, + -- which calls Set_Entry_Index and Set_Prim_Op_Kind. + + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_SSD), Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Unchecked_Access))); + else + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_SSD), Loc)), + Expression => Make_Null (Loc))); + end if; + end if; - -- Generate code to create the storage for the type specific data object - -- with enough space to store the tags of the ancestors plus the tags - -- of all the implemented interfaces (as described in a-tags.adb). + -- Initialize the table of ancestor tags. In case of interface types + -- this table is not needed. - -- TSD : Type_Specific_Data (I_Depth) := - -- (Idepth => I_Depth, - -- Access_Level => Type_Access_Level (Typ), - -- Expanded_Name => Cstring_Ptr!(Exname'Address)) - -- [ External_Tag => Cstring_Ptr!(Exname'Address)) ] - -- RC_Offset => <<integer-value>>, - -- Remotely_Callable => <<boolean-value>> - -- [ Ifaces_Table_Ptr => <<access-value>> ] - -- others => <>); - -- for TSD'Alignment use Address'Alignment + if Is_Interface (Typ) then + Append_To (TSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True)); + else + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Pos : Nat; - TSD_Aggr_List := New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), - Expression => Make_Integer_Literal (Loc, I_Depth)), + begin + TSD_Tags_List := New_List; - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)), - Expression => Make_Integer_Literal (Loc, Type_Access_Level (Typ))), + -- Fill position 0 with null because we still have not generated + -- the tag of Typ. - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Expanded_Name), Loc)), - Expression => - Unchecked_Convert_To (RTE (RE_Cstring_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); + Append_To (TSD_Tags_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, 0)), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); - if not Has_External_Tag_Rep_Clause (Typ) then + -- Fill the rest of the table with the tags of the ancestors - -- Should be the external name not the qualified name??? + Pos := 1; + Current_Typ := Typ; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_External_Tag), Loc)), - Expression => - Unchecked_Convert_To (RTE (RE_Cstring_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); - end if; + loop + Parent_Typ := Etype (Current_Typ); - Append_List_To (TSD_Aggr_List, New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)), - Expression => RC_Offset_Node), + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Remotely_Callable), Loc)), - Expression => New_Occurrence_Of (Remotely_Callable, Loc)))); + exit when Parent_Typ = Current_Typ; + + if Is_CPP_Class (Parent_Typ) then + + -- The tags defined in the C++ side will be inherited when + -- the object is constructed. + -- (see Exp_Ch3.Build_Init_Procedure) + + Append_To (TSD_Tags_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Pos)), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + else + Append_To (TSD_Tags_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Pos)), + Expression => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), + Loc))); + end if; + + Pos := Pos + 1; + Current_Typ := Parent_Typ; + end loop; + + pragma Assert (Pos = I_Depth + 1); + end; - if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then Append_To (TSD_Aggr_List, Make_Component_Association (Loc, Choices => New_List ( New_Occurrence_Of - (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)), - Expression => Iface_Table_Node)); + (RTE_Record_Component (RE_Tags_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => TSD_Tags_List))); end if; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); - - -- Save the expanded name in the dispatch table + -- Build the TSD object Append_To (Result, Make_Object_Declaration (Loc, @@ -2994,6 +3767,7 @@ package body Exp_Disp is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, I_Depth)))), + Expression => Make_Aggregate (Loc, Component_Associations => TSD_Aggr_List))); @@ -3006,77 +3780,402 @@ package body Exp_Disp is Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); - -- Generate code to put the Address of the TSD in the dispatch table + -- Generate the dummy Dispatch_Table object associated with tagged + -- types that have no dispatch table. - Append_To (Elab_Code, - Build_Set_TSD (Loc, - Tag_Node => New_Reference_To (DT_Ptr, Loc), - Value_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (TSD, Loc), - Attribute_Name => Name_Address))); + -- DT : No_Dispatch_Table := + -- (NDT_TSD => TSD'Address; + -- NDT_Prims_Ptr => 0); - -- Generate extra code required for synchronized interfaces + if not Has_Dispatch_Table then + DT_Constr_List := New_List; + DT_Aggr_List := New_List; - if RTE_Available (RE_Set_Tagged_Kind) then - if Ada_Version >= Ada_05 - and then not Is_Interface (Typ) - and then not Is_Abstract_Type (Typ) - and then not Is_Controlled (Typ) - and then not Restriction_Active (No_Dispatching_Calls) - then - -- Generate: - -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); + -- Typeinfo - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Tagged_Kind, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - Tagged_Kind (Typ)))); -- Value - - -- Generate the Select Specific Data table for synchronized - -- types that implement a synchronized interface. The size - -- of the table is constrained by the number of non-predefined - -- primitive operations. - - if Has_Dispatch_Table - and then Is_Concurrent_Record_Type (Typ) - and then Has_Abstract_Interfaces (Typ) - then - -- No need to generate this code if Nb_Prim = 0 ??? + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address); + + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + + -- In case of locally defined tagged types we have already declared + -- and uninitialized object for the dispatch table, which is now + -- initialized by means of an assignment. + + if Is_Local_DT then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (DT, Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + -- In case of library level tagged types we declare now the constant + -- object containing the dispatch table. + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => Static_Dispatch_Tables, + Object_Definition => + New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + end if; + + -- Common case: Typ has a dispatch table + + -- Generate: + + -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := + -- (predef-prim-op-1'address, + -- predef-prim-op-2'address, + -- ... + -- predef-prim-op-n'address); + -- for Predef_Prims'Alignment use Address'Alignment + + -- DT : Dispatch_Table (Nb_Prims) := + -- (Signature => <sig-value>, + -- Tag_Kind => <tag_kind-value>, + -- Predef_Prims => Predef_Prims'First'Address, + -- Offset_To_Top => 0, + -- TSD => TSD'Address; + -- Prims_Ptr => (prim-op-1'address, + -- prim-op-2'address, + -- ... + -- prim-op-n'address)); + + else + declare + Pos : Nat; + + begin + if not Static_Dispatch_Tables then + Nb_Predef_Prims := Max_Predef_Prims; + + else + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos > Nb_Predef_Prims then + Nb_Predef_Prims := Pos; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + declare + Prim_Table : array + (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + E : Entity_Id; + + begin + Prim_Ops_Aggr_List := New_List; + + Prim_Table := (others => Empty); + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Static_Dispatch_Tables + and then Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + and then not Present (Prim_Table + (UI_To_Int (DT_Position (Prim)))) + then + E := Prim; + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + pragma Assert (not Is_Abstract_Subprogram (E)); + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Address); + else + New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; Append_To (Result, Make_Object_Declaration (Loc, - Defining_Identifier => SSD, + Defining_Identifier => Predef_Prims, Aliased_Present => True, + Constant_Present => Static_Dispatch_Tables, Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To ( - RTE (RE_Select_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))))); - - -- Set the pointer to the Select Specific Data table in the TSD - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_SSD, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (SSD, Loc), - Attribute_Name => Name_Address)))); - end if; + New_Reference_To (RTE (RE_Address_Array), Loc), + Expression => Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Predef_Prims, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + end; + end; + + -- Stage 1: Initialize the discriminant and the record components + + DT_Constr_List := New_List; + DT_Aggr_List := New_List; + + -- Num_Prims. 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 + New_Node := Make_Integer_Literal (Loc, 1); + else + New_Node := Make_Integer_Literal (Loc, Nb_Prim); + end if; + + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); + + -- Signature + + if RTE_Record_Component_Available (RE_Signature) then + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Primary_DT), Loc)); end if; + + -- Tag_Kind + + if RTE_Record_Component_Available (RE_Tag_Kind) then + Append_To (DT_Aggr_List, Tagged_Kind (Typ)); + end if; + + -- Predef_Prims + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Predef_Prims, Loc), + Attribute_Name => Name_Address)); + + -- Offset_To_Top + + if RTE_Record_Component_Available (RE_Offset_To_Top) then + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + end if; + + -- Typeinfo + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address)); + + -- Stage 2: Initialize the table of primitive operations + + Prim_Ops_Aggr_List := New_List; + + if Nb_Prim = 0 then + Append_To (Prim_Ops_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); + + elsif not Static_Dispatch_Tables then + for J in 1 .. Nb_Prim loop + Append_To (Prim_Ops_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); + end loop; + + else + declare + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + E : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + Prim_Table := (others => Empty); + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Imported (Prim) + or else Present (Abstract_Interface_Alias (Prim)) + or else Is_Predefined_Dispatching_Operation (Prim) + then + null; + + else + -- Traverse the list of aliased entities to handle + -- renamings of predefined primitives. + + E := Prim; + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + if not Is_Predefined_Dispatching_Operation (E) + and then not Is_Abstract_Subprogram (E) + and then not Present (Abstract_Interface_Alias (E)) + then + pragma Assert + (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); + + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; + + -- There is no need to set Has_Delayed_Freeze here + -- because the analysis of 'Address and 'Code_Address + -- takes care of it. + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Address); + else + New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + end; + end if; + + Append_To (DT_Aggr_List, + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List)); + + -- In case of locally defined tagged types we have already declared + -- and uninitialized object for the dispatch table, which is now + -- initialized by means of an assignment. + + if Is_Local_DT then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (DT, Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + -- In case of library level tagged types we declare now the constant + -- object containing the dispatch table. + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => Static_Dispatch_Tables, + 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)), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + end if; + end if; + + -- Initialize the table of ancestor tags + + if not Is_Interface (Typ) + and then not Is_CPP_Class (Typ) + then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Tags_Table), Loc)), + Expressions => + New_List (Make_Integer_Literal (Loc, 0))), + + Expression => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; + if Static_Dispatch_Tables then + null; + -- If the ancestor is a CPP_Class type we inherit the dispatch tables -- in the init proc, and we don't need to fill them in here. - if Is_CPP_Class (Etype (Typ)) then + elsif Is_CPP_Class (Etype (Typ)) then null; -- Otherwise we fill in the dispatch tables here @@ -3111,39 +4210,32 @@ package body Exp_Disp is -- Inherit the dispatch table if not Is_Interface (Etype (Typ)) then - if Restriction_Active (No_Dispatching_Calls) then - null; + if not Null_Parent_Tag then + declare + Nb_Prims : constant Int := + UI_To_Int (DT_Entry_Count + (First_Tag_Component (Etype (Typ)))); + begin + Append_To (Elab_Code, + Build_Inherit_Predefined_Prims (Loc, + Old_Tag_Node => Old_Tag1, + New_Tag_Node => + New_Reference_To (DT_Ptr, Loc))); - else - if not Null_Parent_Tag then - declare - Nb_Prims : constant Int := - UI_To_Int (DT_Entry_Count - (First_Tag_Component (Etype (Typ)))); - begin + if Nb_Prims /= 0 then Append_To (Elab_Code, - Build_Inherit_Predefined_Prims (Loc, - Old_Tag_Node => Old_Tag1, - New_Tag_Node => - New_Reference_To (DT_Ptr, Loc))); - - if Nb_Prims /= 0 then - Append_To (Elab_Code, - Build_Inherit_Prims (Loc, - Old_Tag_Node => Old_Tag2, - New_Tag_Node => New_Reference_To (DT_Ptr, Loc), - Num_Prims => Nb_Prims)); - end if; - end; - end if; + Build_Inherit_Prims (Loc, + Old_Tag_Node => Old_Tag2, + New_Tag_Node => New_Reference_To (DT_Ptr, Loc), + Num_Prims => Nb_Prims)); + end if; + end; end if; end if; -- Inherit the secondary dispatch tables of the ancestor - if not Restriction_Active (No_Dispatching_Calls) - and then not Is_CPP_Class (Etype (Typ)) - then + if not Is_CPP_Class (Etype (Typ)) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt @@ -3187,6 +4279,7 @@ package body Exp_Disp is E := First_Entity (Typ); while Present (E) and then Present (Node (Sec_DT_Ancestor)) + and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant loop if Is_Tag (E) and then Chars (E) /= Name_uTag then if not Is_Interface (Etype (Typ)) then @@ -3238,8 +4331,9 @@ package body Exp_Disp is end Copy_Secondary_DTs; begin - if Present (Node (Sec_DT_Ancestor)) then - + if Present (Node (Sec_DT_Ancestor)) + and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant + then -- Handle private types if Present (Full_View (Typ)) then @@ -3251,50 +4345,6 @@ package body Exp_Disp is end; end if; end if; - - -- Generate: - -- Inherit_TSD (parent'tag, DT_Ptr); - - if not Is_Interface (Typ) then - if Typ = Etype (Typ) - or else Is_CPP_Class (Etype (Typ)) - then - -- New_TSD (DT_Ptr); - - Append_List_To (Elab_Code, - Build_New_TSD (Loc, - New_Tag_Node => New_Reference_To (DT_Ptr, Loc))); - else - -- Inherit_TSD (parent'tag, DT_Ptr); - - Append_To (Elab_Code, - Build_Inherit_TSD (Loc, - Old_Tag_Node => - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), - Loc), - New_Tag_Node => New_Reference_To (DT_Ptr, Loc), - I_Depth => I_Depth, - Parent_Num_Ifaces => Parent_Num_Ifaces)); - end if; - end if; - end if; - - if not Is_Interface (Typ) - and then RTE_Available (RE_Set_Offset_To_Top) - then - -- Generate: - -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null); - - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - New_Reference_To (RTE (RE_Null_Address), Loc), - New_Reference_To (DT_Ptr, Loc), - New_Occurrence_Of (Standard_True, Loc), - Make_Integer_Literal (Loc, Uint_0), - New_Reference_To (RTE (RE_Null_Address), Loc)))); end if; -- Generate code to register the Tag in the External_Tag hash table for @@ -3302,410 +4352,49 @@ package body Exp_Disp is -- Register_Tag (Dt_Ptr); - -- Skip this if routine not available, or in No_Run_Time mode or Typ is - -- an abstract interface type (because the table to register it is not - -- available in the abstract type but in types implementing this - -- interface) - - if not Has_External_Tag_Rep_Clause (Typ) - and then not No_Run_Time_Mode - and then RTE_Available (RE_Register_Tag) - and then Is_RTE (RTE (RE_Tag), RE_Tag) - and then not Is_Interface (Typ) - then - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Register_Tag), Loc), - Parameter_Associations => - New_List (New_Reference_To (DT_Ptr, Loc)))); - end if; + -- Skip this action in the following cases: + -- 1) if Register_Tag is not available. + -- 2) in No_Run_Time mode. + -- 3) if Typ is an abstract interface type (the secondary tags will + -- be registered later in types implementing this interface type). + -- 4) if Typ is not defined at the library level (this is required + -- to avoid adding concurrency control to the hash table used + -- by the run-time to register the tags). -- Generate: -- if No_Reg then - -- <elab_code> + -- [ Elab_Code ] + -- [ Register_Tag (Dt_Ptr); ] -- No_Reg := False; -- end if; - Append_To (Elab_Code, - Make_Assignment_Statement (Loc, - Name => New_Reference_To (No_Reg, Loc), - Expression => New_Reference_To (Standard_False, Loc))); - - Append_To (Result, - Make_Implicit_If_Statement (Typ, - Condition => New_Reference_To (No_Reg, Loc), - Then_Statements => Elab_Code)); - - -- Ada 2005 (AI-251): Register the tag of the interfaces into the table - -- of interfaces. - - if Num_Ifaces > 0 then - declare - Position : Nat; - - begin - -- If the parent is an interface we must generate code to register - -- all its interfaces; otherwise this code is not needed because - -- Inherit_TSD has already inherited such interfaces. - - if Is_Concurrent_Record_Type (Typ) - or else (Etype (Typ) /= Typ and then Is_Interface (Etype (Typ))) - then - Position := 1; - - AI := First_Elmt (Ancestor_Ifaces); - while Present (AI) loop - -- Generate: - -- Register_Interface (DT_Ptr, Interface'Tag); - - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Register_Interface_Tag, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table (Node (AI)))), - Loc), - Node3 => Make_Integer_Literal (Loc, Position)))); - - Position := Position + 1; - Next_Elmt (AI); - end loop; - end if; - - -- Register the interfaces that are not implemented by the - -- ancestor - - AI := First_Elmt (Typ_Ifaces); - - -- Skip the interfaces implemented by the ancestor - - for Count in 1 .. Parent_Num_Ifaces loop - Next_Elmt (AI); - end loop; - - -- Register the additional interfaces - - Position := Parent_Num_Ifaces + 1; - while Present (AI) loop - - -- Generate: - -- Register_Interface (DT_Ptr, Interface'Tag); - - if not Is_Interface (Typ) - or else Typ /= Node (AI) - then - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Register_Interface_Tag, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table (Node (AI)))), - Loc), - Node3 => Make_Integer_Literal (Loc, Position)))); - - Position := Position + 1; - end if; + if not Is_Interface (Typ) then + if not No_Run_Time_Mode + and then not Is_Local_DT + and then RTE_Available (RE_Register_Tag) + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => + New_List (New_Reference_To (DT_Ptr, Loc)))); + end if; - Next_Elmt (AI); - end loop; + Append_To (Elab_Code, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (No_Reg, Loc), + Expression => New_Reference_To (Standard_False, Loc))); - pragma Assert (Position = Num_Ifaces + 1); - end; + Append_To (Result, + Make_Implicit_If_Statement (Typ, + Condition => New_Reference_To (No_Reg, Loc), + Then_Statements => Elab_Code)); end if; + Analyze_List (Result, Suppress => All_Checks); return Result; end Make_DT; - --------------------------- - -- Make_DT_Access_Action -- - --------------------------- - - function Make_DT_Access_Action - (Typ : Entity_Id; - Action : DT_Access_Action; - Args : List_Id) return Node_Id - is - Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); - Loc : Source_Ptr; - - begin - if No (Args) then - - -- This is a constant - - return New_Reference_To (Action_Name, Sloc (Typ)); - end if; - - pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); - - Loc := Sloc (First (Args)); - - if Action_Is_Proc (Action) then - return - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Action_Name, Loc), - Parameter_Associations => Args); - - else - return - Make_Function_Call (Loc, - Name => New_Reference_To (Action_Name, Loc), - Parameter_Associations => Args); - end if; - end Make_DT_Access_Action; - - ----------------------- - -- Make_Secondary_DT -- - ----------------------- - - procedure Make_Secondary_DT - (Typ : Entity_Id; - Ancestor_Typ : Entity_Id; - Suffix_Index : Nat; - Iface : Entity_Id; - AI_Tag : Entity_Id; - Acc_Disp_Tables : in out Elist_Id; - Result : out List_Id) - is - Loc : constant Source_Ptr := Sloc (AI_Tag); - Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); - Name_DT : constant Name_Id := New_Internal_Name ('T'); - Empty_DT : Boolean := False; - Iface_DT : Node_Id; - Iface_DT_Ptr : Node_Id; - Name_DT_Ptr : Name_Id; - Nb_Prim : Nat; - OSD : Entity_Id; - Size_Expr_Node : Node_Id; - Tname : Name_Id; - - begin - Result := New_List; - - -- Generate a unique external name associated with the secondary - -- dispatch table. This external name will be used to declare an - -- access to this secondary dispatch table, value that will be used - -- for the elaboration of Typ's objects and also for the elaboration - -- of objects of any derivation of Typ that do not override any - -- primitive operation of Typ. - - Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index); - - Tname := Name_Find; - Name_DT_Ptr := New_External_Name (Tname, "P"); - Iface_DT := Make_Defining_Identifier (Loc, Name_DT); - Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); - - -- Dispatch table and related entities are allocated statically - - Set_Ekind (Iface_DT, E_Variable); - Set_Is_Statically_Allocated (Iface_DT); - - Set_Ekind (Iface_DT_Ptr, E_Variable); - Set_Is_Statically_Allocated (Iface_DT_Ptr); - - -- Generate code to create the storage for the Dispatch_Table object. - -- If the number of primitives of Typ is 0 we reserve a dummy single - -- entry for its DT because at run-time the pointer to this dummy entry - -- will be used as the tag. - - Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); - - if Nb_Prim = 0 then - Empty_DT := True; - Nb_Prim := 1; - end if; - - -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); - -- for DT'Alignment use Address'Alignment - - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc), - Right_Opnd => - Make_Op_Multiply (Loc, - Left_Opnd => - New_Reference_To (RTE (RE_DT_Entry_Size), Loc), - Right_Opnd => - Make_Integer_Literal (Loc, Nb_Prim))); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Iface_DT, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Size_Expr_Node)))))); - - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (Iface_DT, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); - - -- Generate code to create the pointer to the dispatch table - - -- Iface_DT_Ptr : Tag := Tag!(DT'Address); - - -- According to the C++ ABI, the base of the vtable is located - -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. - -- Hence, move the pointer down to the real base of the vtable. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Iface_DT_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To (Generalized_Tag, Loc), - Expression => - Unchecked_Convert_To (Generalized_Tag, - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Iface_DT, Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))))); - - -- Note: Offset_To_Top will be initialized by the init subprogram - - -- Set Access_Disp_Table field to be the dispatch table pointer - - if not (Present (Acc_Disp_Tables)) then - Acc_Disp_Tables := New_Elmt_List; - end if; - - Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); - - -- Step 1: Generate an Object Specific Data (OSD) table - - OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); - - -- Nothing to do if configurable run time does not support the - -- Object_Specific_Data entity. - - if not RTE_Available (RE_Object_Specific_Data) then - Error_Msg_CRT ("abstract interface types", Typ); - return; - end if; - - -- Generate: - -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims); - -- where the constraint is used to allocate space for the - -- non-predefined primitive operations only. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => OSD, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To ( - RTE (RE_Object_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))))); - - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Set_Signature, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Iface_DT_Ptr, Loc)), - New_Reference_To (RTE (RE_Secondary_DT), Loc)))); - - -- Generate: - -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); - - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Set_OSD, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Iface_DT_Ptr, Loc)), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (OSD, Loc), - Attribute_Name => Name_Address)))); - - if Ada_Version >= Ada_05 - and then not Is_Interface (Typ) - and then not Is_Abstract_Type (Typ) - and then not Is_Controlled (Typ) - and then RTE_Available (RE_Set_Tagged_Kind) - and then not Restriction_Active (No_Dispatching_Calls) - then - -- Generate: - -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); - - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Set_Tagged_Kind, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), -- DTptr - New_Reference_To (Iface_DT_Ptr, Loc)), - Tagged_Kind (Typ)))); -- Value - - if not Empty_DT - and then Is_Concurrent_Record_Type (Typ) - and then Has_Abstract_Interfaces (Typ) - then - declare - Prim : Entity_Id; - Prim_Alias : Entity_Id; - Prim_Elmt : Elmt_Id; - - begin - -- Step 2: Populate the OSD table - - Prim_Alias := Empty; - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Present (Abstract_Interface_Alias (Prim)) - and then Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)) = Iface - then - Prim_Alias := Abstract_Interface_Alias (Prim); - - -- Generate: - -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr), - -- Secondary_DT_Pos, Primary_DT_pos); - - Append_To (Result, - Make_DT_Access_Action (Iface, - Action => Set_Offset_Index, - Args => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Iface_DT_Ptr, Loc)), - Make_Integer_Literal (Loc, - DT_Position (Prim_Alias)), - Make_Integer_Literal (Loc, - DT_Position (Alias (Prim)))))); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end; - end if; - end if; - end Make_Secondary_DT; - ------------------------------------- -- Make_Select_Specific_Data_Table -- ------------------------------------- @@ -3817,12 +4506,12 @@ package body Exp_Disp is -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); Append_To (Assignments, - Make_DT_Access_Action (Typ, - Action => Set_Prim_Op_Kind, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Prim_Pos), - Prim_Op_Kind (Alias (Prim), Typ)))); + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Prim_Op_Kind (Alias (Prim), Typ)))); -- Retrieve the root of the alias chain @@ -3842,14 +4531,14 @@ package body Exp_Disp is -- (DT_Ptr, <position>, <index>); Append_To (Assignments, - Make_DT_Access_Action (Typ, - Action => Set_Entry_Index, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Prim_Pos), - Make_Integer_Literal (Loc, - Find_Entry_Index - (Wrapped_Entity (Prim_Als)))))); + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Entry_Index), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, + Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); end if; end if; @@ -3973,6 +4662,123 @@ package body Exp_Disp is end if; end Prim_Op_Kind; + ------------------------ + -- Register_Primitive -- + ------------------------ + + procedure Register_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id; + Ins_Nod : Node_Id) + is + DT_Ptr : Entity_Id; + Iface_Prim : Entity_Id; + Iface_Typ : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Pos : Uint; + Tag : Entity_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; + Typ : Entity_Id; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if not RTE_Available (RE_Tag) then + return; + end if; + + if not Present (Abstract_Interface_Alias (Prim)) then + Typ := Scope (DTC_Entity (Prim)); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Pos := DT_Position (Prim); + Tag := First_Tag_Component (Typ); + + if Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim) + then + Insert_After (Ins_Nod, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Position => Pos, + Address_Node => Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + + Insert_After (Ins_Nod, + Build_Set_Prim_Op_Address (Loc, + Typ => Typ, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Position => Pos, + Address_Node => Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end if; + + -- Ada 2005 (AI-251): Primitive associated with an interface type + -- Generate the code of the thunk only if the interface type is not an + -- immediate ancestor of Typ; otherwise the dispatch table associated + -- with the interface is the primary dispatch table and we have nothing + -- else to do here. + + else + Typ := Find_Dispatching_Type (Alias (Prim)); + Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); + + pragma Assert (Is_Interface (Iface_Typ)); + + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Alias (Prim), + Thunk_Id => Thunk_Id, + Thunk_Code => Thunk_Code); + + if not Is_Parent (Iface_Typ, Typ) + and then Present (Thunk_Code) + then + Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); + + -- Generate the code necessary to fill the appropriate entry of + -- the secondary dispatch table of Prim's controlling type with + -- Thunk_Id's address. + + Iface_DT_Ptr := Find_Interface_ADT (Typ, Iface_Typ); + Iface_Prim := Abstract_Interface_Alias (Prim); + Pos := DT_Position (Iface_Prim); + Tag := First_Tag_Component (Iface_Typ); + + if Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim) + then + Insert_Action (Ins_Nod, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Position => Pos, + Address_Node => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + else + pragma Assert (Pos /= Uint_0 + and then Pos <= DT_Entry_Count (Tag)); + + Insert_Action (Ins_Nod, + Build_Set_Prim_Op_Address (Loc, + Typ => Iface_Typ, + Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Position => Pos, + Address_Node => Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + end if; + end if; + end if; + end Register_Primitive; + ------------------------- -- Set_All_DT_Position -- ------------------------- @@ -4112,21 +4918,7 @@ package body Exp_Disp is Count_Prim := Count_Prim + 1; end if; - -- Ada 2005 (AI-251) - - if Present (Abstract_Interface_Alias (Prim)) - and then Is_Interface - (Find_Dispatching_Type - (Abstract_Interface_Alias (Prim))) - then - Set_DTC_Entity (Prim, - Find_Interface_Tag - (T => Typ, - Iface => Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)))); - else - Set_DTC_Entity (Prim, The_Tag); - end if; + Set_DTC_Entity_Value (Typ, Prim); -- Clear any previous value of the DT_Position attribute. In this -- way we ensure that the final position of all the primitives is @@ -4142,10 +4934,70 @@ package body Exp_Disp is := (others => False); E : Entity_Id; + procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); + -- Called if Typ is declared in a nested package or a public child + -- package to handle inherited primitives that were inherited by Typ + -- in the visible part, but whose declaration was deferred because + -- the parent operation was private and not visible at that point. + procedure Set_Fixed_Prim (Pos : Nat); -- Sets to true an element of the Fixed_Prim table to indicate -- that this entry of the dispatch table of Typ is occupied. + ------------------------------------------ + -- Handle_Inherited_Private_Subprograms -- + ------------------------------------------ + + procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is + Op_List : Elist_Id; + Op_Elmt : Elmt_Id; + Op_Elmt_2 : Elmt_Id; + Prim_Op : Entity_Id; + Parent_Subp : Entity_Id; + + begin + Op_List := Primitive_Operations (Typ); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Prim_Op := Node (Op_Elmt); + + -- Search primitives that are implicit operations with an + -- internal name whose parent operation has a normal name. + + if Present (Alias (Prim_Op)) + and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ + and then not Comes_From_Source (Prim_Op) + and then Is_Internal_Name (Chars (Prim_Op)) + and then not Is_Internal_Name (Chars (Alias (Prim_Op))) + then + Parent_Subp := Alias (Prim_Op); + + -- Check if the type has an explicit overriding for this + -- primitive. + + Op_Elmt_2 := Next_Elmt (Op_Elmt); + while Present (Op_Elmt_2) loop + if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) + and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) + then + Set_DT_Position (Prim_Op, DT_Position (Parent_Subp)); + Set_DT_Position (Node (Op_Elmt_2), + DT_Position (Parent_Subp)); + Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); + + goto Next_Primitive; + end if; + + Next_Elmt (Op_Elmt_2); + end loop; + end if; + + <<Next_Primitive>> + Next_Elmt (Op_Elmt); + end loop; + end Handle_Inherited_Private_Subprograms; + -------------------- -- Set_Fixed_Prim -- -------------------- @@ -4160,6 +5012,22 @@ package body Exp_Disp is end Set_Fixed_Prim; begin + -- In case of nested packages and public child package it may be + -- necessary a special management on inherited subprograms so that + -- the dispatch table is properly filled. + + if Ekind (Scope (Scope (Typ))) = E_Package + and then Scope (Scope (Typ)) /= Standard_Standard + and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) + or else + (Nkind (Parent (Typ)) = N_Private_Extension_Declaration + and then Is_Generic_Type (Typ))) + and then In_Open_Scopes (Scope (Etype (Typ))) + and then Typ = Base_Type (Typ) + then + Handle_Inherited_Private_Subprograms (Typ); + end if; + -- Second stage: Register fixed entries Nb_Prim := 0; @@ -4203,7 +5071,7 @@ package body Exp_Disp is Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the - -- overriden primitive + -- overriden primitive. elsif not Present (Abstract_Interface_Alias (Prim)) and then Present (Alias (Prim)) @@ -4402,19 +5270,14 @@ package body Exp_Disp is Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); - -- The derived type must have at least as many components as its - -- parent (for root types, the Etype points back to itself - -- and the test should not fail) - - -- This test fails compiling the partial view of a tagged type - -- derived from an interface which defines the overriding subprogram - -- in the private part. This needs further investigation??? + -- The derived type must have at least as many components as its parent + -- (for root types, the Etype points back to itself and the test cannot + -- fail) - if not Has_Private_Declaration (Typ) then - pragma Assert ( - DT_Entry_Count (The_Tag) >= - DT_Entry_Count (First_Tag_Component (Parent_Typ))); - null; + if DT_Entry_Count (The_Tag) < + DT_Entry_Count (First_Tag_Component (Parent_Typ)) + then + raise Program_Error; end if; end Set_All_DT_Position; @@ -4470,6 +5333,31 @@ package body Exp_Disp is end if; end Set_Default_Constructor; + -------------------------- + -- Set_DTC_Entity_Value -- + -------------------------- + + procedure Set_DTC_Entity_Value + (Tagged_Type : Entity_Id; + Prim : Entity_Id) + is + begin + if Present (Abstract_Interface_Alias (Prim)) + and then Is_Interface + (Find_Dispatching_Type + (Abstract_Interface_Alias (Prim))) + then + Set_DTC_Entity (Prim, + Find_Interface_Tag + (T => Tagged_Type, + Iface => Find_Dispatching_Type + (Abstract_Interface_Alias (Prim)))); + else + Set_DTC_Entity (Prim, + First_Tag_Component (Tagged_Type)); + end if; + end Set_DTC_Entity_Value; + ----------------- -- Tagged_Kind -- ----------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 7314ae255e3..32cde2f6302 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -111,7 +111,7 @@ package Exp_Disp is -- interfaces, not generated for the rest of the cases. See Expand_N_ -- Timed_Entry_Call for more information. - -- Lifecycle of predefined primitive operations + -- Life cycle of predefined primitive operations -- The specifications and bodies of the PPOs are created by -- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies @@ -122,16 +122,14 @@ package Exp_Disp is -- PPOs are collected and added to the Primitive_Operations list of -- a type by the regular analysis mechanism. - -- PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3. + -- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze. - -- Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a - -- call to Register_Predefined_DT_Entry, also in Exp_Ch6. + -- Thunks for PPOs are created by Make_DT. - -- Dispatch table positions of PPOs are set in Set_All_DT_Position in - -- Exp_Disp. + -- Dispatch table positions of PPOs are set by Set_All_DT_Position. - -- Calls to PPOs procede as regular dispatching calls. If the PPO - -- has a thunk, a call procedes as a regular dispatching call with + -- Calls to PPOs proceed as regular dispatching calls. If the PPO + -- has a thunk, a call proceeds as a regular dispatching call with -- a thunk. -- Guidelines for addition of new predefined primitive operations @@ -167,21 +165,6 @@ package Exp_Disp is -- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Set_All_DT_Position - direct use - type DT_Access_Action is - (IW_Membership, - Get_Entry_Index, - Get_Prim_Op_Kind, - Get_Tagged_Kind, - Register_Interface_Tag, - Register_Tag, - Set_Entry_Index, - Set_Offset_Index, - Set_OSD, - Set_Prim_Op_Kind, - Set_Signature, - Set_SSD, - Set_Tagged_Kind); - procedure Expand_Dispatching_Call (Call_Node : Node_Id); -- Expand the call to the operation through the dispatch table and perform -- the required tag checks when appropriate. For CPP types tag checks are @@ -198,41 +181,22 @@ package Exp_Disp is -- the object to give access to the interface tag associated with the -- secondary dispatch table. - function Expand_Interface_Thunk + procedure Expand_Interface_Thunk (N : Node_Id; Thunk_Alias : Node_Id; - Thunk_Id : Entity_Id) return Node_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id); -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- generate additional subprograms (thunks) to have a layout compatible -- with the C++ ABI. The thunk modifies the value of the first actual of -- the call (that is, the pointer to the object) before transferring -- control to the target function. - - function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id) return Node_Id; - -- Generate the code necessary to fill the appropriate entry of the - -- dispatch table of Prim's controlling type with Prim's address. - - function Fill_Secondary_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id; - Thunk_Id : Entity_Id; - Iface_DT_Ptr : Entity_Id) return Node_Id; - -- (Ada 2005): Generate the code necessary to fill the appropriate entry of - -- the secondary dispatch table of Prim's controlling type with Thunk_Id's - -- address. - - function Make_DT_Access_Action - (Typ : Entity_Id; - Action : DT_Access_Action; - Args : List_Id) return Node_Id; - -- Generate a call to one of the Dispatch Table Access Subprograms defined - -- in Ada.Tags or in Interfaces.Cpp + -- + -- Required in 3.4 case, why ??? giant comment needed for any gcc + -- specific code ??? function Make_DT (Typ : Entity_Id) return List_Id; - -- Expand the declarations for the Dispatch Table (or the Vtable in - -- the case of type whose ancestor is a CPP_Class) + -- Expand the declarations for the Dispatch Table. function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id; @@ -284,8 +248,8 @@ package Exp_Disp is function Make_Disp_Timed_Select_Body (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the body of the primitive operation of type - -- Typ used for dispatching in timed selects. Generate a null body if Nul - -- is an interface type. + -- Typ used for dispatching in timed selects. Generates a body containing + -- a single null-statement if Typ is an interface type. function Make_Disp_Timed_Select_Spec (Typ : Entity_Id) return Node_Id; @@ -299,20 +263,19 @@ package Exp_Disp is -- selects. Generate code to set the primitive operation kinds and entry -- indices of primitive operations and primitive wrappers. - procedure Make_Secondary_DT - (Typ : Entity_Id; - Ancestor_Typ : Entity_Id; - Suffix_Index : Nat; - Iface : Entity_Id; - AI_Tag : Entity_Id; - Acc_Disp_Tables : in out Elist_Id; - Result : out List_Id); - -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch - -- Table of Typ associated with Iface (each abstract interface implemented - -- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ - -- and Suffix_Index are used to generate an unique external name which - -- is added at the end of Acc_Disp_Tables; this external name will be - -- used later by the subprogram Exp_Ch3.Build_Init_Procedure. + procedure Register_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id; + Ins_Nod : Node_Id); + -- Register Prim in the corresponding primary or secondary dispatch table. + -- If Prim is associated with a secondary dispatch table then generate also + -- its thunk and register it in the associated secondary dispatch table. + -- In general the dispatch tables are always generated by Make_DT and + -- Make_Secondary_DT; this routine is only used in two corner cases: + -- 1) To construct the dispatch table of a tagged type whose parent + -- is a CPP_Class (see Build_Init_Procedure). + -- 2) To handle late overriding of dispatching operations (see + -- Check_Dispatching_Operation). procedure Set_All_DT_Position (Typ : Entity_Id); -- Set the DT_Position field for each primitive operation. In the CPP @@ -324,6 +287,12 @@ package Exp_Disp is -- be the default constructor (i.e. the function returning this type, -- having a pragma CPP_Constructor and no parameter) + procedure Set_DTC_Entity_Value + (Tagged_Type : Entity_Id; + Prim : Entity_Id); + -- Set the definite value of the DTC_Entity value associated with a given + -- primitive of a tagged type. + procedure Write_DT (Typ : Entity_Id); pragma Export (Ada, Write_DT); -- Debugging procedure (to be called within gdb) diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 9f8993b2961..af2163d3ff6 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -541,7 +541,15 @@ package body Rtsfind is Output_Entity_Name (Id, "not available"); end if; - raise RE_Not_Available; + -- In configurable run time mode, we raise RE_Not_Available, and we hope + -- the caller deals gracefully with this. If we are in normal full run + -- time mode, a load failure is considered fatal and unrecoverable. + + if Configurable_Run_Time_Mode then + raise RE_Not_Available; + else + raise Unrecoverable_Error; + end if; end Load_Fail; -------------- @@ -683,12 +691,24 @@ package body Rtsfind is Set_Analyzed (Cunit (Current_Sem_Unit), True); if not Analyzed (Cunit (U.Unum)) then - Save_Private_Visibility; - Semantics (Cunit (U.Unum)); - Restore_Private_Visibility; - if Fatal_Error (U.Unum) then - Load_Fail ("had semantic errors", U_Id, Id); + -- If the unit is already loaded through a limited_with clauses, + -- the relevant entities must already be available. We do not + -- want to load and analyze the unit because this would create + -- a real semantic dependence when the purpose of the limited_with + -- is precisely to avoid such. + + if From_With_Type (Cunit_Entity (U.Unum)) then + null; + + else + Save_Private_Visibility; + Semantics (Cunit (U.Unum)); + Restore_Private_Visibility; + + if Fatal_Error (U.Unum) then + Load_Fail ("had semantic errors", U_Id, Id); + end if; end if; end if; @@ -891,7 +911,8 @@ package body Rtsfind is ----------------------- function Find_Local_Entity (E : RE_Id) return Entity_Id is - RE_Str : String renames RE_Id'Image (E); + RE_Str : constant String := RE_Id'Image (E); + Nam : Name_Id; Ent : Entity_Id; Save_Nam : constant String := Name_Buffer (1 .. Name_Len); @@ -902,7 +923,8 @@ package body Rtsfind is Name_Buffer (1 .. Name_Len) := RE_Str (RE_Str'First + 3 .. RE_Str'Last); - Ent := Entity_Id (Get_Name_Table_Info (Name_Find)); + Nam := Name_Find; + Ent := Entity_Id (Get_Name_Table_Info (Nam)); Name_Len := Save_Nam'Length; Name_Buffer (1 .. Name_Len) := Save_Nam; @@ -956,9 +978,16 @@ package body Rtsfind is pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); Ename := RE_Chars (E); - -- First we search the package entity chain + -- First we search the package entity chain. If the package + -- only has a limited view, scan the corresponding list of + -- incomplete types. + + if From_With_Type (U.Entity) then + Pkg_Ent := First_Entity (Limited_View (U.Entity)); + else + Pkg_Ent := First_Entity (U.Entity); + end if; - Pkg_Ent := First_Entity (U.Entity); while Present (Pkg_Ent) loop if Ename = Chars (Pkg_Ent) then RE_Table (E) := Pkg_Ent; @@ -1067,6 +1096,7 @@ package body Rtsfind is U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); E1 : Entity_Id; Ename : Name_Id; + Found_E : Entity_Id; Lib_Unit : Node_Id; Pkg_Ent : Entity_Id; @@ -1103,13 +1133,15 @@ package body Rtsfind is -- Search the entity in the components of record type declarations -- found in the package entity chain. + Found_E := Empty; Pkg_Ent := First_Entity (U.Entity); Search : while Present (Pkg_Ent) loop if Is_Record_Type (Pkg_Ent) then E1 := First_Entity (Pkg_Ent); while Present (E1) loop if Ename = Chars (E1) then - exit Search; + pragma Assert (not Present (Found_E)); + Found_E := E1; end if; Next_Entity (E1); @@ -1157,7 +1189,7 @@ package body Rtsfind is end if; Front_End_Inlining := Save_Front_End_Inlining; - return Check_CRT (E, E1); + return Check_CRT (E, Found_E); end RTE_Record_Component; ------------------------------------ @@ -1366,6 +1398,12 @@ package body Rtsfind is end if; end loop; end if; + + exception + -- Generate error message if run-time unit not available + + when RE_Not_Available => + Error_Msg_N ("& not available", Nam); end Text_IO_Kludge; end Rtsfind; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 81a8f34ead0..cb59e71cc87 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -184,6 +184,7 @@ package Rtsfind is -- Children of System + System_Address_Image, System_Arith_64, System_AST_Handling, System_Assertions, @@ -201,6 +202,7 @@ package Rtsfind is System_Compare_Array_Unsigned_8, System_DSA_Services, System_Exception_Table, + System_Exceptions, System_Exn_Int, System_Exn_LLF, System_Exn_LLI, @@ -399,7 +401,7 @@ package Rtsfind is -- Range of values for children of Interfaces subtype System_Child is RTU_Id - range System_Arith_64 .. System_Tasking_Stages; + range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System subtype System_Tasking_Child is System_Child @@ -456,11 +458,11 @@ package Rtsfind is RE_Exception_Message, -- Ada.Exceptions RE_Exception_Name_Simple, -- Ada.Exceptions RE_Exception_Occurrence, -- Ada.Exceptions - RE_Local_Raise, -- Ada.Exceptions RE_Null_Occurrence, -- Ada.Exceptions RE_Poll, -- Ada.Exceptions RE_Raise_Exception, -- Ada.Exceptions RE_Raise_Exception_Always, -- Ada.Exceptions + RE_Raise_From_Controlled_Operation, -- Ada.Exceptions RE_Reraise_Occurrence, -- Ada.Exceptions RE_Reraise_Occurrence_Always, -- Ada.Exceptions RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions @@ -485,42 +487,45 @@ package Rtsfind is RE_Stream_Access, -- Ada.Streams.Stream_IO - RE_Abstract_Interface, -- Ada.Tags RE_Access_Level, -- Ada.Tags + RE_Address_Array, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags RE_Base_Address, -- Ada.Tags RE_Cstring_Ptr, -- Ada.Tags RE_Default_Prim_Op_Count, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags RE_Dispatch_Table, -- Ada.Tags + RE_Dispatch_Table_Wrapper, -- Ada.Tags RE_Displace, -- Ada.Tags - RE_DT_Entry_Size, -- Ada.Tags - RE_DT_Min_Prologue_Size, -- Ada.Tags - RE_DT_Prologue_Size, -- Ada.Tags + RE_DT, -- Ada.Tags + RE_DT_Predef_Prims_Offset, -- Ada.Tags RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags RE_Expanded_Name, -- Ada.Tags RE_External_Tag, -- Ada.Tags + RE_HT_Link, -- Ada.Tags RO_TA_External_Tag, -- Ada.Tags RE_Get_Access_Level, -- Ada.Tags RE_Get_Entry_Index, -- 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 - RE_Get_Remotely_Callable, -- Ada.Tags RE_Get_Tagged_Kind, -- Ada.Tags RE_Idepth, -- Ada.Tags + RE_Iface_Tag, -- Ada.Tags RE_Ifaces_Table, -- Ada.Tags - RE_Ifaces_Table_Ptr, -- Ada.Tags + RE_Interfaces_Table, -- Ada.Tags RE_Interface_Data, -- Ada.Tags - RE_Interface_Data_Ptr, -- Ada.Tags RE_Interface_Tag, -- Ada.Tags RE_IW_Membership, -- Ada.Tags RE_Nb_Ifaces, -- Ada.Tags + RE_No_Dispatch_Table_Wrapper, -- Ada.Tags + RE_NDT_Prims_Ptr, -- Ada.Tags + RE_NDT_TSD, -- Ada.Tags + RE_Num_Prims, -- Ada.Tags RE_Object_Specific_Data, -- Ada.Tags RE_Offset_To_Top, -- Ada.Tags - RE_Type_Specific_Data, -- Ada.Tags + RE_Offset_To_Top_Function_Ptr, -- Ada.Tags + RE_OSD_Table, -- Ada.Tags + RE_OSD_Num_Prims, -- Ada.Tags RE_POK_Function, -- Ada.Tags RE_POK_Procedure, -- Ada.Tags RE_POK_Protected_Entry, -- Ada.Tags @@ -529,34 +534,29 @@ package Rtsfind is RE_POK_Task_Entry, -- Ada.Tags RE_POK_Task_Function, -- Ada.Tags RE_POK_Task_Procedure, -- Ada.Tags + RE_Predef_Prims, -- Ada.Tags + RE_Predef_Prims_Table_Ptr, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags - RE_Primary_DT, -- Ada.Tags RE_Prims_Ptr, -- Ada.Tags - RE_Register_Interface_Tag, -- Ada.Tags + RE_Primary_DT, -- Ada.Tags + RE_Signature, -- Ada.Tags + RE_SSD, -- Ada.Tags + RE_TSD, -- Ada.Tags + RE_Type_Specific_Data, -- Ada.Tags RE_Register_Tag, -- Ada.Tags - RE_Remotely_Callable, -- Ada.Tags + RE_Transportable, -- Ada.Tags RE_RC_Offset, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags - RE_Set_Access_Level, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags - RE_Set_Expanded_Name, -- Ada.Tags - RE_Set_Num_Prim_Ops, -- Ada.Tags - 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_Static_Offset_To_Top, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags + RE_Tag_Kind, -- Ada.Tags RE_Tag_Ptr, -- Ada.Tags + RE_Tag_Table, -- Ada.Tags RE_Tags_Table, -- Ada.Tags RE_Tagged_Kind, -- Ada.Tags RE_Type_Specific_Data_Ptr, -- Ada.Tags @@ -599,6 +599,8 @@ package Rtsfind is RE_Null_Address, -- System RE_Priority, -- System + RE_Address_Image, -- System.Address_Image + RE_Add_With_Ovflo_Check, -- System.Arith_64 RE_Double_Divide, -- System.Arith_64 RE_Multiply_With_Ovflo_Check, -- System.Arith_64 @@ -607,6 +609,7 @@ package Rtsfind is RE_Create_AST_Handler, -- System.AST_Handling + RE_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions RE_AST_Handler, -- System.Aux_DEC @@ -663,6 +666,8 @@ package Rtsfind is RE_Register_Exception, -- System.Exception_Table + RE_Local_Raise, -- System.Exceptions + RE_Exn_Integer, -- System.Exn_Int RE_Exn_Long_Long_Float, -- System.Exn_LLF @@ -1231,6 +1236,7 @@ package Rtsfind is RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements + RE_Dummy_Communication_Block, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools RE_Allocate_Any, -- System_Storage_Pools, @@ -1333,11 +1339,6 @@ package Rtsfind is RE_Get_GNAT_Exception, -- System.Soft_Links RE_Update_Exception, -- System.Soft_Links - RE_ATSD, -- System.Threads - RE_Thread_Body_Enter, -- System.Threads - RE_Thread_Body_Exceptional_Exit, -- System.Threads - RE_Thread_Body_Leave, -- System.Threads - RE_Bits_1, -- System.Unsigned_Types RE_Bits_2, -- System.Unsigned_Types RE_Bits_4, -- System.Unsigned_Types @@ -1563,11 +1564,11 @@ package Rtsfind is RE_Exception_Message => Ada_Exceptions, RE_Exception_Name_Simple => Ada_Exceptions, RE_Exception_Occurrence => Ada_Exceptions, - RE_Local_Raise => Ada_Exceptions, RE_Null_Occurrence => Ada_Exceptions, RE_Poll => Ada_Exceptions, RE_Raise_Exception => Ada_Exceptions, RE_Raise_Exception_Always => Ada_Exceptions, + RE_Raise_From_Controlled_Operation => Ada_Exceptions, RE_Reraise_Occurrence => Ada_Exceptions, RE_Reraise_Occurrence_Always => Ada_Exceptions, RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, @@ -1592,42 +1593,45 @@ package Rtsfind is RE_Stream_Access => Ada_Streams_Stream_IO, - RE_Abstract_Interface => Ada_Tags, RE_Access_Level => Ada_Tags, + RE_Address_Array => Ada_Tags, RE_Addr_Ptr => Ada_Tags, RE_Base_Address => Ada_Tags, RE_Cstring_Ptr => Ada_Tags, RE_Default_Prim_Op_Count => Ada_Tags, RE_Descendant_Tag => Ada_Tags, RE_Dispatch_Table => Ada_Tags, + RE_Dispatch_Table_Wrapper => Ada_Tags, RE_Displace => Ada_Tags, - RE_DT_Entry_Size => Ada_Tags, - RE_DT_Min_Prologue_Size => Ada_Tags, - RE_DT_Prologue_Size => Ada_Tags, + RE_DT => Ada_Tags, + RE_DT_Predef_Prims_Offset => Ada_Tags, RE_DT_Typeinfo_Ptr_Size => Ada_Tags, RE_Expanded_Name => Ada_Tags, RE_External_Tag => Ada_Tags, + RE_HT_Link => Ada_Tags, RO_TA_External_Tag => Ada_Tags, RE_Get_Access_Level => Ada_Tags, RE_Get_Entry_Index => 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, - RE_Get_Remotely_Callable => Ada_Tags, RE_Get_Tagged_Kind => Ada_Tags, RE_Idepth => Ada_Tags, + RE_Iface_Tag => Ada_Tags, RE_Ifaces_Table => Ada_Tags, - RE_Ifaces_Table_Ptr => Ada_Tags, + RE_Interfaces_Table => Ada_Tags, RE_Interface_Data => Ada_Tags, - RE_Interface_Data_Ptr => Ada_Tags, RE_Interface_Tag => Ada_Tags, RE_IW_Membership => Ada_Tags, RE_Nb_Ifaces => Ada_Tags, + RE_No_Dispatch_Table_Wrapper => Ada_Tags, + RE_NDT_Prims_Ptr => Ada_Tags, + RE_NDT_TSD => Ada_Tags, + RE_Num_Prims => Ada_Tags, RE_Object_Specific_Data => Ada_Tags, RE_Offset_To_Top => Ada_Tags, - RE_Type_Specific_Data => Ada_Tags, + RE_Offset_To_Top_Function_Ptr => Ada_Tags, + RE_OSD_Table => Ada_Tags, + RE_OSD_Num_Prims => Ada_Tags, RE_POK_Function => Ada_Tags, RE_POK_Procedure => Ada_Tags, RE_POK_Protected_Entry => Ada_Tags, @@ -1636,34 +1640,29 @@ package Rtsfind is RE_POK_Task_Entry => Ada_Tags, RE_POK_Task_Function => Ada_Tags, RE_POK_Task_Procedure => Ada_Tags, + RE_Predef_Prims => Ada_Tags, + RE_Predef_Prims_Table_Ptr => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, - RE_Primary_DT => Ada_Tags, RE_Prims_Ptr => Ada_Tags, - RE_Register_Interface_Tag => Ada_Tags, + RE_Primary_DT => Ada_Tags, + RE_Signature => Ada_Tags, + RE_SSD => Ada_Tags, + RE_TSD => Ada_Tags, + RE_Type_Specific_Data => Ada_Tags, RE_Register_Tag => Ada_Tags, - RE_Remotely_Callable => Ada_Tags, + RE_Transportable => Ada_Tags, RE_RC_Offset => Ada_Tags, RE_Secondary_DT => Ada_Tags, RE_Select_Specific_Data => Ada_Tags, - RE_Set_Access_Level => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, - RE_Set_Expanded_Name => Ada_Tags, - RE_Set_Num_Prim_Ops => Ada_Tags, - 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_Static_Offset_To_Top => Ada_Tags, RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, + RE_Tag_Kind => Ada_Tags, RE_Tag_Ptr => Ada_Tags, + RE_Tag_Table => Ada_Tags, RE_Tags_Table => Ada_Tags, RE_Tagged_Kind => Ada_Tags, RE_Type_Specific_Data_Ptr => Ada_Tags, @@ -1704,6 +1703,8 @@ package Rtsfind is RE_Null_Address => System, RE_Priority => System, + RE_Address_Image => System_Address_Image, + RE_Add_With_Ovflo_Check => System_Arith_64, RE_Double_Divide => System_Arith_64, RE_Multiply_With_Ovflo_Check => System_Arith_64, @@ -1712,6 +1713,7 @@ package Rtsfind is RE_Create_AST_Handler => System_AST_Handling, + RE_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions, RE_AST_Handler => System_Aux_DEC, @@ -1768,6 +1770,8 @@ package Rtsfind is RE_Register_Exception => System_Exception_Table, + RE_Local_Raise => System_Exceptions, + RE_Exn_Integer => System_Exn_Int, RE_Exn_Long_Long_Float => System_Exn_LLF, @@ -2336,6 +2340,7 @@ package Rtsfind is RE_Storage_Offset => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements, RE_To_Address => System_Storage_Elements, + RE_Dummy_Communication_Block => System_Storage_Elements, RE_Root_Storage_Pool => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools, @@ -2438,11 +2443,6 @@ package Rtsfind is RE_Get_GNAT_Exception => System_Soft_Links, RE_Update_Exception => System_Soft_Links, - RE_ATSD => System_Threads, - RE_Thread_Body_Enter => System_Threads, - RE_Thread_Body_Exceptional_Exit => System_Threads, - RE_Thread_Body_Leave => System_Threads, - RE_Bits_1 => System_Unsigned_Types, RE_Bits_2 => System_Unsigned_Types, RE_Bits_4 => System_Unsigned_Types, @@ -2808,9 +2808,9 @@ package Rtsfind is -- construct. function RTE_Available (E : RE_Id) return Boolean; - -- Returns true if a call to RTE will succeed without raising an - -- exception and without generating an error message, i.e. if the - -- call will obtain the desired entity without any problems. + -- Returns true if a call to RTE will succeed without raising an exception + -- and without generating an error message, i.e. if the call will obtain + -- the desired entity without any problems. function RTE_Record_Component (E : RE_Id) return Entity_Id; -- Given the entity defined in the above tables, as identified by the |