------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
+-- 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. 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. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- 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. --
+-- 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 Unchecked_Conversion;
+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
--- Structure of the GNAT Dispatch Table
-
--- +----------------------+
--- | TSD pointer ---|-----> Type Specific Data
--- +----------------------+ +-------------------+
--- | 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
- TSD : Type_Specific_Data_Ptr;
- Prims_Ptr : Address_Array (1 .. 1);
- end record;
- -- 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, and allocates the Dispatch_Table
- -- record accordingly.
- --
- -- 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 --
- ---------------------------------------------
+ -----------------------
+ -- 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 Unchecked_Conversion (Cstring_Ptr, System.Address);
+ new Ada.Unchecked_Conversion (Tag, System.Address);
- -----------------------
- -- Local Subprograms --
- -----------------------
+ function To_Dispatch_Table_Ptr is
+ new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
- 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 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.
+ -- 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);
package body HTable_Subprograms is
- -----------
- -- Equal --
- -----------
+ -----------
+ -- 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;
-----------------
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 T.TSD.HT_Link;
+ return TSD.HT_Link.all;
end Get_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
- T.TSD.HT_Link := Next;
+ 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;
+
--------------------
- -- CW_Membership --
+ -- 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 Typ'Class
+ -- Obj in Iface'Class
- -- Each dispatch table contains a reference to a table of ancestors
- -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
+ -- Each dispatch table contains a table with the tags of all the
+ -- implemented interfaces.
- -- 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 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.
- -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
- -- = Typ'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;
- function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
- Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
begin
- return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
- end CW_Membership;
+ 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 : constant Cstring_Ptr := T.TSD.Expanded_Name;
+ 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;
------------------
function External_Tag (T : Tag) return String is
- Result : constant Cstring_Ptr := T.TSD.External_Tag;
+ 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_Expanded_Name --
- -----------------------
+ ---------------------
+ -- Get_Entry_Index --
+ ---------------------
- function Get_Expanded_Name (T : Tag) return System.Address is
+ function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
begin
- return To_Address (T.TSD.Expanded_Name);
- end Get_Expanded_Name;
+ return SSD (T).SSD_Table (Position).Index;
+ end Get_Entry_Index;
----------------------
- -- Get_External_Tag --
+ -- Get_Prim_Op_Kind --
----------------------
- function Get_External_Tag (T : Tag) return System.Address is
- begin
- return To_Address (T.TSD.External_Tag);
- end Get_External_Tag;
-
- ---------------------------
- -- Get_Inheritance_Depth --
- ---------------------------
-
- function Get_Inheritance_Depth (T : Tag) return Natural is
+ function Get_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive) return Prim_Op_Kind
+ is
begin
- return T.TSD.Idepth;
- end Get_Inheritance_Depth;
+ return SSD (T).SSD_Table (Position).Kind;
+ end Get_Prim_Op_Kind;
- -------------------------
- -- Get_Prim_Op_Address --
- -------------------------
+ ----------------------
+ -- Get_Offset_Index --
+ ----------------------
- function Get_Prim_Op_Address
+ function Get_Offset_Index
(T : Tag;
- Position : Positive) return System.Address
+ Position : Positive) return Positive
is
begin
- return T.Prims_Ptr (Position);
- end Get_Prim_Op_Address;
+ if Is_Primary_DT (T) then
+ return Position;
+ else
+ return OSD (T).OSD_Table (Position);
+ end if;
+ end Get_Offset_Index;
-------------------
-- Get_RC_Offset --
-------------------
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 T.TSD.RC_Offset;
+ return TSD.RC_Offset;
end Get_RC_Offset;
- ---------------------------
- -- Get_Remotely_Callable --
- ---------------------------
-
- function Get_Remotely_Callable (T : Tag) return Boolean is
- begin
- return T.TSD.Remotely_Callable = True;
- end Get_Remotely_Callable;
-
- -------------
- -- Get_TSD --
- -------------
-
- function Get_TSD (T : Tag) return System.Address is
- begin
- return To_Address (T.TSD);
- end Get_TSD;
-
- ----------------
- -- Inherit_DT --
- ----------------
+ ---------------------
+ -- Get_Tagged_Kind --
+ ---------------------
- procedure Inherit_DT
- (Old_T : Tag;
- New_T : Tag;
- Entry_Count : Natural)
- is
+ function Get_Tagged_Kind (T : Tag) return Tagged_Kind 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;
+ return DT (T).Tag_Kind;
+ end Get_Tagged_Kind;
- -----------------
- -- Inherit_TSD --
- -----------------
+ -----------------------------
+ -- Interface_Ancestor_Tags --
+ -----------------------------
- procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is
- TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (Old_TSD);
- New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
+ 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 TSD /= null then
- New_TSD.Idepth := TSD.Idepth + 1;
- New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
- := TSD.Ancestor_Tags (0 .. TSD.Idepth);
+ if Iface_Table = null then
+ declare
+ Table : Tag_Array (1 .. 0);
+ begin
+ return Table;
+ end;
else
- New_TSD.Idepth := 0;
- end if;
+ 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;
- New_TSD.Ancestor_Tags (0) := New_Tag;
- end Inherit_TSD;
+ 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;
+ 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
+
+ -- 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);
+ 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
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 --
------------
function Length (Str : Cstring_Ptr) return Natural is
- Len : Integer := 1;
+ Len : Integer;
begin
- while Str (Len) /= ASCII.Nul loop
+ 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;
+
-----------------
-- 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 := T.TSD.Ancestor_Tags (1);
- -- The tag of the parent type through the dispatch table
+ 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
- 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
+ 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 (F.all (Obj));
+ return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
end Parent_Size;
----------------
----------------
function Parent_Tag (T : Tag) return Tag is
+ TSD_Ptr : Addr_Ptr;
+ TSD : Type_Specific_Data_Ptr;
+
begin
- return T.TSD.Ancestor_Tags (1);
+ 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 --
------------------
External_Tag_HTable.Set (T);
end Register_Tag;
- -----------------------
- -- Set_Expanded_Name --
- -----------------------
+ -------------------
+ -- Secondary_Tag --
+ -------------------
+
+ function Secondary_Tag (T, Iface : Tag) return Tag is
+ Iface_Table : Interface_Data_Ptr;
+ Obj_DT : Dispatch_Table_Ptr;
- procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
begin
- T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
- end Set_Expanded_Name;
+ if not Is_Primary_DT (T) then
+ raise Program_Error;
+ end if;
- ----------------------
- -- Set_External_Tag --
- ----------------------
+ Obj_DT := DT (T);
+ Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
- procedure Set_External_Tag (T : Tag; Value : System.Address) is
- begin
- T.TSD.External_Tag := To_Cstring_Ptr (Value);
- end Set_External_Tag;
+ 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;
- ---------------------------
- -- Set_Inheritance_Depth --
- ---------------------------
+ -- If the object does not implement the interface we must raise CE
- procedure Set_Inheritance_Depth
- (T : Tag;
- Value : Natural)
- is
- begin
- T.TSD.Idepth := Value;
- end Set_Inheritance_Depth;
+ raise Constraint_Error with "invalid interface conversion";
+ end Secondary_Tag;
- -------------------------
- -- Set_Prim_Op_Address --
- -------------------------
+ ---------------------
+ -- Set_Entry_Index --
+ ---------------------
- procedure Set_Prim_Op_Address
+ procedure Set_Entry_Index
(T : Tag;
Position : Positive;
- Value : System.Address)
+ Value : Positive)
is
begin
- T.Prims_Ptr (Position) := Value;
- end Set_Prim_Op_Address;
+ SSD (T).SSD_Table (Position).Index := Value;
+ end Set_Entry_Index;
- -------------------
- -- Set_RC_Offset --
- -------------------
+ -----------------------
+ -- Set_Offset_To_Top --
+ -----------------------
- procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
+ 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
- T.TSD.RC_Offset := Value;
- end Set_RC_Offset;
+ -- 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_Remotely_Callable --
- ---------------------------
+ ----------------------
+ -- Set_Prim_Op_Kind --
+ ----------------------
- procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
+ procedure Set_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive;
+ Value : Prim_Op_Kind)
+ is
begin
- if Value then
- T.TSD.Remotely_Callable := True;
- else
- T.TSD.Remotely_Callable := False;
- end if;
- end Set_Remotely_Callable;
+ SSD (T).SSD_Table (Position).Kind := Value;
+ end Set_Prim_Op_Kind;
- -------------
- -- Set_TSD --
- -------------
+ ------------------------
+ -- Wide_Expanded_Name --
+ ------------------------
+
+ WC_Encoding : Character;
+ pragma Import (C, WC_Encoding, "__gl_wc_encoding");
+ -- Encoding method for source, as exported by binder
- procedure Set_TSD (T : Tag; Value : System.Address) is
+ 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
- T.TSD := To_Type_Specific_Data_Ptr (Value);
- end Set_TSD;
+ 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;
OSDN Git Service
