diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:20:45 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:20:45 +0000 |
commit | 725a69d2f44aa3e14eef13edfb81f86c87a81bad (patch) | |
tree | 8fbe6b35707fff66b60ba8cb0ee58cc612b2f5af /gcc/ada/a-tags.adb | |
parent | 4775ec6dd2f836d7b36b8e325a06842b3d01020c (diff) | |
download | gcc-725a69d2f44aa3e14eef13edfb81f86c87a81bad.tar.gz |
2007-04-20 Javier Miranda <miranda@adacore.com>
* a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to
the package.
(Object_Specific_Data_Array): This is now internal to the package.
(Object_Specific_Data): This is now internal to the package.
(Select_Specific_Data_Element): This is now internal to the package.
(Select_Specific_Data_Array): This is now internal to the package.
(Select_Specific_Data): This is now internal to the package.
(Offset_To_Top_Function_Ptr): This is now public.
(To_Offset_To_Top_Function_Ptr): Removed.
(Storage_Offset_Ptr,To_Storage_Offset_Ptr): These declarations are now
local to subprogram Offset_To_Top.
(Predefined_DT): Removed.
(Typeinfo_Ptr): Removed.
(OSD): This function is now internal to this package.
(SSD): This function is now internal to this package.
(DT): New function that displaces the pointer to the table of primitives
to get access to the enclosing wrapper record.
(IW_Membership): Code cleanup.
(Offset_To_Top): Code cleanup.
(Predefined_DT): Removed.
(Register_Interface_Tag): Removed.
(Set_Interface_Table): Removed.
(Set_Offset_Index): Removed.
(Set_Offset_To_Top): Code cleanup.
(Set_OSD): Removed.
(Set_Signature): Removed.
(Set_SSD): Removed.
(Set_Tagged_Kind): Removed.
(Typeinfo_Ptr): Removed.
(TSD): Removed.
(Displace): Add missing check on null actual.
* exp_disp.ads, exp_disp.adb
(Select_Expansion_Utilities): Removed.
(Build_Common_Dispatching_Select_Statements): Moved to exp_atags.
(Expand_Dispatching_Call): Update calls to Get_Prim_Op_Address because
the interface requires a new parameter.
(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Replace
calls to subprograms Build_T, Build_S, etc. by the corresponding code.
Done to remove package Select_Expansion_Utilities.
(Make_DT): New implementation for statically allocated dispatch tables.
(Make_Secondary_DT): Moved to the scope of Make_DT.
(Register_Primitive): Code cleanup plus incoporate the use of the new
function DT_Address_Attribute.
(Expand_Interface_Thunk): The profile of this subprogram has been
changed to return the Thunk_Id and the corresponding code.
(Fill_DT_Entry): Removed. Its functionality is now provided by
subprogram Register_Primitive.
(Fill_Secondary_DT_Entry): Removed. Its functionality is now provided by
subprogram Register_Primitive.
(Register_Primitive): New subprogram that incorporates the previous
functionalities of Fill_DT_Entry and Fill_Secondary_DT_Entry.
(Build_Common_Dispatching_Select_Statements): Remove formal Typ. This
was only required to call Make_DT_Access_Action, which is now removed.
(Ada_Actions): Removed
(Action_Is_Proc): Removed
(Action_Nb_Arg): Removed
Replace all the calls to Make_DT_Access_Action by direct calls to
Make_Procedure_Call_Statement or Make_Function_Call.
(Set_DTC_Entity_Value): New subprogram.
(Set_All_DT_Position): Add call to new subprogram Set_DTC_Entity_Value.
(Expand_Interface_Thunk): Add missing support for primitives that are
functions with a controlling result (case in which there is no need
to generate the thunk).
* exp_atag.ads, exp_atag.adb
(Build_DT): New subprogram that displaces the pointer to reference the
base of the wrapper record.
(Build_Typeinfo_Offset): Removed.
(RTE_Tag_Node): Removed.
(Build_Common_Dispatching_Select_Statements): Moved here from exp_disp
(Build_Get_RC_Offset): Removed.
(Build_Inherit_Predefined_Prims): Removed.
(Build_Inherit_TSD: Removed.
(Build_New_TSD): Removed.
(Build_Set_External_Tag): Removed.
(Build_Set_Predefined_Prim_Op_Address): Add documentation.
(Build_Set_Prim_Op_Address): Add documentation.
(Build_Set_TSD): Removed.
* rtsfind.ads, rtsfind.adb
(Load_Fail): If load fails and we are not in configurable run-time
mode, then raise Unrecoverable_Error.
(Text_IO_Kludge): Generate an error message if a run-time library is
not available in a given run-time (ie. zfp run-time).
(RTE_Record_Component): Add code to check that the component we search
for is not found in two records in the given run-time package.
(RE_DT_Offset_To_Top_Size, RE_DT_Predef_Prims_Size): Removed
(RE_DT_Predef_Prims_Offset): New entity
(RE_Static_Offset_To_Top): New entity
(RE_HT_Link): New entity.
(System_Address_Image): Addition of this run-time package.
(RE_Address_Image): New entity.
(RE_Abstract_Interface): Removed.
(RE_Default_Prim_Op_Count): Removed.
(RE_DT_Entry_Size): Removed.
(RE_DT_Min_Prologue_Size): Removed.
(RE_DT_Prologue_Size): Removed.
(RE_Ifaces_Table_Ptr): Removed.
(RE_Interface_Data_Ptr): Removed.
(RE_Type_Specific_Data): Removed.
(RE_Primary_DT): Removed.
(RE_Register_Interface_Tag): Removed.
(RE_Set_Offset_Index): Removed.
(RE_Set_OSD): Removed.
(RE_Set_SSD): Removed.
(RE_Set_Signature): Removed.
(RE_Set_Tagged_Kind): Removed.
(RE_Address_Array): New entity.
(RE_DT): New entity.
(RE_Iface_Tag): New entity.
(RE_Interfaces_Table): New entity.
(RE_No_Dispatch_Table): New entity.
(RE_NDT_Prims_Ptr): New entity.
(RE_NDT_TSD): New entity.
(RE_Num_Prims): New entity.
(RE_Offset_To_Top_Function_Ptr): New entity.
(RE_OSD_Table): New entity.
(RE_OSD_Num_Prims): New entity.
(RE_Predef_Prims): New entity
(RE_Predef_Prims_Table_Ptr): New entity.
(RE_Primary_DT): New entity.
(RE_Signature): New entity.
(RE_SSD): New entity.
(RE_TSD): New entity.
(RE_Type_Specific_Data): New entity.
(RE_Tag_Kind): New entity.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125379 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/a-tags.adb')
-rw-r--r-- | gcc/ada/a-tags.adb | 653 |
1 files changed, 318 insertions, 335 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 -- ------------------------ |