------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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 System.HTable; pragma Elaborate_All (System.HTable); package body Ada.Tags is -- Structure of the GNAT Dispatch Table -- +-----------------------+ -- | Offset_To_Top | -- +-----------------------+ -- | Typeinfo_Ptr/TSD_Ptr |----> Type Specific Data -- Tag ---> +-----------------------+ +-------------------+ -- | table of | | inheritance depth | -- : primitive ops : +-------------------+ -- | pointers | | expanded name | -- +-----------------------+ +-------------------+ -- | external tag | -- +-------------------+ -- | Hash table link | -- +-------------------+ -- | Remotely Callable | -- +-------------------+ -- | Rec Ctrler offset | -- +-------------------+ -- | table of | -- : ancestor : -- | tags | -- +-------------------+ subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; type Tag_Table is array (Natural range <>) of Tag; pragma Suppress_Initialization (Tag_Table); pragma Suppress (Index_Check, On => Tag_Table); -- We suppress index checks because the declared size in the record below -- is a dummy size of one (see below). type Wide_Boolean is new Boolean; -- This name should probably be changed sometime ??? and indeed probably -- this field could simply be of type Standard.Boolean. type Type_Specific_Data is record Idepth : Natural; Expanded_Name : Cstring_Ptr; External_Tag : Cstring_Ptr; HT_Link : Tag; Remotely_Callable : Wide_Boolean; RC_Offset : SSE.Storage_Offset; Ancestor_Tags : Tag_Table (0 .. 1); end record; -- The size of the Ancestor_Tags array actually depends on the tagged type -- to which it applies. We are using the same mechanism as for the -- Prims_Ptr array in the Dispatch_Table record. See comments below for -- more details. type Dispatch_Table is record -- Offset_To_Top : Integer := 0; -- Typeinfo_Ptr : System.Address; -- Currently TSD is also here??? Prims_Ptr : Address_Array (Positive); end record; -- Note on the commented out fields of the Dispatch_Table -- ------------------------------------------------------ -- 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++ termi- -- nology) 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. -- ----------------------------------------------------------------------- -- 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 a -- 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. --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- function To_Cstring_Ptr is new Unchecked_Conversion (System.Address, Cstring_Ptr); function To_Address is new Unchecked_Conversion (Cstring_Ptr, System.Address); ----------------------------------------------------------- -- Unchecked Conversions for the component offset_to_top -- ----------------------------------------------------------- type Int_Ptr is access Integer; function To_Int_Ptr is new Unchecked_Conversion (System.Address, Int_Ptr); ----------------------- -- Local Subprograms -- ----------------------- 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 Offset_To_Top (T : Tag) return Integer; -- Returns the current value of the offset_to_top component available in -- the prologue of the dispatch table. 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. pragma Unreferenced (Offset_To_Top); pragma Unreferenced (Typeinfo_Ptr); -- These functions will be used for full compatibility with the C++ ABI ------------------------- -- 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 begin return TSD (T).HT_Link; 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 begin TSD (T).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 -- (Ancestor_Tags) 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: -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth) -- = Typ'tag function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; begin return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag; end CW_Membership; ------------------- -- Expanded_Name -- ------------------- function Expanded_Name (T : Tag) return String is Result : constant Cstring_Ptr := TSD (T).Expanded_Name; begin return Result (1 .. Length (Result)); end Expanded_Name; ------------------ -- External_Tag -- ------------------ function External_Tag (T : Tag) return String is Result : constant Cstring_Ptr := TSD (T).External_Tag; begin return Result (1 .. Length (Result)); end External_Tag; ----------------------- -- Get_Expanded_Name -- ----------------------- function Get_Expanded_Name (T : Tag) return System.Address is begin return To_Address (TSD (T).Expanded_Name); end Get_Expanded_Name; ---------------------- -- 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_Inheritance_Depth -- --------------------------- function Get_Inheritance_Depth (T : Tag) return Natural is begin return TSD (T).Idepth; end Get_Inheritance_Depth; ------------------------- -- Get_Prim_Op_Address -- ------------------------- function Get_Prim_Op_Address (T : Tag; Position : Positive) return System.Address is begin return T.Prims_Ptr (Position); end Get_Prim_Op_Address; ------------------- -- Get_RC_Offset -- ------------------- function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is begin return TSD (T).RC_Offset; end Get_RC_Offset; --------------------------- -- Get_Remotely_Callable -- --------------------------- function Get_Remotely_Callable (T : Tag) return Boolean is begin return TSD (T).Remotely_Callable = True; end Get_Remotely_Callable; ------------- -- Get_TSD -- ------------- function Get_TSD (T : Tag) return System.Address is use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin return TSD_Ptr.all; end Get_TSD; ---------------- -- Inherit_DT -- ---------------- procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is begin if Old_T /= null then New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); end if; end Inherit_DT; ----------------- -- Inherit_TSD -- ----------------- procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is Old_TSD_Ptr : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (Old_TSD); New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag); begin if Old_TSD_Ptr /= null then New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) := Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth); else New_TSD_Ptr.Idepth := 0; end if; New_TSD_Ptr.Ancestor_Tags (0) := New_Tag; end Inherit_TSD; ------------------ -- Internal_Tag -- ------------------ function Internal_Tag (External : String) return Tag is Ext_Copy : aliased String (External'First .. External'Last + 1); Res : Tag; begin -- 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); 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; ------------ -- Length -- ------------ function Length (Str : Cstring_Ptr) return Natural is Len : Integer := 1; begin while Str (Len) /= ASCII.Nul loop Len := Len + 1; end loop; return Len - 1; end Length; ----------------- -- Parent_Size -- ----------------- type Acc_Size is access function (A : System.Address) return Long_Long_Integer; function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); -- The profile of the implicitly defined _size primitive function Parent_Size (Obj : System.Address; T : Tag) return SSE.Storage_Count is Parent_Tag : constant Tag := TSD (T).Ancestor_Tags (1); -- The tag of the parent type through the dispatch table F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); -- Access to the _size primitive of the parent. We assume that -- it is always in the first slot of the distatch table begin -- Here we compute the size of the _parent field of the object return SSE.Storage_Count (F.all (Obj)); end Parent_Size; ---------------- -- Parent_Tag -- ---------------- function Parent_Tag (T : Tag) return Tag is begin return TSD (T).Ancestor_Tags (1); end Parent_Tag; ------------------ -- Register_Tag -- ------------------ procedure Register_Tag (T : Tag) is begin External_Tag_HTable.Set (T); end Register_Tag; ----------------------- -- Set_Expanded_Name -- ----------------------- procedure Set_Expanded_Name (T : Tag; Value : System.Address) is begin TSD (T).Expanded_Name := To_Cstring_Ptr (Value); end Set_Expanded_Name; ---------------------- -- Set_External_Tag -- ---------------------- procedure Set_External_Tag (T : Tag; Value : System.Address) is begin TSD (T).External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; --------------------------- -- Set_Inheritance_Depth -- --------------------------- procedure Set_Inheritance_Depth (T : Tag; Value : Natural) is begin TSD (T).Idepth := Value; end Set_Inheritance_Depth; ------------------------- -- Set_Prim_Op_Address -- ------------------------- procedure Set_Prim_Op_Address (T : Tag; Position : Positive; Value : System.Address) is begin T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; ------------------- -- Set_RC_Offset -- ------------------- procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is begin TSD (T).RC_Offset := Value; end Set_RC_Offset; --------------------------- -- Set_Remotely_Callable -- --------------------------- procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is begin if Value then TSD (T).Remotely_Callable := True; else TSD (T).Remotely_Callable := False; end if; end Set_Remotely_Callable; ------------- -- Set_TSD -- ------------- procedure Set_TSD (T : Tag; Value : System.Address) is use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin TSD_Ptr.all := Value; end Set_TSD; ------------------- -- Offset_To_Top -- ------------------- function Offset_To_Top (T : Tag) return Integer is use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Int_Ptr := To_Int_Ptr (To_Address (T) - DT_Prologue_Size); begin return TSD_Ptr.all; end Offset_To_Top; ------------------ -- Typeinfo_Ptr -- ------------------ function Typeinfo_Ptr (T : Tag) return System.Address is use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin return TSD_Ptr.all; end Typeinfo_Ptr; --------- -- TSD -- --------- function TSD (T : Tag) return Type_Specific_Data_Ptr is begin return To_Type_Specific_Data_Ptr (Get_TSD (T)); end TSD; end Ada.Tags;