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 --
----------------------
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 --
-------------------------
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 --
-------------------------
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
- function Get_Expanded_Name (T : Tag) return System.Address;
- -- Retrieve the address of a null terminated string containing
- -- the expanded name
-
function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the external name
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
- function Get_Inheritance_Depth (T : Tag) return Natural;
- -- Given a pointer to a dispatch Table, retrieves the value representing
- -- the depth in the inheritance tree (used for membership).
-
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object
-- has controlled components. O otherwise.
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
- procedure Set_Inheritance_Depth
- (T : Tag;
- Value : Natural);
- -- Given a pointer to a dispatch Table, stores the value representing
- -- the depth in the inheritance tree (the second parameter). Used during
- -- elaboration of the tagged type.
-
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
-- use in a minimal/no run-time environment for high integrity use.
pragma Inline_Always (CW_Membership);
- pragma Inline_Always (Get_Expanded_Name);
- pragma Inline_Always (Get_Inheritance_Depth);
pragma Inline_Always (Get_Prim_Op_Address);
pragma Inline_Always (Get_RC_Offset);
pragma Inline_Always (Get_Remotely_Callable);
pragma Inline_Always (Register_Tag);
pragma Inline_Always (Set_Expanded_Name);
pragma Inline_Always (Set_External_Tag);
- pragma Inline_Always (Set_Inheritance_Depth);
pragma Inline_Always (Set_Prim_Op_Address);
pragma Inline_Always (Set_RC_Offset);
pragma Inline_Always (Set_Remotely_Callable);
(CW_Membership => RE_CW_Membership,
DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size,
- Get_Expanded_Name => RE_Get_Expanded_Name,
Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_RC_Offset => RE_Get_RC_Offset,
(CW_Membership => RE_CPP_CW_Membership,
DT_Entry_Size => RE_CPP_DT_Entry_Size,
DT_Prologue_Size => RE_CPP_DT_Prologue_Size,
- Get_Expanded_Name => RE_CPP_Get_Expanded_Name,
Get_External_Tag => RE_CPP_Get_External_Tag,
Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address,
Get_RC_Offset => RE_CPP_Get_RC_Offset,
(CW_Membership => False,
DT_Entry_Size => False,
DT_Prologue_Size => False,
- Get_Expanded_Name => False,
Get_External_Tag => False,
Get_Prim_Op_Address => False,
Get_Remotely_Callable => False,
(CW_Membership => 2,
DT_Entry_Size => 0,
DT_Prologue_Size => 0,
- Get_Expanded_Name => 1,
Get_External_Tag => 1,
Get_Prim_Op_Address => 2,
Get_RC_Offset => 1,
(CW_Membership,
DT_Entry_Size,
DT_Prologue_Size,
- Get_Expanded_Name,
Get_External_Tag,
Get_Prim_Op_Address,
Get_RC_Offset,
return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag;
end CPP_CW_Membership;
- ---------------------------
- -- CPP_Get_Expanded_Name --
- ---------------------------
-
- function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
- begin
- return To_Address (TSD (T).Expanded_Name);
- end CPP_Get_Expanded_Name;
-
--------------------------
-- CPP_Get_External_Tag --
--------------------------
return To_Address (TSD (T).External_Tag);
end CPP_Get_External_Tag;
- -------------------------------
- -- CPP_Get_Inheritance_Depth --
- -------------------------------
-
- function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
- begin
- return TSD (T).Idepth;
- end CPP_Get_Inheritance_Depth;
-
-------------------------
-- CPP_Get_Prim_Op_Address --
-------------------------
TSD (T).External_Tag := To_Cstring_Ptr (Value);
end CPP_Set_External_Tag;
- -------------------------------
- -- CPP_Set_Inheritance_Depth --
- -------------------------------
-
- procedure CPP_Set_Inheritance_Depth
- (T : Vtable_Ptr;
- Value : Natural)
- is
- begin
- TSD (T).Idepth := Value;
- end CPP_Set_Inheritance_Depth;
-
-----------------------------
-- CPP_Set_Prim_Op_Address --
-----------------------------
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
- procedure CPP_Set_Inheritance_Depth
- (T : Vtable_Ptr;
- Value : Natural);
- -- Given a pointer to a dispatch Table, stores the value representing
- -- the depth in the inheritance tree. Used during elaboration of the
- -- tagged type.
-
- function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural;
- -- Given a pointer to a dispatch Table, retreives the value representing
- -- the depth in the inheritance tree. Used for membership.
-
procedure CPP_Set_TSD (T : Vtable_Ptr; Value : S.Address);
-- Given a pointer T to a dispatch Table, stores the address of the
-- record containing the Type Specific Data generated by GNAT
-- Set the address of the string containing the expanded name
-- in the Dispatch table
- function CPP_Get_Expanded_Name (T : Vtable_Ptr) return S.Address;
- -- Retrieve the address of a null terminated string containing
- -- the expanded name
-
procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean);
-- Since the notions of spec/body distinction and categorized packages
-- do not exist in C, this procedure will do nothing
pragma Inline (CPP_Set_Prim_Op_Address);
pragma Inline (CPP_Get_Prim_Op_Address);
- pragma Inline (CPP_Set_Inheritance_Depth);
- pragma Inline (CPP_Get_Inheritance_Depth);
pragma Inline (CPP_Set_TSD);
pragma Inline (CPP_Get_TSD);
pragma Inline (CPP_Inherit_DT);
pragma Inline (CPP_Set_External_Tag);
pragma Inline (CPP_Get_External_Tag);
pragma Inline (CPP_Set_Expanded_Name);
- pragma Inline (CPP_Get_Expanded_Name);
pragma Inline (CPP_Set_Remotely_Callable);
pragma Inline (CPP_Get_Remotely_Callable);
pragma Inline (Displaced_This);
RE_DT_Entry_Size, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
- RE_Get_Expanded_Name, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_CPP_CW_Membership, -- Interfaces.CPP
RE_CPP_DT_Entry_Size, -- Interfaces.CPP
RE_CPP_DT_Prologue_Size, -- Interfaces.CPP
- RE_CPP_Get_Expanded_Name, -- Interfaces.CPP
RE_CPP_Get_External_Tag, -- Interfaces.CPP
RE_CPP_Get_Prim_Op_Address, -- Interfaces.CPP
RE_CPP_Get_RC_Offset, -- Interfaces.CPP
RE_DT_Entry_Size => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
- RE_Get_Expanded_Name => Ada_Tags,
RE_Get_External_Tag => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_CPP_CW_Membership => Interfaces_CPP,
RE_CPP_DT_Entry_Size => Interfaces_CPP,
RE_CPP_DT_Prologue_Size => Interfaces_CPP,
- RE_CPP_Get_Expanded_Name => Interfaces_CPP,
RE_CPP_Get_External_Tag => Interfaces_CPP,
RE_CPP_Get_Prim_Op_Address => Interfaces_CPP,
RE_CPP_Get_RC_Offset => Interfaces_CPP,
New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
- -----------------------
- -- Make_DT_Component --
- -----------------------
-
- function Make_DT_Component
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- N : Positive) return Node_Id
- is
- X : Node_Id;
- Full_Type : Entity_Id := Typ;
-
- begin
- if Is_Private_Type (Typ) then
- Full_Type := Underlying_Type (Typ);
- end if;
-
- X :=
- First_Component
- (Designated_Type
- (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type))))));
-
- for J in 2 .. N loop
- X := Next_Component (X);
- end loop;
-
- return New_Reference_To (X, Loc);
- end Make_DT_Component;
-
--------------------------------
-- Make_Implicit_If_Statement --
--------------------------------
-- Must_Be_Byte_Aligned is set in the attribute reference node. The
-- Attribute_Name must be Name_Address or Name_Unrestricted_Access.
- function Make_DT_Component
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- N : Positive) return Node_Id;
- -- Gives a reference to the Nth component of the Dispatch Table of
- -- a given Tagged Type.
- --
- -- N = 1 --> Inheritance_Depth
- -- N = 2 --> Tags (array of ancestors)
- -- N = 3, 4 --> predefined primitive
- -- function _Size (X : Typ) return Long_Long_Integer;
- -- function _Equality (X : Typ; Y : Typ'Class) return Boolean;
- -- N >= 5 --> User-Defined Primitive Operations
-
function Make_DT_Access
(Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;
-- Create an access to the Dispatch Table by using the Tag field