diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/a-tags.adb')
-rw-r--r-- | gcc-4.7/gcc/ada/a-tags.adb | 1049 |
1 files changed, 0 insertions, 1049 deletions
diff --git a/gcc-4.7/gcc/ada/a-tags.adb b/gcc-4.7/gcc/ada/a-tags.adb deleted file mode 100644 index 4731bb909..000000000 --- a/gcc-4.7/gcc/ada/a-tags.adb +++ /dev/null @@ -1,1049 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; -with System.HTable; -with System.Storage_Elements; use System.Storage_Elements; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_StW; use System.WCh_StW; - -pragma Elaborate_All (System.HTable); - -package body Ada.Tags is - - ----------------------- - -- 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. - - function Get_External_Tag (T : Tag) return System.Address; - -- Returns address of a null terminated string containing the external name - - 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. - - 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). - - 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 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. - - 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 - - function To_Address is - new Unchecked_Conversion (Cstring_Ptr, System.Address); - - function To_Cstring_Ptr is - new Unchecked_Conversion (System.Address, Cstring_Ptr); - - -- Disable warnings on possible aliasing problem - - function To_Tag is - new Unchecked_Conversion (Integer_Address, Tag); - - function To_Addr_Ptr is - new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); - - function To_Address is - new Ada.Unchecked_Conversion (Tag, System.Address); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); - - function To_Object_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - - function To_Tag_Ptr is - new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); - - function To_Type_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - - ------------------------------- - -- Inline_Always Subprograms -- - ------------------------------- - - -- 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. - - ------------------- - -- 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 - 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 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; - - ------------------- - -- Is_Primary_DT -- - ------------------- - - 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 -- - ------------------------- - - type HTable_Headers is range 1 .. 64; - - -- The following internal package defines the routines used for the - -- instantiation of a new System.HTable.Static_HTable (see below). See - -- spec in g-htable.ads for details of usage. - - package HTable_Subprograms is - procedure Set_HT_Link (T : Tag; Next : Tag); - function Get_HT_Link (T : Tag) return Tag; - function Hash (F : System.Address) return HTable_Headers; - function Equal (A, B : System.Address) return Boolean; - end HTable_Subprograms; - - package External_Tag_HTable is new System.HTable.Static_HTable ( - Header_Num => HTable_Headers, - Element => Dispatch_Table, - Elmt_Ptr => Tag, - Null_Ptr => null, - Set_Next => HTable_Subprograms.Set_HT_Link, - Next => HTable_Subprograms.Get_HT_Link, - Key => System.Address, - Get_Key => Get_External_Tag, - Hash => HTable_Subprograms.Hash, - Equal => HTable_Subprograms.Equal); - - ------------------------ - -- HTable_Subprograms -- - ------------------------ - - -- Bodies of routines for hash table instantiation - - package body HTable_Subprograms is - - ----------- - -- Equal -- - ----------- - - function Equal (A, B : System.Address) return Boolean is - Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); - Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); - J : Integer := 1; - begin - loop - if Str1 (J) /= Str2 (J) then - return False; - elsif Str1 (J) = ASCII.NUL then - return True; - else - J := J + 1; - end if; - end loop; - end Equal; - - ----------------- - -- Get_HT_Link -- - ----------------- - - 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.HT_Link.all; - end Get_HT_Link; - - ---------- - -- Hash -- - ---------- - - function Hash (F : System.Address) return HTable_Headers is - function H is new System.HTable.Hash (HTable_Headers); - Str : constant Cstring_Ptr := To_Cstring_Ptr (F); - Res : constant HTable_Headers := H (Str (1 .. Length (Str))); - begin - return Res; - end Hash; - - ----------------- - -- Set_HT_Link -- - ----------------- - - 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.HT_Link.all := Next; - end Set_HT_Link; - - end HTable_Subprograms; - - ------------------ - -- Base_Address -- - ------------------ - - function Base_Address (This : System.Address) return System.Address is - begin - return This - Offset_To_Top (This); - end Base_Address; - - --------------- - -- Check_TSD -- - --------------- - - procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is - T : Tag; - - E_Tag_Len : constant Integer := Length (TSD.External_Tag); - E_Tag : String (1 .. E_Tag_Len); - for E_Tag'Address use TSD.External_Tag.all'Address; - pragma Import (Ada, E_Tag); - - Dup_Ext_Tag : constant String := "duplicated external tag """; - - begin - -- Verify that the external tag of this TSD is not registered in the - -- runtime hash table. - - T := External_Tag_HTable.Get (To_Address (TSD.External_Tag)); - - if T /= null then - - -- Avoid concatenation, as it is not allowed in no run time mode - - declare - Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1); - begin - Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag; - Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) := - E_Tag; - Msg (Msg'Last) := '"'; - raise Program_Error with Msg; - end; - end if; - end Check_TSD; - - -------------------- - -- Descendant_Tag -- - -------------------- - - function Descendant_Tag (External : String; Ancestor : Tag) return Tag is - Int_Tag : constant Tag := Internal_Tag (External); - - begin - if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then - raise Tag_Error; - end if; - - return Int_Tag; - end Descendant_Tag; - - -------------- - -- Displace -- - -------------- - - function Displace - (This : System.Address; - T : Tag) return System.Address - is - Iface_Table : Interface_Data_Ptr; - Obj_Base : System.Address; - Obj_DT : Dispatch_Table_Ptr; - Obj_DT_Tag : Tag; - - begin - 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 - if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then - - -- Case of Static value of Offset_To_Top - - if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then - Obj_Base := Obj_Base + - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; - - -- Otherwise call the function generated by the expander to - -- provide the value. - - else - Obj_Base := Obj_Base + - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all - (Obj_Base); - end if; - - return Obj_Base; - end if; - end loop; - end if; - - -- 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_Tag, T) then - return Obj_Base; - end if; - - -- If the object does not implement the interface we must raise CE - - raise Constraint_Error with "invalid interface conversion"; - 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 -- - ------------------- - - -- Canonical implementation of Classwide Membership corresponding to: - - -- Obj in Iface'Class - - -- Each dispatch table contains a table with the tags of all the - -- implemented interfaces. - - -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces - -- that are contained in the dispatch table referenced by Obj'Tag. - - function IW_Membership (This : System.Address; T : Tag) return Boolean is - Iface_Table : Interface_Data_Ptr; - Obj_Base : System.Address; - Obj_DT : Dispatch_Table_Ptr; - Obj_TSD : Type_Specific_Data_Ptr; - - begin - 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 - if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then - return True; - end if; - end loop; - end if; - - -- Look for the tag in the ancestor tags table. This is required for: - -- Iface_CW in Typ'Class - - for Id in 0 .. Obj_TSD.Idepth loop - if Obj_TSD.Tags_Table (Id) = T then - return True; - end if; - end loop; - - return False; - end IW_Membership; - - ------------------- - -- Expanded_Name -- - ------------------- - - function Expanded_Name (T : Tag) return String is - Result : Cstring_Ptr; - 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); - Result := TSD.Expanded_Name; - return Result (1 .. Length (Result)); - end Expanded_Name; - - ------------------ - -- External_Tag -- - ------------------ - - function External_Tag (T : Tag) return String is - Result : Cstring_Ptr; - 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); - Result := TSD.External_Tag; - return Result (1 .. Length (Result)); - end External_Tag; - - --------------------- - -- Get_Entry_Index -- - --------------------- - - function Get_Entry_Index (T : Tag; Position : Positive) return Positive is - begin - return SSD (T).SSD_Table (Position).Index; - end Get_Entry_Index; - - ---------------------- - -- Get_Prim_Op_Kind -- - ---------------------- - - function Get_Prim_Op_Kind - (T : Tag; - Position : Positive) return Prim_Op_Kind - is - begin - return SSD (T).SSD_Table (Position).Kind; - end Get_Prim_Op_Kind; - - ---------------------- - -- Get_Offset_Index -- - ---------------------- - - function Get_Offset_Index - (T : Tag; - Position : Positive) return Positive - is - begin - if Is_Primary_DT (T) then - return Position; - else - return OSD (T).OSD_Table (Position); - end if; - end Get_Offset_Index; - - --------------------- - -- Get_Tagged_Kind -- - --------------------- - - function Get_Tagged_Kind (T : Tag) return Tagged_Kind is - begin - return DT (T).Tag_Kind; - end Get_Tagged_Kind; - - ----------------------------- - -- Interface_Ancestor_Tags -- - ----------------------------- - - function Interface_Ancestor_Tags (T : Tag) return Tag_Array 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); - Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; - - begin - if Iface_Table = null then - declare - Table : Tag_Array (1 .. 0); - begin - return Table; - end; - else - declare - Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); - begin - for J in 1 .. Iface_Table.Nb_Ifaces loop - Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; - end loop; - - return Table; - end; - end if; - end Interface_Ancestor_Tags; - - ------------------ - -- 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 := null; - - begin - -- 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 - - -- Protect the run-time against wrong internal tags. We - -- cannot use exception handlers here because it would - -- disable the use of this run-time compiling with - -- restriction No_Exception_Handler. - - declare - C : Character; - Wrong_Tag : Boolean := False; - - begin - if External (Addr_First) /= '1' - or else External (Addr_First + 1) /= '6' - or else External (Addr_First + 2) /= '#' - then - Wrong_Tag := True; - - else - for J in Addr_First + 3 .. Addr_Last - 1 loop - C := External (J); - - if not (C in '0' .. '9') - and then not (C in 'A' .. 'F') - and then not (C in 'a' .. 'f') - then - Wrong_Tag := True; - exit; - end if; - end loop; - end if; - - -- Convert the numeric value into a tag - - if not Wrong_Tag then - Addr := Integer_Address'Value - (External (Addr_First .. Addr_Last)); - - -- Internal tags never have value 0 - - if Addr /= 0 then - return To_Tag (Addr); - end if; - end if; - end; - end if; - end; - - -- Handle library-level tagged types - - else - -- Make NUL-terminated copy of external tag string - - 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 - Msg1 : constant String := "unknown tagged type: "; - Msg2 : String (1 .. Msg1'Length + External'Length); - - begin - Msg2 (1 .. Msg1'Length) := Msg1; - Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := - External; - Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); - end; - end if; - - return Res; - end Internal_Tag; - - --------------------------------- - -- Is_Descendant_At_Same_Level -- - --------------------------------- - - function Is_Descendant_At_Same_Level - (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 D_TSD.Access_Level = A_TSD.Access_Level; - end Is_Descendant_At_Same_Level; - - ------------ - -- Length -- - ------------ - - -- Should this be reimplemented using the strlen GCC builtin??? - - function Length (Str : Cstring_Ptr) return Natural is - Len : Integer; - - begin - Len := 1; - while Str (Len) /= ASCII.NUL loop - Len := Len + 1; - end loop; - - return Len - 1; - end Length; - - ------------------- - -- Offset_To_Top -- - ------------------- - - function Offset_To_Top - (This : System.Address) return SSE.Storage_Offset - is - Tag_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - - type Storage_Offset_Ptr is access SSE.Storage_Offset; - function To_Storage_Offset_Ptr is - new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); - - Curr_DT : Dispatch_Table_Ptr; - - begin - 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; - - ------------------------ - -- Needs_Finalization -- - ------------------------ - - function Needs_Finalization (T : Tag) return Boolean 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.Needs_Finalization; - end Needs_Finalization; - - ----------------- - -- Parent_Size -- - ----------------- - - function Parent_Size - (Obj : System.Address; - T : Tag) return SSE.Storage_Count - is - Parent_Slot : constant Positive := 1; - -- The tag of the parent is always in the first slot of the table of - -- ancestor tags. - - 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_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Parent_Tag) - - DT_Typeinfo_Ptr_Size); - Parent_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); - - begin - -- Here we compute the size of the _parent field of the object - - return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); - end Parent_Size; - - ---------------- - -- Parent_Tag -- - ---------------- - - 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.Idepth = 0 then - return No_Tag; - else - return TSD.Tags_Table (1); - end if; - end Parent_Tag; - - ------------------------------- - -- Register_Interface_Offset -- - ------------------------------- - - procedure Register_Interface_Offset - (This : System.Address; - Interface_T : Tag; - Is_Static : Boolean; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr) - is - Prim_DT : Dispatch_Table_Ptr; - Iface_Table : Interface_Data_Ptr; - - begin - -- "This" points to the primary DT and we must save Offset_Value in - -- the Offset_To_Top field of the corresponding dispatch table. - - Prim_DT := DT (To_Tag_Ptr (This).all); - Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; - - -- 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 - if Is_Static or else Offset_Value = 0 then - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := - Offset_Value; - else - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := - Offset_Func; - end if; - - return; - end if; - end loop; - end if; - - -- If we arrive here there is some error in the run-time data structure - - raise Program_Error; - end Register_Interface_Offset; - - ------------------ - -- Register_Tag -- - ------------------ - - procedure Register_Tag (T : Tag) is - begin - External_Tag_HTable.Set (T); - end Register_Tag; - - ------------------- - -- Secondary_Tag -- - ------------------- - - function Secondary_Tag (T, Iface : Tag) return Tag is - Iface_Table : Interface_Data_Ptr; - Obj_DT : Dispatch_Table_Ptr; - - begin - if not Is_Primary_DT (T) then - raise Program_Error; - end if; - - Obj_DT := DT (T); - 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 - if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then - return Iface_Table.Ifaces_Table (Id).Secondary_DT; - end if; - end loop; - end if; - - -- If the object does not implement the interface we must raise CE - - raise Constraint_Error with "invalid interface conversion"; - end Secondary_Tag; - - --------------------- - -- Set_Entry_Index -- - --------------------- - - procedure Set_Entry_Index - (T : Tag; - Position : Positive; - Value : Positive) - is - begin - SSD (T).SSD_Table (Position).Index := Value; - end Set_Entry_Index; - - ----------------------- - -- Set_Offset_To_Top -- - ----------------------- - - procedure Set_Dynamic_Offset_To_Top - (This : System.Address; - Interface_T : Tag; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr) - is - Sec_Base : System.Address; - Sec_DT : Dispatch_Table_Ptr; - begin - -- Save the offset to top field in the secondary dispatch table - - if Offset_Value /= 0 then - Sec_Base := This + Offset_Value; - Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); - Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; - end if; - - Register_Interface_Offset - (This, Interface_T, False, Offset_Value, Offset_Func); - end Set_Dynamic_Offset_To_Top; - - ---------------------- - -- Set_Prim_Op_Kind -- - ---------------------- - - procedure Set_Prim_Op_Kind - (T : Tag; - Position : Positive; - Value : Prim_Op_Kind) - is - begin - SSD (T).SSD_Table (Position).Kind := Value; - end Set_Prim_Op_Kind; - - ---------------------- - -- Type_Is_Abstract -- - ---------------------- - - function Type_Is_Abstract (T : Tag) return Boolean 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); - return TSD.Type_Is_Abstract; - end Type_Is_Abstract; - - -------------------- - -- Unregister_Tag -- - -------------------- - - procedure Unregister_Tag (T : Tag) is - begin - External_Tag_HTable.Remove (Get_External_Tag (T)); - end Unregister_Tag; - - ------------------------ - -- Wide_Expanded_Name -- - ------------------------ - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Encoding method for source, as exported by binder - - function Wide_Expanded_Name (T : Tag) return Wide_String is - S : constant String := Expanded_Name (T); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Expanded_Name; - - ----------------------------- - -- Wide_Wide_Expanded_Name -- - ----------------------------- - - function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is - S : constant String := Expanded_Name (T); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Expanded_Name; - -end Ada.Tags; |