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_All (System.HTable);
package body Ada.Tags is
K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
K_Offset_To_Top : constant SSE.Storage_Count :=
K_Typeinfo + DT_Offset_To_Top_Size;
K_Tagged_Kind : constant SSE.Storage_Count :=
K_Offset_To_Top + DT_Tagged_Kind_Size;
K_Signature : constant SSE.Storage_Count :=
K_Tagged_Kind + DT_Signature_Size;
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);
type Interface_Data_Element is record
Iface_Tag : Tag;
Static_Offset_To_Top : Boolean;
Offset_To_Top_Value : System.Storage_Elements.Storage_Offset;
Offset_To_Top_Func : System.Address;
end record;
type Interfaces_Array is
array (Natural range <>) of Interface_Data_Element;
type Interface_Data (Nb_Ifaces : Positive) is record
Table : Interfaces_Array (1 .. Nb_Ifaces);
end record;
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
type Object_Specific_Data (Nb_Prim : Positive) is record
Num_Prim_Ops : Natural;
OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
end record;
type Select_Specific_Data_Element is record
Index : Positive;
Kind : Prim_Op_Kind;
end record;
type Select_Specific_Data_Array is
array (Positive range <>) of Select_Specific_Data_Element;
type Select_Specific_Data (Nb_Prim : Positive) is record
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
end record;
type Type_Specific_Data is record
Idepth : Natural;
Access_Level : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
Remotely_Callable : Boolean;
RC_Offset : SSE.Storage_Offset;
Ifaces_Table_Ptr : System.Address;
Num_Prim_Ops : Natural;
SSD_Ptr : System.Address;
Tags_Table : Tag_Table (0 .. 1);
end record;
type Dispatch_Table is record
Prims_Ptr : Address_Array (1 .. 1);
end record;
type Signature_Type is
(Must_Be_Primary_DT,
Must_Be_Secondary_DT,
Must_Be_Primary_Or_Secondary_DT,
Must_Be_Interface,
Must_Be_Primary_Or_Interface);
function To_Address is
new Unchecked_Conversion (Cstring_Ptr, System.Address);
function To_Cstring_Ptr is
new Unchecked_Conversion (System.Address, Cstring_Ptr);
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);
type Offset_To_Top_Function_Ptr is
access function (This : System.Address)
return System.Storage_Elements.Storage_Offset;
function To_Offset_To_Top_Function_Ptr is
new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr);
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean;
function Check_Size
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural) return Boolean;
function Get_Num_Prim_Ops (T : Tag) return Natural;
function Is_Primary_DT (T : Tag) return Boolean;
pragma Inline_Always (Is_Primary_DT);
function Length (Str : Cstring_Ptr) return Natural;
function Typeinfo_Ptr (T : Tag) return System.Address;
pragma Unreferenced (Typeinfo_Ptr);
type HTable_Headers is range 1 .. 64;
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);
package body HTable_Subprograms is
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;
function Get_HT_Link (T : Tag) return Tag is
begin
return TSD (T).HT_Link;
end Get_HT_Link;
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;
procedure Set_HT_Link (T : Tag; Next : Tag) is
begin
TSD (T).HT_Link := Next;
end Set_HT_Link;
end HTable_Subprograms;
function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
Signature : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
Sig_Values : constant Signature_Values :=
To_Signature_Values (Signature.all);
Signature_Id : Signature_Kind;
begin
if Sig_Values (1) /= Valid_Signature then
Signature_Id := Unknown;
elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then
Signature_Id := Sig_Values (2);
else
Signature_Id := Unknown;
end if;
case Signature_Id is
when Primary_DT =>
if Kind = Must_Be_Secondary_DT
or else Kind = Must_Be_Interface
then
return False;
end if;
when Secondary_DT =>
if Kind = Must_Be_Primary_DT
or else Kind = Must_Be_Interface
then
return False;
end if;
when Abstract_Interface =>
if Kind = Must_Be_Primary_DT
or else Kind = Must_Be_Secondary_DT
or else Kind = Must_Be_Primary_Or_Secondary_DT
then
return False;
end if;
when others =>
return False;
end case;
return True;
end Check_Signature;
function Check_Size
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural) return Boolean
is
Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
begin
return Entry_Count <= Max_Entries_Old
and then Entry_Count <= Max_Entries_New;
end Check_Size;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Pos : Integer;
begin
pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
function Displace
(This : System.Address;
T : Tag) return System.Address
is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
pragma Assert
(Check_Signature (T, Must_Be_Interface));
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Obj_DT, Must_Be_Primary_DT));
Obj_TSD := TSD (Obj_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = T then
if Iface_Table.Table (Id).Static_Offset_To_Top then
Obj_Base :=
Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value;
else
Obj_Base :=
Obj_Base +
To_Offset_To_Top_Function_Ptr
(Iface_Table.Table (Id).Offset_To_Top_Func).all
(Obj_Base);
end if;
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Obj_DT, Must_Be_Secondary_DT));
return Obj_Base;
end if;
end loop;
end if;
raise Constraint_Error;
end Displace;
function IW_Membership (This : System.Address; T : Tag) return Boolean is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
pragma Assert
(Check_Signature (T, Must_Be_Primary_Or_Interface));
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Obj_DT, Must_Be_Primary_DT));
Obj_TSD := TSD (Obj_DT);
Last_Id := Obj_TSD.Idepth;
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = T then
return True;
end if;
end loop;
end if;
for Id in 0 .. Last_Id loop
if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
return False;
end IW_Membership;
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
Int_Tag : Tag;
begin
pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
Int_Tag := Internal_Tag (External);
pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
raise Tag_Error;
end if;
return Int_Tag;
end Descendant_Tag;
function Expanded_Name (T : Tag) return String is
Result : Cstring_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).Expanded_Name;
return Result (1 .. Length (Result));
end Expanded_Name;
function External_Tag (T : Tag) return String is
Result : Cstring_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).External_Tag;
return Result (1 .. Length (Result));
end External_Tag;
function Get_Access_Level (T : Tag) return Natural is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).Access_Level;
end Get_Access_Level;
function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
return SSD (T).SSD_Table (Position).Index;
end Get_Entry_Index;
function Get_External_Tag (T : Tag) return System.Address is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Address (TSD (T).External_Tag);
end Get_External_Tag;
function Get_Num_Prim_Ops (T : Tag) return Natural is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
if Is_Primary_DT (T) then
return TSD (T).Num_Prim_Ops;
else
return OSD (T).Num_Prim_Ops;
end if;
end Get_Num_Prim_Ops;
function Get_Predefined_Prim_Op_Address
(T : Tag;
Position : Positive) return System.Address
is
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position <= Default_Prim_Op_Count);
return Prim_Ops_DT.Prims_Ptr (Position);
end Get_Predefined_Prim_Op_Address;
function Get_Prim_Op_Address
(T : Tag;
Position : Positive) return System.Address
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
return T.Prims_Ptr (Position);
end Get_Prim_Op_Address;
function Get_Prim_Op_Kind
(T : Tag;
Position : Positive) return Prim_Op_Kind
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
return SSD (T).SSD_Table (Position).Kind;
end Get_Prim_Op_Kind;
function Get_Offset_Index
(T : Tag;
Position : Positive) return Positive
is
begin
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
return OSD (T).OSD_Table (Position);
end Get_Offset_Index;
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).RC_Offset;
end Get_RC_Offset;
function Get_Remotely_Callable (T : Tag) return Boolean is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).Remotely_Callable;
end Get_Remotely_Callable;
function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
end Get_Tagged_Kind;
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
Old_T_Prim_Ops : Tag;
New_T_Prim_Ops : Tag;
Size : Positive;
begin
pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
if Old_T /= null then
New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count);
Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size);
New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size);
Size := Default_Prim_Op_Count;
New_T_Prim_Ops.Prims_Ptr (1 .. Size) :=
Old_T_Prim_Ops.Prims_Ptr (1 .. Size);
end if;
end Inherit_DT;
procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
New_TSD_Ptr : Type_Specific_Data_Ptr;
New_Iface_Table_Ptr : Interface_Data_Ptr;
Old_TSD_Ptr : Type_Specific_Data_Ptr;
Old_Iface_Table_Ptr : Interface_Data_Ptr;
begin
pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
New_TSD_Ptr := TSD (New_Tag);
if Old_Tag /= null then
pragma Assert
(Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
Old_TSD_Ptr := TSD (Old_Tag);
New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) :=
Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth);
if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr,
System.Null_Address)
then
Old_Iface_Table_Ptr :=
To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr);
New_Iface_Table_Ptr :=
To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr);
New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) :=
Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces);
end if;
else
New_TSD_Ptr.Idepth := 0;
end if;
New_TSD_Ptr.Tags_Table (0) := New_Tag;
end Inherit_TSD;
function Internal_Tag (External : String) return Tag is
Ext_Copy : aliased String (External'First .. External'Last + 1);
Res : Tag;
begin
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;
function Is_Descendant_At_Same_Level
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
begin
return CW_Membership (Descendant, Ancestor)
and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
end Is_Descendant_At_Same_Level;
function Is_Primary_DT (T : Tag) return Boolean is
Signature : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
Sig_Values : constant Signature_Values :=
To_Signature_Values (Signature.all);
begin
return Sig_Values (2) = Primary_DT;
end Is_Primary_DT;
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;
function Offset_To_Top
(This : System.Address) return System.Storage_Elements.Storage_Offset
is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Offset_To_Top : Storage_Offset_Ptr;
begin
Offset_To_Top := To_Storage_Offset_Ptr
(To_Address (Curr_DT) - K_Offset_To_Top);
if Offset_To_Top.all = SSE.Storage_Offset'Last then
Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size);
end if;
return Offset_To_Top.all;
end Offset_To_Top;
function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
function Parent_Size
(Obj : System.Address;
T : Tag) return SSE.Storage_Count
is
Parent_Tag : Tag;
Prim_Ops_DT : Tag;
F : Acc_Size;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
Parent_Tag := TSD (T).Tags_Table (1);
Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size);
F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1));
return SSE.Storage_Count (F.all (Obj));
end Parent_Size;
function Parent_Tag (T : Tag) return Tag is
begin
if T = No_Tag then
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
if TSD (T).Idepth = 0 then
return No_Tag;
else
return TSD (T).Tags_Table (1);
end if;
end Parent_Tag;
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag;
Position : Positive)
is
New_T_TSD : Type_Specific_Data_Ptr;
Iface_Table : Interface_Data_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
New_T_TSD := TSD (T);
Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
pragma Assert (Position <= Iface_Table.Nb_Ifaces);
Iface_Table.Table (Position).Iface_Tag := Interface_T;
end Register_Interface_Tag;
procedure Register_Tag (T : Tag) is
begin
External_Tag_HTable.Set (T);
end Register_Tag;
procedure Set_Access_Level (T : Tag; Value : Natural) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Access_Level := Value;
end Set_Access_Level;
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
Value : Positive)
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
SSD (T).SSD_Table (Position).Index := Value;
end Set_Entry_Index;
procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
begin
pragma Assert
(Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
end Set_Expanded_Name;
procedure Set_External_Tag (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).External_Tag := To_Cstring_Ptr (Value);
end Set_External_Tag;
procedure Set_Interface_Table (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Ifaces_Table_Ptr := Value;
end Set_Interface_Table;
procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
if Is_Primary_DT (T) then
TSD (T).Num_Prim_Ops := Value;
else
OSD (T).Num_Prim_Ops := Value;
end if;
end Set_Num_Prim_Ops;
procedure Set_Offset_Index
(T : Tag;
Position : Positive;
Value : Positive)
is
begin
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
OSD (T).OSD_Table (Position) := Value;
end Set_Offset_Index;
procedure Set_Offset_To_Top
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset;
Offset_Func : System.Address)
is
Prim_DT : Tag;
Sec_Base : System.Address;
Sec_DT : Tag;
Offset_To_Top : Storage_Offset_Ptr;
Iface_Table : Interface_Data_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
begin
if System."=" (This, System.Null_Address) then
pragma Assert
(Check_Signature (Interface_T, Must_Be_Primary_DT));
pragma Assert (Offset_Value = 0);
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top);
Offset_To_Top.all := Offset_Value;
return;
end if;
Prim_DT := To_Tag_Ptr (This).all;
pragma Assert
(Check_Signature (Prim_DT, Must_Be_Primary_DT));
Sec_Base := This + Offset_Value;
Sec_DT := To_Tag_Ptr (Sec_Base).all;
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
pragma Assert
(Check_Signature (Sec_DT, Must_Be_Secondary_DT));
if Is_Static then
Offset_To_Top.all := Offset_Value;
else
Offset_To_Top.all := SSE.Storage_Offset'Last;
end if;
Obj_TSD := TSD (Prim_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = Interface_T then
Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static;
if Is_Static then
Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value;
else
Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func;
end if;
return;
end if;
end loop;
end if;
raise Program_Error;
end Set_Offset_To_Top;
procedure Set_OSD (T : Tag; Value : System.Address) is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
OSD_Ptr.all := Value;
end Set_OSD;
procedure Set_Predefined_Prim_Op_Address
(T : Tag;
Position : Positive;
Value : System.Address)
is
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
Prim_Ops_DT.Prims_Ptr (Position) := Value;
end Set_Predefined_Prim_Op_Address;
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
Value : System.Address)
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
T.Prims_Ptr (Position) := Value;
end Set_Prim_Op_Address;
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
Value : Prim_Op_Kind)
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Position <= Get_Num_Prim_Ops (T));
SSD (T).SSD_Table (Position).Kind := Value;
end Set_Prim_Op_Kind;
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).RC_Offset := Value;
end Set_RC_Offset;
procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Remotely_Callable := Value;
end Set_Remotely_Callable;
procedure Set_Signature (T : Tag; Value : Signature_Kind) is
Signature : constant System.Address := To_Address (T) - K_Signature;
Sig_Ptr : constant Signature_Values_Ptr :=
To_Signature_Values_Ptr (Signature);
begin
Sig_Ptr.all (1) := Valid_Signature;
Sig_Ptr.all (2) := Value;
end Set_Signature;
procedure Set_SSD (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).SSD_Ptr := Value;
end Set_SSD;
procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
end Set_Tagged_Kind;
procedure Set_TSD (T : Tag; Value : System.Address) is
TSD_Ptr : Addr_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo);
TSD_Ptr.all := Value;
end Set_TSD;
function SSD (T : Tag) return Select_Specific_Data_Ptr is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
end SSD;
function Typeinfo_Ptr (T : Tag) return System.Address is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return TSD_Ptr.all;
end Typeinfo_Ptr;
function TSD (T : Tag) return Type_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
end TSD;
WC_Encoding : Character;
pragma Import (C, WC_Encoding, "__gl_wc_encoding");
function Wide_Expanded_Name (T : Tag) return Wide_String is
begin
return String_To_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
end Wide_Expanded_Name;
function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
begin
return String_To_Wide_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
end Wide_Wide_Expanded_Name;
end Ada.Tags;