New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45953 138bc75d-0d04-0410-961f-82ee72b054a4

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;