Package Name: ada.tags
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
-- S p e c --
-- --
-- $Revision: 1.17 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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- --
-- 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. --
-- --
-- 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. --
-- --
-- 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). --
-- --
------------------------------------------------------------------------------
with System;
with System.Storage_Elements;
package Ada.Tags is
pragma Elaborate_Body;
type Tag is private;
function Expanded_Name (T : Tag) return String;
function External_Tag (T : Tag) return String;
function Internal_Tag (External : String) return Tag;
Tag_Error : exception;
private
----------------------------------------------------------------
-- 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
-- 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
-- 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
-- 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
-- initialize those structures and and uses the GET functions to
-- retreive the information when needed
package S renames System;
package SSE renames System.Storage_Elements;
procedure Set_Prim_Op_Address
(T : Tag;
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)
function Get_Prim_Op_Address
(T : Tag;
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)
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.
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).
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
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
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
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.
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(4 * (Standard'Address_Size / S.Storage_Unit));
-- Size of the first part of the type specific data
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
procedure Inherit_DT
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural);
-- 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);
-- Entry point used to initialize the TSD of a type knowing the
-- TSD of the direct ancestor.
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.
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
procedure Set_External_Tag (T : Tag; Value : S.Address);
-- Set the address of the string containing the external tag
-- in the Dispatch table
function Get_External_Tag (T : Tag) return S.Address;
-- Retreive the address of a null terminated string containing
-- the external name
procedure Set_Expanded_Name (T : Tag; Value : S.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table
function Get_Expanded_Name (T : Tag) return S.Address;
-- Retreive the address of a null terminated string containing
-- the expanded name
type Address_Array is array (Natural range <>) of S.Address;
type Dispatch_Table;
type Tag is access all Dispatch_Table;
type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
pragma Inline (Set_Prim_Op_Address);
pragma Inline (Get_Prim_Op_Address);
pragma Inline (Set_Inheritance_Depth);
pragma Inline (Get_Inheritance_Depth);
pragma Inline (Set_TSD);
pragma Inline (Get_TSD);
pragma Inline (Inherit_DT);
pragma Inline (CW_Membership);
pragma Inline (Set_External_Tag);
pragma Inline (Get_External_Tag);
pragma Inline (Set_Expanded_Name);
pragma Inline (Get_Expanded_Name);
end Ada.Tags;