File : a-tags.ads
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
5 -- A D A . T A G S --
-- --
-- S p e c --
-- --
-- $Revision: 1.23 $ --
10 -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
15 -- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
20 -- 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 --
25 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
30 -- 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. --
-- --
35 -- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
40 with System;
with System.Storage_Elements;
package Ada.Tags is
45 pragma Elaborate_Body;
type Tag is private;
function Expanded_Name (T : Tag) return String;
50
function External_Tag (T : Tag) return String;
function Internal_Tag (External : String) return Tag;
55 Tag_Error : exception;
private
----------------------------------------------------------------
60 -- Abstract procedural interface for the GNAT dispatch table --
----------------------------------------------------------------
-- GNAT's Dispatch Table format is customizable in order to match the
-- format used in another langauge. GNAT supports programs that use
65 -- two different dispatch table format at the same time: the native
-- format that supports Ada 95 tagged types and which is described in
-- Ada.Tags and a foreign format for types that are imported from some
-- other language (typically C++) which is described in interfaces.cpp.
-- The runtime information kept for each tagged type is separated into
70 -- two objects: the Dispatch Table and the Type Specific Data record.
-- These two objects are allocated statically using the constants:
-- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
-- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
75
-- where Nb_prim is the number of primitive operations of the given
-- type and Idepth its inheritance depth.
-- The compiler generates calls to the following SET routines to
80 -- initialize those structures and uses the GET functions to
-- retreive the information when needed
package S renames System;
package SSE renames System.Storage_Elements;
85
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.
90 function Get_Expanded_Name (T : Tag) return S.Address;
-- Retrieve the address of a null terminated string containing
-- the expanded name
function Get_External_Tag (T : Tag) return S.Address;
95 -- Retrieve the address of a null terminated string containing
-- the external name
function Get_Prim_Op_Address
(T : Tag;
100 Position : Positive)
return S.Address;
-- Given a pointer to a dispatch Table (T) and a position in the DT
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
105
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).
110 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.
pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
115 -- This procedure is used in s-finimp to compute the deep routines
-- it is exported manually in order to avoid changing completely the
-- organization of the run time.
function Get_Remotely_Callable (T : Tag) return Boolean;
120 -- Return the value previously set by Set_Remotely_Callable
function Get_TSD (T : Tag) return S.Address;
-- Given a pointer T to a dispatch Table, retreives the address of the
-- record containing the Type Specific Data generated by GNAT
125
procedure Inherit_DT
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural);
130 -- Entry point used to initialize the DT of a type knowing the tag
-- of the direct ancestor and the number of primitive ops that are
-- inherited (Entry_Count).
procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag);
135 -- Entry point used to initialize the TSD of a type knowing the
-- TSD of the direct ancestor.
function Parent_Size (Obj : S.Address) return SSE.Storage_Count;
-- Computes the size of field _Parent of a tagged extension object
140 -- whose address is 'obj' by calling the indirectly _size function of
-- the parent. This function assumes that _size is always in slot 1 of
-- the dispatch table.
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
145 -- This procedure is used in s-finimp and is thus exported manually
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
150
procedure Set_Inheritance_Depth
(T : Tag;
Value : Natural);
-- Given a pointer to a dispatch Table, stores the value representing
155 -- the depth in the inheritance tree (the second parameter). Used during
-- elaboration of the tagged type.
procedure Set_Prim_Op_Address
(T : Tag;
160 Position : Positive;
Value : S.Address);
-- Given a pointer to a dispatch Table (T) and a position in the
-- dispatch Table put the address of the virtual function in it
-- (used for overriding)
165
procedure Set_TSD (T : Tag; 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
170 procedure Set_Expanded_Name (T : Tag; Value : S.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table
procedure Set_External_Tag (T : Tag; Value : S.Address);
175 -- Set the address of the string containing the external tag
-- in the Dispatch table
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
-- Sets the Offset of the implicit record controller when the object
180 -- has controlled components. Set to O otherwise.
procedure Set_Remotely_Callable (T : Tag; Value : Boolean);
-- Set to true if the type has been declared in a context described
-- in E.4 (18)
185
DT_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / S.Storage_Unit);
-- Size of the first part of the dispatch table
190
DT_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / S.Storage_Unit);
-- Size of each primitive operation entry in the Dispatch Table.
195
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(6 * Standard'Address_Size / S.Storage_Unit);
-- Size of the first part of the type specific data
200
TSD_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count (Standard'Address_Size / S.Storage_Unit);
-- Size of each ancestor tag entry in the TSD
205 type Address_Array is array (Natural range <>) of S.Address;
type Dispatch_Table;
type Tag is access all Dispatch_Table;
210 type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Get_Expanded_Name);
215 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 (Get_TSD);
220 pragma Inline_Always (Inherit_DT);
pragma Inline_Always (Inherit_TSD);
pragma Inline_Always (Register_Tag);
pragma Inline_Always (Set_Expanded_Name);
pragma Inline_Always (Set_External_Tag);
225 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);
pragma Inline_Always (Set_TSD);
230 end Ada.Tags;