blob: d663a41f5a841b35a365f2703847b64e15f12df5 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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 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 (System.HTable);
-- Elaborate needed instead of Elaborate_All to avoid elaboration cycles
-- when polling is turned on. This is safe because HTable doesn't do anything
-- at elaboration time; it just contains a generic package we want to
-- instantiate.
package body Ada.Tags is
-----------------------
-- Local Subprograms --
-----------------------
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 IW_Membership
(Descendant_TSD : Type_Specific_Data_Ptr;
T : Tag) return Boolean;
-- Subsidiary function of IW_Membership and CW_Membership which factorizes
-- the functionality needed to check if a given descendant implements an
-- interface tag T.
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). See comment in body
-- explaining why we cannot use the normal strlen built-in.
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 (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_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);
-------------------------------
-- 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.
----------------------
-- 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_Abstract --
-----------------
function 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.Is_Abstract;
end Is_Abstract;
-------------------
-- 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;
begin
J := 1;
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;
else
return Int_Tag;
end if;
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 --
-------------------
function IW_Membership
(Descendant_TSD : Type_Specific_Data_Ptr;
T : Tag) return Boolean
is
Iface_Table : Interface_Data_Ptr;
begin
Iface_Table := Descendant_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 .. Descendant_TSD.Idepth loop
if Descendant_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
return False;
end IW_Membership;
-------------------
-- 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
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);
return IW_Membership (Obj_TSD, T);
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
pragma Unsuppress (All_Checks);
-- To make T'Class'Input robust in the case of bad data
Res : Tag := null;
begin
-- Raise Tag_Error for empty strings and very long strings. This makes
-- T'Class'Input robust in the case of bad data, for example
--
-- String (123456789..1234)
--
-- The limit of 10,000 characters is arbitrary, but is unlikely to be
-- exceeded by legitimate external tag names.
if External'Length not in 1 .. 10_000 then
raise Tag_Error;
end if;
-- 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
declare
Ext_Copy : aliased String (External'First .. External'Last + 1);
pragma Assert (Ext_Copy'Length > 1); -- See Length check at top
begin
Ext_Copy (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
Res := External_Tag_HTable.Get (Ext_Copy'Address);
end;
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
begin
if Descendant = Ancestor then
return True;
else
declare
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
D_TSD.Access_Level = A_TSD.Access_Level
and then (CW_Membership (Descendant, Ancestor)
or else IW_Membership (D_TSD, Ancestor));
end;
end if;
end Is_Descendant_At_Same_Level;
------------
-- Length --
------------
-- Note: This unit is used in the Ravenscar runtime library, so it cannot
-- depend on System.CTRL. Furthermore, this happens on CPUs where the GCC
-- intrinsic strlen may not be available, so we need to recode our own Ada
-- version here.
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);
-- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
-- The parent record type has variable-size components, so the
-- instance-specific offset is stored in the tagged record, right
-- after the reference to Curr_DT (which is a secondary dispatch
-- table).
return To_Storage_Offset_Ptr (This + Tag_Size).all;
else
-- The offset is compile-time known, so it is simply stored in the
-- Offset_To_Top field.
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
(Prim_T : Tag;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr)
is
Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T);
Iface_Table : constant Interface_Data_Ptr :=
To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
begin
-- 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_Dynamic_Offset_To_Top --
-------------------------------
procedure Set_Dynamic_Offset_To_Top
(This : System.Address;
Prim_T : Tag;
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
(Prim_T, 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;
--------------------
-- 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 : constant 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;