diff options
author | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 13:55:47 +0000 |
---|---|---|
committer | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 13:55:47 +0000 |
commit | 1fac938ee5fb71eb038b3b33e393a02d5ea33190 (patch) | |
tree | 2984031fa75d4e716ac1f562efe5ae818a291ca8 /gcc/ada/a-tags.adb | |
parent | e6e7bf38fd3e54eef6e896049ef2d52135eab3d0 (diff) | |
download | gcc-1fac938ee5fb71eb038b3b33e393a02d5ea33190.tar.gz |
New Language: Ada
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45953 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/a-tags.adb')
-rw-r--r-- | gcc/ada/a-tags.adb | 536 |
1 files changed, 536 insertions, 0 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb new file mode 100644 index 00000000000..b11330d41cb --- /dev/null +++ b/gcc/ada/a-tags.adb @@ -0,0 +1,536 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.30 $ +-- -- +-- Copyright (C) 1992-2001 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 Ada.Exceptions; +with Unchecked_Conversion; +with GNAT.HTable; + +pragma Elaborate_All (GNAT.HTable); + +package body Ada.Tags is + +-- Structure of the GNAT Dispatch Table + +-- +----------------------+ +-- | TSD pointer ---|-----> Type Specific Data +-- +----------------------+ +-------------------+ +-- | table of | | inheritance depth | +-- : primitive ops : +-------------------+ +-- | pointers | | expanded name | +-- +----------------------+ +-------------------+ +-- | external tag | +-- +-------------------+ +-- | Hash table link | +-- +-------------------+ +-- | Remotely Callable | +-- +-------------------+ +-- | Rec Ctrler offset | +-- +-------------------+ +-- | table of | +-- : ancestor : +-- | tags | +-- +-------------------+ + + use System; + + 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); + + type Wide_Boolean is (False, True); + for Wide_Boolean'Size use Standard'Address_Size; + + type Type_Specific_Data is record + Idepth : Natural; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag; + Remotely_Callable : Wide_Boolean; + RC_Offset : SSE.Storage_Offset; + Ancestor_Tags : Tag_Table (Natural); + end record; + + type Dispatch_Table is record + TSD : Type_Specific_Data_Ptr; + Prims_Ptr : Address_Array (Positive); + end record; + + ------------------------------------------- + -- Unchecked Conversions for Tag and TSD -- + ------------------------------------------- + + function To_Type_Specific_Data_Ptr is + new Unchecked_Conversion (Address, Type_Specific_Data_Ptr); + + function To_Address is new Unchecked_Conversion (Tag, Address); + function To_Address is + new Unchecked_Conversion (Type_Specific_Data_Ptr, Address); + + --------------------------------------------- + -- Unchecked Conversions for String Fields -- + --------------------------------------------- + + function To_Cstring_Ptr is + new Unchecked_Conversion (Address, Cstring_Ptr); + + function To_Address is + new Unchecked_Conversion (Cstring_Ptr, Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + 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). + + ------------------------- + -- External_Tag_HTable -- + ------------------------- + + type HTable_Headers is range 1 .. 64; + + -- The following internal package defines the routines used for + -- the instantiation of a new GNAT.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 : Address) return HTable_Headers; + function Equal (A, B : Address) return Boolean; + end HTable_Subprograms; + + package External_Tag_HTable is new GNAT.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 => 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 : Address) return Boolean is + Str1 : Cstring_Ptr := To_Cstring_Ptr (A); + Str2 : 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; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Tag) return Tag is + begin + return T.TSD.HT_Link; + end Get_HT_Link; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Address) return HTable_Headers is + function H is new GNAT.HTable.Hash (HTable_Headers); + Str : 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 + begin + T.TSD.HT_Link := Next; + end Set_HT_Link; + + end HTable_Subprograms; + + -------------------- + -- CW_Membership -- + -------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Typ'Class + + -- Each dispatch table contains a reference to a table of ancestors + -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" . + + -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are + -- contained in the dispatch table referenced by Obj'Tag . Knowing the + -- level of inheritance of both types, this can be computed in constant + -- time by the formula: + + -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth) + -- = Typ'tag + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is + Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; + + begin + return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag; + end CW_Membership; + + ------------------- + -- Expanded_Name -- + ------------------- + + function Expanded_Name (T : Tag) return String is + Result : Cstring_Ptr := T.TSD.Expanded_Name; + + begin + return Result (1 .. Length (Result)); + end Expanded_Name; + + ------------------ + -- External_Tag -- + ------------------ + + function External_Tag (T : Tag) return String is + Result : Cstring_Ptr := T.TSD.External_Tag; + + begin + return Result (1 .. Length (Result)); + end External_Tag; + + ----------------------- + -- Get_Expanded_Name -- + ----------------------- + + function Get_Expanded_Name (T : Tag) return Address is + begin + return To_Address (T.TSD.Expanded_Name); + end Get_Expanded_Name; + + ---------------------- + -- Get_External_Tag -- + ---------------------- + + function Get_External_Tag (T : Tag) return Address is + begin + return To_Address (T.TSD.External_Tag); + end Get_External_Tag; + + --------------------------- + -- Get_Inheritance_Depth -- + --------------------------- + + function Get_Inheritance_Depth (T : Tag) return Natural is + begin + return T.TSD.Idepth; + end Get_Inheritance_Depth; + + ------------------------- + -- Get_Prim_Op_Address -- + ------------------------- + + function Get_Prim_Op_Address + (T : Tag; + Position : Positive) + return Address + is + begin + return T.Prims_Ptr (Position); + end Get_Prim_Op_Address; + + ------------------- + -- Get_RC_Offset -- + ------------------- + + function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is + begin + return T.TSD.RC_Offset; + end Get_RC_Offset; + + --------------------------- + -- Get_Remotely_Callable -- + --------------------------- + + function Get_Remotely_Callable (T : Tag) return Boolean is + begin + return T.TSD.Remotely_Callable = True; + end Get_Remotely_Callable; + + ------------- + -- Get_TSD -- + ------------- + + function Get_TSD (T : Tag) return Address is + begin + return To_Address (T.TSD); + end Get_TSD; + + ---------------- + -- Inherit_DT -- + ---------------- + + procedure Inherit_DT + (Old_T : Tag; + New_T : Tag; + Entry_Count : Natural) + is + begin + if Old_T /= null then + New_T.Prims_Ptr (1 .. Entry_Count) := + Old_T.Prims_Ptr (1 .. Entry_Count); + end if; + end Inherit_DT; + + ----------------- + -- Inherit_TSD -- + ----------------- + + procedure Inherit_TSD (Old_TSD : Address; New_Tag : Tag) is + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Old_TSD); + New_TSD : Type_Specific_Data renames New_Tag.TSD.all; + + begin + if TSD /= null then + New_TSD.Idepth := TSD.Idepth + 1; + New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth) + := TSD.Ancestor_Tags (0 .. TSD.Idepth); + else + New_TSD.Idepth := 0; + end if; + + New_TSD.Ancestor_Tags (0) := New_Tag; + end Inherit_TSD; + + ------------------ + -- Internal_Tag -- + ------------------ + + function Internal_Tag (External : String) return Tag is + Ext_Copy : aliased String (External'First .. External'Last + 1); + Res : Tag; + + begin + -- Make a copy of the string representing the external tag with + -- a null at the end + + 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; + + ------------ + -- Length -- + ------------ + + 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; + + ----------------- + -- Parent_Size -- + ----------------- + + -- Fake type with a tag as first component. Should match the + -- layout of all tagged types. + + type T is record + A : Tag; + end record; + + type T_Ptr is access all T; + + function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr); + + -- The profile of the implicitly defined _size primitive + + type Acc_Size is access function (A : Address) return Long_Long_Integer; + function To_Acc_Size is new Unchecked_Conversion (Address, Acc_Size); + + function Parent_Size (Obj : Address) return SSE.Storage_Count is + + -- Get the tag of the object + + Obj_Tag : constant Tag := To_T_Ptr (Obj).A; + + -- Get the tag of the parent type through the dispatch table + + Parent_Tag : constant Tag := Obj_Tag.TSD.Ancestor_Tags (1); + + -- Get an access to the _size primitive of the parent. We assume that + -- it is always in the first slot of the distatch table + + F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + + begin + -- Here we compute the size of the _parent field of the object + + return SSE.Storage_Count (F.all (Obj)); + end Parent_Size; + + ------------------ + -- Register_Tag -- + ------------------ + + procedure Register_Tag (T : Tag) is + begin + External_Tag_HTable.Set (T); + end Register_Tag; + + ----------------------- + -- Set_Expanded_Name -- + ----------------------- + + procedure Set_Expanded_Name (T : Tag; Value : Address) is + begin + T.TSD.Expanded_Name := To_Cstring_Ptr (Value); + end Set_Expanded_Name; + + ---------------------- + -- Set_External_Tag -- + ---------------------- + + procedure Set_External_Tag (T : Tag; Value : Address) is + begin + T.TSD.External_Tag := To_Cstring_Ptr (Value); + end Set_External_Tag; + + --------------------------- + -- Set_Inheritance_Depth -- + --------------------------- + + procedure Set_Inheritance_Depth + (T : Tag; + Value : Natural) + is + begin + T.TSD.Idepth := Value; + end Set_Inheritance_Depth; + + ------------------------- + -- Set_Prim_Op_Address -- + ------------------------- + + procedure Set_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : Address) + is + begin + T.Prims_Ptr (Position) := Value; + end Set_Prim_Op_Address; + + ------------------- + -- Set_RC_Offset -- + ------------------- + + procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is + begin + T.TSD.RC_Offset := Value; + end Set_RC_Offset; + + --------------------------- + -- Set_Remotely_Callable -- + --------------------------- + + procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is + begin + if Value then + T.TSD.Remotely_Callable := True; + else + T.TSD.Remotely_Callable := False; + end if; + end Set_Remotely_Callable; + + ------------- + -- Set_TSD -- + ------------- + + procedure Set_TSD (T : Tag; Value : Address) is + begin + T.TSD := To_Type_Specific_Data_Ptr (Value); + end Set_TSD; + +end Ada.Tags; |