New Language: Ada

From-SVN: r45960

gcc/ada/table.adb

@@ -0,0 +1,345 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                T A B L E                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.44 $
+--                                                                          --
+--          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 Debug;   use Debug;
+with Opt;
+with Output;  use Output;
+with System;  use System;
+with Tree_IO; use Tree_IO;
+
+package body Table is
+   package body Table is
+
+      Min : constant Int := Int (Table_Low_Bound);
+      --  Subscript of the minimum entry in the currently allocated table
+
+      Length : Int := 0;
+      --  Number of entries in currently allocated table. The value of zero
+      --  ensures that we initially allocate the table.
+
+      procedure free (T : Table_Ptr);
+      pragma Import (C, free);
+
+      -----------------------
+      -- Local Subprograms --
+      -----------------------
+
+      procedure Reallocate;
+      --  Reallocate the existing table according to the current value stored
+      --  in Max. Works correctly to do an initial allocation if the table
+      --  is currently null.
+
+      function Tree_Get_Table_Address return Address;
+      --  Return Null_Address if the table length is zero,
+      --  Table (First)'Address if not.
+
+      ------------
+      -- Append --
+      ------------
+
+      procedure Append (New_Val : Table_Component_Type) is
+      begin
+         Increment_Last;
+         Table (Table_Index_Type (Last_Val)) := New_Val;
+      end Append;
+
+      --------------------
+      -- Decrement_Last --
+      --------------------
+
+      procedure Decrement_Last is
+      begin
+         Last_Val := Last_Val - 1;
+      end Decrement_Last;
+
+      ----------
+      -- Free --
+      ----------
+
+      procedure Free is
+      begin
+         free (Table);
+         Table := null;
+         Length := 0;
+      end Free;
+
+      --------------------
+      -- Increment_Last --
+      --------------------
+
+      procedure Increment_Last is
+      begin
+         Last_Val := Last_Val + 1;
+
+         if Last_Val > Max then
+            Reallocate;
+         end if;
+      end Increment_Last;
+
+      ----------
+      -- Init --
+      ----------
+
+      procedure Init is
+         Old_Length : Int := Length;
+
+      begin
+         Last_Val := Min - 1;
+         Max      := Min + (Table_Initial * Opt.Table_Factor) - 1;
+         Length   := Max - Min + 1;
+
+         --  If table is same size as before (happens when table is never
+         --  expanded which is a common case), then simply reuse it. Note
+         --  that this also means that an explicit Init call right after
+         --  the implicit one in the package body is harmless.
+
+         if Old_Length = Length then
+            return;
+
+         --  Otherwise we can use Reallocate to get a table of the right size.
+         --  Note that Reallocate works fine to allocate a table of the right
+         --  initial size when it is first allocated.
+
+         else
+            Reallocate;
+         end if;
+      end Init;
+
+      ----------
+      -- Last --
+      ----------
+
+      function Last return Table_Index_Type is
+      begin
+         return Table_Index_Type (Last_Val);
+      end Last;
+
+      ----------------
+      -- Reallocate --
+      ----------------
+
+      procedure Reallocate is
+
+         function realloc
+           (memblock : Table_Ptr;
+            size     : size_t)
+            return     Table_Ptr;
+         pragma Import (C, realloc);
+
+         function malloc
+           (size     : size_t)
+            return     Table_Ptr;
+         pragma Import (C, malloc);
+
+         New_Size : size_t;
+
+      begin
+         if Max < Last_Val then
+            pragma Assert (not Locked);
+
+            --  Make sure that we have at least the initial allocation. This
+            --  is needed in cases where a zero length table is written out.
+
+            Length := Int'Max (Length, Table_Initial);
+
+            --  Now increment table length until it is sufficiently large
+
+            while Max < Last_Val loop
+               Length := Length * (100 + Table_Increment) / 100;
+               Max := Min + Length - 1;
+            end loop;
+
+            if Debug_Flag_D then
+               Write_Str ("--> Allocating new ");
+               Write_Str (Table_Name);
+               Write_Str (" table, size = ");
+               Write_Int (Max - Min + 1);
+               Write_Eol;
+            end if;
+         end if;
+
+         New_Size :=
+           size_t ((Max - Min + 1) *
+                   (Table_Type'Component_Size / Storage_Unit));
+
+         if Table = null then
+            Table := malloc (New_Size);
+
+         elsif New_Size > 0 then
+            Table :=
+              realloc
+                (memblock => Table,
+                 size     => New_Size);
+         end if;
+
+         if Length /= 0 and then Table = null then
+            Set_Standard_Error;
+            Write_Str ("available memory exhausted");
+            Write_Eol;
+            Set_Standard_Output;
+            raise Unrecoverable_Error;
+         end if;
+
+      end Reallocate;
+
+      -------------
+      -- Release --
+      -------------
+
+      procedure Release is
+      begin
+         Length := Last_Val - Int (Table_Low_Bound) + 1;
+         Max    := Last_Val;
+         Reallocate;
+      end Release;
+
+      -------------
+      -- Restore --
+      -------------
+
+      procedure Restore (T : Saved_Table) is
+      begin
+         free (Table);
+         Last_Val := T.Last_Val;
+         Max      := T.Max;
+         Table    := T.Table;
+         Length   := Max - Min + 1;
+      end Restore;
+
+      ----------
+      -- Save --
+      ----------
+
+      function Save return Saved_Table is
+         Res : Saved_Table;
+
+      begin
+         Res.Last_Val := Last_Val;
+         Res.Max      := Max;
+         Res.Table    := Table;
+
+         Table  := null;
+         Length := 0;
+         Init;
+         return Res;
+      end Save;
+
+      --------------
+      -- Set_Item --
+      --------------
+
+      procedure Set_Item
+         (Index : Table_Index_Type;
+          Item  : Table_Component_Type)
+      is
+      begin
+         if Int (Index) > Max then
+            Set_Last (Index);
+         end if;
+
+         Table (Index) := Item;
+      end Set_Item;
+
+      --------------
+      -- Set_Last --
+      --------------
+
+      procedure Set_Last (New_Val : Table_Index_Type) is
+      begin
+         if Int (New_Val) < Last_Val then
+            Last_Val := Int (New_Val);
+         else
+            Last_Val := Int (New_Val);
+
+            if Last_Val > Max then
+               Reallocate;
+            end if;
+         end if;
+      end Set_Last;
+
+      ----------------------------
+      -- Tree_Get_Table_Address --
+      ----------------------------
+
+      function Tree_Get_Table_Address return Address is
+      begin
+         if Length = 0 then
+            return Null_Address;
+         else
+            return Table (First)'Address;
+         end if;
+      end Tree_Get_Table_Address;
+
+      ---------------
+      -- Tree_Read --
+      ---------------
+
+      --  Note: we allocate only the space required to accomodate the data
+      --  actually written, which means that a Tree_Write/Tree_Read sequence
+      --  does an implicit Release.
+
+      procedure Tree_Read is
+      begin
+         Tree_Read_Int (Max);
+         Last_Val := Max;
+         Length := Max - Min + 1;
+         Reallocate;
+
+         Tree_Read_Data
+           (Tree_Get_Table_Address,
+             (Last_Val - Int (First) + 1) *
+               Table_Type'Component_Size / Storage_Unit);
+      end Tree_Read;
+
+      ----------------
+      -- Tree_Write --
+      ----------------
+
+      --  Note: we write out only the currently valid data, not the entire
+      --  contents of the allocated array. See note above on Tree_Read.
+
+      procedure Tree_Write is
+      begin
+         Tree_Write_Int (Int (Last));
+         Tree_Write_Data
+           (Tree_Get_Table_Address,
+            (Last_Val - Int (First) + 1) *
+              Table_Type'Component_Size / Storage_Unit);
+      end Tree_Write;
+
+   begin
+      Init;
+   end Table;
+end Table;

gcc/ada/table.ads

@@ -0,0 +1,225 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                T A B L E                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.38 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package provides an implementation of dynamically resizable one
+--  dimensional arrays. The idea is to mimic the normal Ada semantics for
+--  arrays as closely as possible with the one additional capability of
+--  dynamically modifying the value of the Last attribute.
+
+--  Note that this interface should remain synchronized with those in
+--  GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these
+--  three related units.
+
+with Types; use Types;
+
+package Table is
+pragma Elaborate_Body (Table);
+
+   generic
+      type Table_Component_Type is private;
+      type Table_Index_Type     is range <>;
+
+      Table_Low_Bound  : Table_Index_Type;
+      Table_Initial    : Pos;
+      Table_Increment  : Nat;
+      Table_Name       : String;
+
+   package Table is
+
+      --  Table_Component_Type and Table_Index_Type specify the type of the
+      --  array, Table_Low_Bound is the lower bound. Index_type must be an
+      --  integer type. The effect is roughly to declare:
+
+      --    Table : array (Table_Index_Type range Table_Low_Bound .. <>)
+      --                       of Table_Component_Type;
+
+      --    Note: since the upper bound can be one less than the lower
+      --    bound for an empty array, the table index type must be able
+      --    to cover this range, e.g. if the lower bound is 1, then the
+      --    Table_Index_Type should be Natural rather than Positive.
+
+      --  Table_Component_Type may be any Ada type, except that controlled
+      --  types are not supported. Note however that default initialization
+      --  will NOT occur for array components.
+
+      --  The Table_Initial values controls the allocation of the table when
+      --  it is first allocated, either by default, or by an explicit Init
+      --  call. The value used is Opt.Table_Factor * Table_Initial.
+
+      --  The Table_Increment value controls the amount of increase, if the
+      --  table has to be increased in size. The value given is a percentage
+      --  value (e.g. 100 = increase table size by 100%, i.e. double it).
+
+      --  The Table_Name parameter is simply use in debug output messages it
+      --  has no other usage, and is not referenced in non-debugging mode.
+
+      --  The Last and Set_Last subprograms provide control over the current
+      --  logical allocation. They are quite efficient, so they can be used
+      --  freely (expensive reallocation occurs only at major granularity
+      --  chunks controlled by the allocation parameters).
+
+      --  Note: we do not make the table components aliased, since this would
+      --  restict the use of table for discriminated types. If it is necessary
+      --  to take the access of a table element, use Unrestricted_Access.
+
+      type Table_Type is
+        array (Table_Index_Type range <>) of Table_Component_Type;
+
+      subtype Big_Table_Type is
+        Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+      --  We work with pointers to a bogus array type that is constrained
+      --  with the maximum possible range bound. This means that the pointer
+      --  is a thin pointer, which is more efficient. Since subscript checks
+      --  in any case must be on the logical, rather than physical bounds,
+      --  safety is not compromised by this approach.
+
+      type Table_Ptr is access all Big_Table_Type;
+      --  The table is actually represented as a pointer to allow reallocation
+
+      Table : aliased Table_Ptr := null;
+      --  The table itself. The lower bound is the value of Low_Bound.
+      --  Logically the upper bound is the current value of Last (although
+      --  the actual size of the allocated table may be larger than this).
+      --  The program may only access and modify Table entries in the range
+      --  First .. Last.
+
+      Locked : Boolean := False;
+      --  Table expansion is permitted only if this switch is set to False. A
+      --  client may set Locked to True, in which case any attempt to expand
+      --  the table will cause an assertion failure. Note that while a table
+      --  is locked, its address in memory remains fixed and unchanging. This
+      --  feature is used to control table expansion during Gigi processing.
+      --  Gigi assumes that tables other than the Uint and Ureal tables do
+      --  not move during processing, which means that they cannot be expanded.
+      --  The Locked flag is used to enforce this restriction.
+
+      procedure Init;
+      --  This procedure allocates a new table of size Initial (freeing any
+      --  previously allocated larger table). It is not necessary to call
+      --  Init when a table is first instantiated (since the instantiation does
+      --  the same initialization steps). However, it is harmless to do so, and
+      --  Init is convenient in reestablishing a table for new use.
+
+      function Last return Table_Index_Type;
+      pragma Inline (Last);
+      --  Returns the current value of the last used entry in the table, which
+      --  can then be used as a subscript for Table. Note that the only way to
+      --  modify Last is to call the Set_Last procedure. Last must always be
+      --  used to determine the logically last entry.
+
+      procedure Release;
+      --  Storage is allocated in chunks according to the values given in the
+      --  Initial and Increment parameters. A call to Release releases all
+      --  storage that is allocated, but is not logically part of the current
+      --  array value. Current array values are not affected by this call.
+
+      procedure Free;
+      --  Free all allocated memory for the table. A call to init is required
+      --  before any use of this table after calling Free.
+
+      First : constant Table_Index_Type := Table_Low_Bound;
+      --  Export First as synonym for Low_Bound (parallel with use of Last)
+
+      procedure Set_Last (New_Val : Table_Index_Type);
+      pragma Inline (Set_Last);
+      --  This procedure sets Last to the indicated value. If necessary the
+      --  table is reallocated to accomodate the new value (i.e. on return
+      --  the allocated table has an upper bound of at least Last). If Set_Last
+      --  reduces the size of the table, then logically entries are removed
+      --  from the table. If Set_Last increases the size of the table, then
+      --  new entries are logically added to the table.
+
+      procedure Increment_Last;
+      pragma Inline (Increment_Last);
+      --  Adds 1 to Last (same as Set_Last (Last + 1).
+
+      procedure Decrement_Last;
+      pragma Inline (Decrement_Last);
+      --  Subtracts 1 from Last (same as Set_Last (Last - 1).
+
+      procedure Append (New_Val : Table_Component_Type);
+      pragma Inline (Append);
+      --  Equivalent to:
+      --    x.Increment_Last;
+      --    x.Table (x.Last) := New_Val;
+      --  i.e. the table size is increased by one, and the given new item
+      --  stored in the newly created table element.
+
+      procedure Set_Item
+        (Index : Table_Index_Type;
+         Item  : Table_Component_Type);
+      pragma Inline (Set_Item);
+      --  Put Item in the table at position Index. The table is expanded if
+      --  current table length is less than Index and in that case Last is set
+      --  to Index. Item will replace any value already present in the table
+      --  at this position.
+
+      type Saved_Table is private;
+      --  Type used for Save/Restore subprograms
+
+      function Save return Saved_Table;
+      --  Resets table to empty, but saves old contents of table in returned
+      --  value, for possible later restoration by a call to Restore.
+
+      procedure Restore (T : Saved_Table);
+      --  Given a Saved_Table value returned by a prior call to Save, restores
+      --  the table to the state it was in at the time of the Save call.
+
+      procedure Tree_Write;
+      --  Writes out contents of table using Tree_IO
+
+      procedure Tree_Read;
+      --  Initializes table by reading contents previously written
+      --  with the Tree_Write call (also using Tree_IO)
+
+   private
+
+      Last_Val : Int;
+      --  Current value of Last. Note that we declare this in the private part
+      --  because we don't want the client to modify Last except through one of
+      --  the official interfaces (since a modification to Last may require a
+      --  reallocation of the table).
+
+      Max : Int;
+      --  Subscript of the maximum entry in the currently allocated table
+
+      type Saved_Table is record
+         Last_Val : Int;
+         Max      : Int;
+         Table    : Table_Ptr;
+      end record;
+
+   end Table;
+end Table;

gcc/ada/targparm.adb

@@ -0,0 +1,228 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                        GNAT RUN-TIME COMPONENTS                          --
+--                                                                          --
+--                             T A R G P A R M                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.15 $
+--                                                                          --
+--          Copyright (C) 1999-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.                                                      --
+--                                                                          --
+-- 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 Namet;    use Namet;
+with Output;   use Output;
+with Sinput;   use Sinput;
+with Sinput.L; use Sinput.L;
+with Fname.UF; use Fname.UF;
+with Types;    use Types;
+
+package body Targparm is
+
+   type Targparm_Tags is
+     (AAM, CLA, DEN, DSP, FEL, HIM, LSI, MOV,
+      MRN, SCD, SCP, SNZ, UAM, VMS, ZCD, ZCG, ZCF);
+
+   Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
+   --  Flag is set True if corresponding parameter is scanned
+
+   AAM_Str : aliased constant Source_Buffer := "AAMP";
+   CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
+   DEN_Str : aliased constant Source_Buffer := "Denorm";
+   DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP";
+   FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
+   HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
+   LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
+   MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
+   MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
+   SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
+   SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
+   SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
+   UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
+   VMS_Str : aliased constant Source_Buffer := "OpenVMS";
+   ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
+   ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
+   ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
+
+   type Buffer_Ptr is access constant Source_Buffer;
+   Targparm_Str : array (Targparm_Tags) of Buffer_Ptr :=
+     (AAM_Str'Access,
+      CLA_Str'Access,
+      DEN_Str'Access,
+      DSP_Str'Access,
+      FEL_Str'Access,
+      HIM_Str'Access,
+      LSI_Str'Access,
+      MOV_Str'Access,
+      MRN_Str'Access,
+      SCD_Str'Access,
+      SCP_Str'Access,
+      SNZ_Str'Access,
+      UAM_Str'Access,
+      VMS_Str'Access,
+      ZCD_Str'Access,
+      ZCG_Str'Access,
+      ZCF_Str'Access);
+
+   ---------------------------
+   -- Get_Target_Parameters --
+   ---------------------------
+
+   procedure Get_Target_Parameters is
+      use ASCII;
+
+      S : Source_File_Index;
+      N : Name_Id;
+      T : Source_Buffer_Ptr;
+      P : Source_Ptr;
+      Z : Source_Ptr;
+
+      Fatal : Boolean := False;
+      --  Set True if a fatal error is detected
+
+      Result : Boolean;
+      --  Records boolean from system line
+
+   begin
+      Name_Buffer (1 .. 6) := "system";
+      Name_Len := 6;
+      N := File_Name_Of_Spec (Name_Find);
+      S := Load_Source_File (N);
+
+      if S = No_Source_File then
+         Write_Line ("fatal error, run-time library not installed correctly");
+         Write_Str ("cannot locate file ");
+         Write_Line (Name_Buffer (1 .. Name_Len));
+         raise Unrecoverable_Error;
+
+      --  This must always be the first source file read, and we have defined
+      --  a constant Types.System_Source_File_Index as 1 to reflect this.
+
+      else
+         pragma Assert (S = System_Source_File_Index);
+         null;
+      end if;
+
+      P := Source_First (S);
+      Z := Source_Last  (S);
+      T := Source_Text  (S);
+
+      while T (P .. P + 10) /= "end System;" loop
+
+         for K in Targparm_Tags loop
+            if T (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
+                                                   Targparm_Str (K).all
+            then
+               P := P + 3 + Targparm_Str (K)'Length;
+
+               if Targparm_Flags (K) then
+                  Set_Standard_Error;
+                  Write_Line
+                    ("fatal error: system.ads is incorrectly formatted");
+                  Write_Str ("duplicate line for parameter: ");
+
+                  for J in Targparm_Str (K)'Range loop
+                     Write_Char (Targparm_Str (K).all (J));
+                  end loop;
+
+                  Write_Eol;
+                  Set_Standard_Output;
+                  Fatal := True;
+
+               else
+                  Targparm_Flags (K) := True;
+               end if;
+
+               while T (P) /= ':' or else T (P + 1) /= '=' loop
+                  P := P + 1;
+               end loop;
+
+               P := P + 2;
+
+               while T (P) = ' ' loop
+                  P := P + 1;
+               end loop;
+
+               Result := (T (P) = 'T');
+
+               case K is
+                  when AAM => AAMP_On_Target                      := Result;
+                  when CLA => Command_Line_Args_On_Target         := Result;
+                  when DEN => Denorm_On_Target                    := Result;
+                  when DSP => Functions_Return_By_DSP_On_Target   := Result;
+                  when FEL => Frontend_Layout_On_Target           := Result;
+                  when HIM => High_Integrity_Mode_On_Target       := Result;
+                  when LSI => Long_Shifts_Inlined_On_Target       := Result;
+                  when MOV => Machine_Overflows_On_Target         := Result;
+                  when MRN => Machine_Rounds_On_Target            := Result;
+                  when SCD => Stack_Check_Default_On_Target       := Result;
+                  when SCP => Stack_Check_Probes_On_Target        := Result;
+                  when SNZ => Signed_Zeros_On_Target              := Result;
+                  when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
+                  when VMS => OpenVMS_On_Target                   := Result;
+                  when ZCD => ZCX_By_Default_On_Target            := Result;
+                  when ZCG => GCC_ZCX_Support_On_Target           := Result;
+                  when ZCF => Front_End_ZCX_Support_On_Target     := Result;
+               end case;
+
+               exit;
+            end if;
+         end loop;
+
+         while T (P) /= CR and then T (P) /= LF loop
+            P := P + 1;
+            exit when P >= Z;
+         end loop;
+
+         while T (P) = CR or else T (P) = LF loop
+            P := P + 1;
+            exit when P >= Z;
+         end loop;
+
+         if P >= Z then
+            Set_Standard_Error;
+            Write_Line ("fatal error, system.ads not formatted correctly");
+            Set_Standard_Output;
+            raise Unrecoverable_Error;
+         end if;
+      end loop;
+
+      for K in Targparm_Tags loop
+         if not Targparm_Flags (K) then
+            Set_Standard_Error;
+            Write_Line
+              ("fatal error: system.ads is incorrectly formatted");
+            Write_Str ("missing line for parameter: ");
+
+            for J in Targparm_Str (K)'Range loop
+               Write_Char (Targparm_Str (K).all (J));
+            end loop;
+
+            Write_Eol;
+            Set_Standard_Output;
+            Fatal := True;
+         end if;
+      end loop;
+
+      if Fatal then
+         raise Unrecoverable_Error;
+      end if;
+   end Get_Target_Parameters;
+
+end Targparm;

gcc/ada/targparm.ads

@@ -0,0 +1,288 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                        GNAT RUN-TIME COMPONENTS                          --
+--                                                                          --
+--                             T A R G P A R M                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.13 $
+--                                                                          --
+--          Copyright (C) 1999-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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package obtains parameters from the target runtime version of
+--  System, to indicate parameters relevant to the target environment.
+
+--  Conceptually, these parameters could be obtained using rtsfind, but
+--  we do not do this for three reasons:
+
+--    1. Compiling System for every compilation wastes time
+--    2. This compilation impedes debugging by adding extra compile steps
+--    3. There are recursion problems coming from compiling System itself
+--        or any of its children.
+
+--  For all these reasons, we read in the source of System, and then scan
+--  it at the text level to extract the parameter values.
+
+--  Note however, that later on, when the ali file is written, we make sure
+--  that the System file is at least parsed, so that the checksum is properly
+--  computed and set in the ali file. This partially negates points 1 and 2
+--  above although just parsing is quick and does not impact debugging much.
+
+package Targparm is
+
+   --  The following parameters correspond to the variables defined in the
+   --  private part of System (without the terminating _On_Target). Note
+   --  that it is required that all parameters be specified in system.ads.
+
+   -----------------------------------
+   -- Control of Exception Handling --
+   -----------------------------------
+
+   --  GNAT provides two methods of implementing exceptions:
+
+   --    Longjmp/Setjmp (-gnatL)
+
+   --      This approach uses longjmp/setjmp to handle exceptions. It
+   --      uses less storage, and can often propagate exceptions faster,
+   --      at the expense of (sometimes considerable) overhead in setting
+   --      up an exception handler. This approach is available on all
+   --      targets, and is the default where it is the only approach.
+
+   --    Zero Cost (-gnatZ)
+
+   --      This approach uses separate exception tables. These use extra
+   --      storage, and exception propagation can be quite slow, but there
+   --      is no overhead in setting up an exception handler (it is to this
+   --      latter operation that the phrase zero-cost refers). This approach
+   --      is only available on some targets, and is the default where it is
+   --      available.
+
+   ZCX_By_Default_On_Target : Boolean;
+   --  Indicates if zero cost exceptions are active by default. Can be modified
+   --  by the use of -gnatZ and -gnatL switches.
+
+   GCC_ZCX_Support_On_Target  : Boolean;
+   --  Indicates that when ZCX is active the mechanism to be used is the
+   --  standard GCC ZCX mechanism  (introduced in GCC 3.1)
+
+   Front_End_ZCX_Support_On_Target : Boolean;
+   --  Indicates that when ZCX is active (and GCC_ZCX_Support is not set)
+   --  the mechanism to be used is the GNAT front end specific ZCX mechanism
+
+   ---------------------------------------
+   -- High_Integrity (No Run Time) Mode --
+   ---------------------------------------
+
+   --  In High_Integrity mode, there is no system run-time, and the flag
+   --  Opt.No_Run_Time is set so that the language is appropriately
+   --  restricted to forbid construct that would generate run-time calls.
+
+   High_Integrity_Mode_On_Target : Boolean;
+   --  Indicates that this build is for a high integrity mode version of
+   --  GNAT, so that no run time is permitted.
+
+   -------------------------------
+   -- Control of Stack Checking --
+   -------------------------------
+
+   --  GNAT provides two methods of implementing exceptions:
+
+   --    GCC Probing Mechanism
+
+   --      This approach uses the standard GCC mechanism for
+   --      stack checking. The method assumes that accessing
+   --      storage immediately beyond the end of the stack
+   --      will result in a trap that is converted to a storage
+   --      error by the runtime system. This mechanism has
+   --      minimal overhead, but requires complex hardware,
+   --      operating system and run-time support. Probing is
+   --      the default method where it is available. The stack
+   --      size for the environment task depends on the operating
+   --      system and cannot be set in a system-independent way.
+
+   --   GNAT Stack-limit Checking
+
+   --      This method relies on comparing the stack pointer
+   --      with per-task stack limits. If the check fails, an
+   --      exception is explicitly raised. The advantage is
+   --      that the method requires no extra system dependent
+   --      runtime support and can be used on systems without
+   --      memory protection as well, but at the cost of more
+   --      overhead for doing the check. This method is the
+   --      default on systems that lack complete support for
+   --      probing.
+
+   Stack_Check_Probes_On_Target : Boolean;
+   --  Indicates if stack check probes are used, as opposed to the standard
+   --  target independent comparison method.
+
+   Stack_Check_Default_On_Target : Boolean;
+   --  Indicates if stack checking is on by default
+
+   ----------------------------
+   -- Command Line Arguments --
+   ----------------------------
+
+   --  For most ports of GNAT, command line arguments are supported. The
+   --  following flag is set to False for targets that do not support
+   --  command line arguments (notably VxWorks).
+
+   Command_Line_Args_On_Target : Boolean;
+   --  Set False if no command line arguments on target
+
+   --  Note: this is prepared for future use, but not yet used, since we
+   --  do not yet have a way of propagating Targparm params to the binder
+
+   -----------------------
+   -- Main Program Name --
+   -----------------------
+
+   --  When the binder generates the main program to be used to create the
+   --  executable, the main program name is main by default (to match the
+   --  usual Unix practice). If this parameter is set to True, then the
+   --  name is instead by default taken from the actual Ada main program
+   --  name (just the name of the child if the main program is a child unit).
+   --  In either case, this value can be overridden using -M name.
+
+   Use_Ada_Main_Program_Name_On_Target : Boolean;
+   --  Set True to use the Ada main program name as the main name
+
+   --  Note: this is prepared for future use, but not yet used, since we
+   --  do not yet have a way of propagating Targparm params to the binder
+
+   ----------------------------
+   -- Support of Long Shifts --
+   ----------------------------
+
+   --  In GNORT mode, we cannot call library routines, and in particular
+   --  we cannot call routines for long (64-bit) shifts if such routines
+   --  are required on the target. This comes up in the context of support
+   --  of packed arrays. We can only represent packed arrays whose length
+   --  is in the range 33- to 64-bits as modular types if long shifts are
+   --  done with inline code.
+
+   --  For the default version, for now we set long shifts inlined as True
+   --  This may not be quite accurate, but until we get proper separate
+   --  System's for each target, it is a safer choice.
+
+   Long_Shifts_Inlined_On_Target : Boolean;
+   --  Indicates if long (double word) shifts are generated using inlined
+   --  code (and thus are permissible in No_Run_Time mode).
+
+   ----------------------------------------------
+   -- Boolean-Valued Floating-Point Attributes --
+   ----------------------------------------------
+
+   --  The constants below give the values for representation oriented
+   --  floating-point attributes that are the same for all float types
+   --  on the target. These are all boolean values.
+
+   --  A value is only True if the target reliably supports the corresponding
+   --  feature. Reliably here means that support is guaranteed for all
+   --  possible settings of the relevant compiler switches (like -mieee),
+   --  since we cannot control the user setting of those switches.
+
+   --  The attributes cannot dependent on the current setting of compiler
+   --  switches, since the values must be static and consistent throughout
+   --  the partition. We probably should add such consistency checks in future,
+   --  but for now we don't do this.
+
+   AAMP_On_Target : Boolean;
+   --  Set to True if target is AAMP.
+
+   Denorm_On_Target : Boolean;
+   --  Set to False on targets that do not reliably support denormals.
+   --  Reliably here means for all settings of the relevant -m flag, so
+   --  for example, this is False on the Alpha where denormals are not
+   --  supported unless -mieee is used.
+
+   Machine_Rounds_On_Target : Boolean;
+   --  Set to False for targets where S'Machine_Rounds is False
+
+   Machine_Overflows_On_Target : Boolean;
+   --  Set to True for targets where S'Machine_Overflows is True
+
+   Signed_Zeros_On_Target : Boolean;
+   --  Set to False on targets that do not reliably support signed zeros.
+
+   OpenVMS_On_Target : Boolean;
+   --  Set to True if target is OpenVMS.
+
+   --------------------------------------------------------------
+   -- Handling of Unconstrained Values Returned from Functions --
+   --------------------------------------------------------------
+
+   --  Functions that return variable length objects, notably unconstrained
+   --  arrays are a special case, because there is no simple obvious way of
+   --  implementing this feature. Furthermore, this capability is not present
+   --  in C++ or C, so typically the system ABI does not handle this case.
+
+   --  GNAT uses two different approaches
+
+   --    The Secondary Stack
+
+   --      The secondary stack is a special storage pool that is used for
+   --      this purpose. The called function places the result on the
+   --      secondary stack, and the caller uses or copies the value from
+   --      the secondary stack, and pops the secondary stack after the
+   --      value is consumed. The secondary stack is outside the system
+   --      ABI, and the important point is that although generally it is
+   --      handled in a stack like manner corresponding to the subprogram
+   --      call structure, a return from a function does NOT pop the stack.
+
+   --    DSP (Depressed Stack Pointer)
+
+   --      Some targets permit the implementation of a function call/return
+   --      protocol in which the function does not pop the main stack pointer
+   --      on return, but rather returns with the stack pointer depressed.
+   --      This is not generally permitted by any ABI, but for at least some
+   --      targets, the implementation of alloca provides a model for this
+   --      approach. If return-with-DSP is implemented, then functions that
+   --      return variable length objects do it by returning with the stack
+   --      pointer depressed, and the returned object is a pointer to the
+   --      area within the stack frame of the called procedure that contains
+   --      the returned value. The caller must then pop the main stack when
+   --      this value is consumed.
+
+   Functions_Return_By_DSP_On_Target : Boolean;
+   --  Set to True if target permits functions to return with using the
+   --  DSP (depressed stack pointer) approach.
+
+   -----------------
+   -- Data Layout --
+   -----------------
+
+   --  Normally when using the GCC backend, Gigi and GCC perform much of the
+   --  data layout using the standard layout capabilities of GCC. If the
+   --  parameter Backend_Layout is set to False, then the front end must
+   --  perform all data layout. For further details see the package Layout.
+
+   Frontend_Layout_On_Target : Boolean;
+   --  Set True if front end does layout
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Get_Target_Parameters;
+   --  Called at the start of execution to read the source of System and
+   --  obtain and set the values of the above parameters.
+
+end Targparm;

gcc/ada/targtyps.c

@@ -0,0 +1,226 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                            T A R G T Y P S                               *
+ *                                                                          *
+ *                                  Body                                    *
+ *                                                                          *
+ *                             $Revision: 1.1 $
+ *                                                                          *
+ *          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 you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion 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). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* Functions for retrieving target types. See Ada package Get_Targ */
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "real.h"
+#include "rtl.h"
+#include "ada.h"
+#include "types.h"
+#include "atree.h"
+#include "elists.h"
+#include "namet.h"
+#include "nlists.h"
+#include "snames.h"
+#include "stringt.h"
+#include "uintp.h"
+#include "urealp.h"
+#include "fe.h"
+#include "sinfo.h"
+#include "einfo.h"
+#include "ada-tree.h"
+#include "gigi.h"
+
+#define MIN(X,Y) ((X) < (Y) ? (X) : (Y))
+
+/* Standard data type sizes.  Most of these are not used.  */
+
+#ifndef CHAR_TYPE_SIZE
+#define CHAR_TYPE_SIZE BITS_PER_UNIT
+#endif
+
+#ifndef SHORT_TYPE_SIZE
+#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
+#endif
+
+#ifndef INT_TYPE_SIZE
+#define INT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#ifdef OPEN_VMS /* A target macro defined in vms.h */
+#define LONG_TYPE_SIZE 64
+#else
+#ifndef LONG_TYPE_SIZE
+#define LONG_TYPE_SIZE BITS_PER_WORD
+#endif
+#endif
+
+#ifndef LONG_LONG_TYPE_SIZE
+#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+#ifndef FLOAT_TYPE_SIZE
+#define FLOAT_TYPE_SIZE BITS_PER_WORD
+#endif
+
+#ifndef DOUBLE_TYPE_SIZE
+#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+#ifndef LONG_DOUBLE_TYPE_SIZE
+#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
+#endif
+
+#ifndef WIDEST_HARDWARE_FP_SIZE
+#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE
+#endif
+
+/* The following provide a functional interface for the front end Ada code
+   to determine the sizes that are used for various C types. */
+
+Pos
+get_target_bits_per_unit ()
+{
+  return BITS_PER_UNIT;
+}
+
+Pos
+get_target_bits_per_word ()
+{
+  return BITS_PER_WORD;
+}
+
+Pos
+get_target_char_size ()
+{
+  return CHAR_TYPE_SIZE;
+}
+
+Pos
+get_target_wchar_t_size ()
+{
+  /* We never want wide chacters less than "short" in Ada.  */
+  return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE);
+}
+
+Pos
+get_target_short_size ()
+{
+  return SHORT_TYPE_SIZE;
+}
+
+Pos
+get_target_int_size ()
+{
+  return INT_TYPE_SIZE;
+}
+
+Pos
+get_target_long_size ()
+{
+  return LONG_TYPE_SIZE;
+}
+
+Pos
+get_target_long_long_size ()
+{
+  return LONG_LONG_TYPE_SIZE;
+}
+
+Pos
+get_target_float_size ()
+{
+  return FLOAT_TYPE_SIZE;
+}
+
+Pos
+get_target_double_size ()
+{
+  return DOUBLE_TYPE_SIZE;
+}
+
+Pos
+get_target_long_double_size ()
+{
+  return WIDEST_HARDWARE_FP_SIZE;
+}
+
+Pos
+get_target_pointer_size ()
+{
+  return POINTER_SIZE;
+}
+
+Pos
+get_target_maximum_alignment ()
+{
+  return BIGGEST_ALIGNMENT / BITS_PER_UNIT;
+}
+
+Boolean
+get_target_no_dollar_in_label ()
+{
+#ifdef NO_DOLLAR_IN_LABEL
+  return 1;
+#else
+  return 0;
+#endif
+}
+
+#ifndef FLOAT_WORDS_BIG_ENDIAN
+#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN
+#endif
+
+Nat
+get_float_words_be ()
+{
+  return FLOAT_WORDS_BIG_ENDIAN;
+}
+
+Nat
+get_words_be ()
+{
+  return WORDS_BIG_ENDIAN;
+}
+
+Nat
+get_bytes_be ()
+{
+  return BYTES_BIG_ENDIAN;
+}
+
+Nat
+get_bits_be ()
+{
+  return BITS_BIG_ENDIAN;
+}
+
+Nat
+get_strict_alignment ()
+{
+  return STRICT_ALIGNMENT;
+}

gcc/ada/tbuild.adb

@@ -0,0 +1,522 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T B U I L D                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.98 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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 Atree;    use Atree;
+with Einfo;    use Einfo;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Restrict; use Restrict;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Uintp;    use Uintp;
+
+package body Tbuild is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Add_Unique_Serial_Number;
+   --  Add a unique serialization to the string in the Name_Buffer. This
+   --  consists of a unit specific serial number, and b/s for body/spec.
+
+   ------------------------------
+   -- Add_Unique_Serial_Number --
+   ------------------------------
+
+   procedure Add_Unique_Serial_Number is
+      Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+
+   begin
+      Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+
+      --  Add either b or s, depending on whether current unit is a spec
+      --  or a body. This is needed because we may generate the same name
+      --  in a spec and a body otherwise.
+
+      Name_Len := Name_Len + 1;
+
+      if Nkind (Unit_Node) = N_Package_Declaration
+        or else Nkind (Unit_Node) = N_Subprogram_Declaration
+        or else Nkind (Unit_Node) in N_Generic_Declaration
+      then
+         Name_Buffer (Name_Len) := 's';
+      else
+         Name_Buffer (Name_Len) := 'b';
+      end if;
+   end Add_Unique_Serial_Number;
+
+   ----------------
+   -- Checks_Off --
+   ----------------
+
+   function Checks_Off (N : Node_Id) return Node_Id is
+   begin
+      return
+        Make_Unchecked_Expression (Sloc (N),
+          Expression => N);
+   end Checks_Off;
+
+   ----------------
+   -- Convert_To --
+   ----------------
+
+   function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
+      Result : Node_Id;
+
+   begin
+      if Present (Etype (Expr))
+        and then (Etype (Expr)) = Typ
+      then
+         return Relocate_Node (Expr);
+      else
+         Result :=
+           Make_Type_Conversion (Sloc (Expr),
+             Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
+             Expression => Relocate_Node (Expr));
+
+         Set_Etype (Result, Typ);
+         return Result;
+      end if;
+   end Convert_To;
+
+   --------------------
+   -- Make_DT_Access --
+   --------------------
+
+   function Make_DT_Access
+     (Loc  : Source_Ptr;
+      Rec  : Node_Id;
+      Typ  : Entity_Id)
+      return Node_Id
+   is
+      Full_Type : Entity_Id := Typ;
+
+   begin
+      if Is_Private_Type (Typ) then
+         Full_Type := Underlying_Type (Typ);
+      end if;
+
+      return
+        Unchecked_Convert_To (
+          New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
+          Make_Selected_Component (Loc,
+            Prefix => New_Copy (Rec),
+            Selector_Name =>
+              New_Reference_To (Tag_Component (Full_Type), Loc)));
+   end Make_DT_Access;
+
+   -----------------------
+   -- Make_DT_Component --
+   -----------------------
+
+   function Make_DT_Component
+     (Loc  : Source_Ptr;
+      Typ  : Entity_Id;
+      I    : 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 (Access_Disp_Table (Full_Type))));
+
+      for J in 2 .. I loop
+         X := Next_Component (X);
+      end loop;
+
+      return New_Reference_To (X, Loc);
+   end Make_DT_Component;
+
+   --------------------------------
+   -- Make_Implicit_If_Statement --
+   --------------------------------
+
+   function Make_Implicit_If_Statement
+     (Node            : Node_Id;
+      Condition       : Node_Id;
+      Then_Statements : List_Id;
+      Elsif_Parts     : List_Id := No_List;
+      Else_Statements : List_Id := No_List)
+      return            Node_Id
+   is
+   begin
+      Check_Restriction (No_Implicit_Conditionals, Node);
+      return Make_If_Statement (Sloc (Node),
+        Condition,
+        Then_Statements,
+        Elsif_Parts,
+        Else_Statements);
+   end Make_Implicit_If_Statement;
+
+   -------------------------------------
+   -- Make_Implicit_Label_Declaration --
+   -------------------------------------
+
+   function Make_Implicit_Label_Declaration
+     (Loc                 : Source_Ptr;
+      Defining_Identifier : Node_Id;
+      Label_Construct     : Node_Id)
+      return                Node_Id
+   is
+      N : constant Node_Id :=
+            Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
+
+   begin
+      Set_Label_Construct (N, Label_Construct);
+      return N;
+   end Make_Implicit_Label_Declaration;
+
+   ----------------------------------
+   -- Make_Implicit_Loop_Statement --
+   ----------------------------------
+
+   function Make_Implicit_Loop_Statement
+     (Node                   : Node_Id;
+      Statements             : List_Id;
+      Identifier             : Node_Id := Empty;
+      Iteration_Scheme       : Node_Id := Empty;
+      Has_Created_Identifier : Boolean := False;
+      End_Label              : Node_Id := Empty)
+      return                   Node_Id
+   is
+   begin
+      Check_Restriction (No_Implicit_Loops, Node);
+
+      if Present (Iteration_Scheme)
+        and then Present (Condition (Iteration_Scheme))
+      then
+         Check_Restriction (No_Implicit_Conditionals, Node);
+      end if;
+
+      return Make_Loop_Statement (Sloc (Node),
+        Identifier             => Identifier,
+        Iteration_Scheme       => Iteration_Scheme,
+        Statements             => Statements,
+        Has_Created_Identifier => Has_Created_Identifier,
+        End_Label              => End_Label);
+   end Make_Implicit_Loop_Statement;
+
+   --------------------------
+   -- Make_Integer_Literal --
+   ---------------------------
+
+   function Make_Integer_Literal
+     (Loc    : Source_Ptr;
+      Intval : Int)
+      return   Node_Id
+   is
+   begin
+      return Make_Integer_Literal (Loc, UI_From_Int (Intval));
+   end Make_Integer_Literal;
+
+   ---------------------------
+   -- Make_Unsuppress_Block --
+   ---------------------------
+
+   --  Generates the following expansion:
+
+   --    declare
+   --       pragma Suppress (<check>);
+   --    begin
+   --       <stmts>
+   --    end;
+
+   function Make_Unsuppress_Block
+     (Loc   : Source_Ptr;
+      Check : Name_Id;
+      Stmts : List_Id)
+      return  Node_Id
+   is
+   begin
+      return
+        Make_Block_Statement (Loc,
+          Declarations => New_List (
+            Make_Pragma (Loc,
+              Chars => Name_Suppress,
+              Pragma_Argument_Associations => New_List (
+                Make_Pragma_Argument_Association (Loc,
+                  Expression => Make_Identifier (Loc, Check))))),
+
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => Stmts));
+   end Make_Unsuppress_Block;
+
+   --------------------------
+   -- New_Constraint_Error --
+   --------------------------
+
+   function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
+      Ident_Node : Node_Id;
+      Raise_Node : Node_Id;
+
+   begin
+      Ident_Node := New_Node (N_Identifier, Loc);
+      Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
+      Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
+      Raise_Node := New_Node (N_Raise_Statement, Loc);
+      Set_Name (Raise_Node, Ident_Node);
+      return Raise_Node;
+   end New_Constraint_Error;
+
+   -----------------------
+   -- New_External_Name --
+   -----------------------
+
+   function New_External_Name
+     (Related_Id   : Name_Id;
+      Suffix       : Character := ' ';
+      Suffix_Index : Int       := 0;
+      Prefix       : Character := ' ')
+      return         Name_Id
+   is
+   begin
+      Get_Name_String (Related_Id);
+
+      if Prefix /= ' ' then
+         pragma Assert (Is_OK_Internal_Letter (Prefix));
+
+         for J in reverse 1 .. Name_Len loop
+            Name_Buffer (J + 1) := Name_Buffer (J);
+         end loop;
+
+         Name_Len := Name_Len + 1;
+         Name_Buffer (1) := Prefix;
+      end if;
+
+      if Suffix /= ' ' then
+         pragma Assert (Is_OK_Internal_Letter (Suffix));
+         Name_Len := Name_Len + 1;
+         Name_Buffer (Name_Len) := Suffix;
+      end if;
+
+      if Suffix_Index /= 0 then
+         if Suffix_Index < 0 then
+            Add_Unique_Serial_Number;
+         else
+            Add_Nat_To_Name_Buffer (Suffix_Index);
+         end if;
+      end if;
+
+      return Name_Find;
+   end New_External_Name;
+
+   function New_External_Name
+     (Related_Id   : Name_Id;
+      Suffix       : String;
+      Suffix_Index : Int       := 0;
+      Prefix       : Character := ' ')
+      return         Name_Id
+   is
+   begin
+      Get_Name_String (Related_Id);
+
+      if Prefix /= ' ' then
+         pragma Assert (Is_OK_Internal_Letter (Prefix));
+
+         for J in reverse 1 .. Name_Len loop
+            Name_Buffer (J + 1) := Name_Buffer (J);
+         end loop;
+
+         Name_Len := Name_Len + 1;
+         Name_Buffer (1) := Prefix;
+      end if;
+
+      if Suffix /= "" then
+         Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
+         Name_Len := Name_Len + Suffix'Length;
+      end if;
+
+      if Suffix_Index /= 0 then
+         if Suffix_Index < 0 then
+            Add_Unique_Serial_Number;
+         else
+            Add_Nat_To_Name_Buffer (Suffix_Index);
+         end if;
+      end if;
+
+      return Name_Find;
+   end New_External_Name;
+
+   function New_External_Name
+     (Suffix       : Character;
+      Suffix_Index : Nat)
+      return         Name_Id
+   is
+   begin
+      Name_Buffer (1) := Suffix;
+      Name_Len := 1;
+      Add_Nat_To_Name_Buffer (Suffix_Index);
+      return Name_Find;
+   end New_External_Name;
+
+   -----------------------
+   -- New_Internal_Name --
+   -----------------------
+
+   function New_Internal_Name (Id_Char : Character) return Name_Id is
+   begin
+      pragma Assert (Is_OK_Internal_Letter (Id_Char));
+      Name_Buffer (1) := Id_Char;
+      Name_Len := 1;
+      Add_Unique_Serial_Number;
+      return Name_Enter;
+   end New_Internal_Name;
+
+   -----------------------
+   -- New_Occurrence_Of --
+   -----------------------
+
+   function New_Occurrence_Of
+     (Def_Id : Entity_Id;
+      Loc    : Source_Ptr)
+      return   Node_Id
+   is
+      Occurrence : Node_Id;
+
+   begin
+      Occurrence := New_Node (N_Identifier, Loc);
+      Set_Chars (Occurrence, Chars (Def_Id));
+      Set_Entity (Occurrence, Def_Id);
+
+      if Is_Type (Def_Id) then
+         Set_Etype (Occurrence, Def_Id);
+      else
+         Set_Etype (Occurrence, Etype (Def_Id));
+      end if;
+
+      return Occurrence;
+   end New_Occurrence_Of;
+
+   ----------------------
+   -- New_Reference_To --
+   ----------------------
+
+   function New_Reference_To
+     (Def_Id : Entity_Id;
+      Loc    : Source_Ptr)
+      return   Node_Id
+   is
+      Occurrence : Node_Id;
+
+   begin
+      Occurrence := New_Node (N_Identifier, Loc);
+      Set_Chars (Occurrence, Chars (Def_Id));
+      Set_Entity (Occurrence, Def_Id);
+      return Occurrence;
+   end New_Reference_To;
+
+   -----------------------
+   -- New_Suffixed_Name --
+   -----------------------
+
+   function New_Suffixed_Name
+     (Related_Id : Name_Id;
+      Suffix     : String)
+      return       Name_Id
+   is
+   begin
+      Get_Name_String (Related_Id);
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := '_';
+      Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
+      Name_Len := Name_Len + Suffix'Length;
+      return Name_Find;
+   end New_Suffixed_Name;
+
+   -------------------
+   -- OK_Convert_To --
+   -------------------
+
+   function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
+      Result : Node_Id;
+
+   begin
+      Result :=
+        Make_Type_Conversion (Sloc (Expr),
+          Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
+          Expression   => Relocate_Node (Expr));
+      Set_Conversion_OK (Result, True);
+      Set_Etype (Result, Typ);
+      return Result;
+   end OK_Convert_To;
+
+   --------------------------
+   -- Unchecked_Convert_To --
+   --------------------------
+
+   function Unchecked_Convert_To
+     (Typ  : Entity_Id;
+      Expr : Node_Id)
+      return Node_Id
+   is
+      Loc    : constant Source_Ptr := Sloc (Expr);
+      Result : Node_Id;
+
+   begin
+      --  If the expression is already of the correct type, then nothing
+      --  to do, except for relocating the node in case this is required.
+
+      if Present (Etype (Expr))
+        and then (Base_Type (Etype (Expr)) = Typ
+                   or else Etype (Expr) = Typ)
+      then
+         return Relocate_Node (Expr);
+
+      --  Cases where the inner expression is itself an unchecked conversion
+      --  to the same type, and we can thus eliminate the outer conversion.
+
+      elsif Nkind (Expr) = N_Unchecked_Type_Conversion
+        and then Entity (Subtype_Mark (Expr)) = Typ
+      then
+         Result := Relocate_Node (Expr);
+
+      --  All other cases
+
+      else
+         Result :=
+           Make_Unchecked_Type_Conversion (Loc,
+             Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+             Expression   => Relocate_Node (Expr));
+      end if;
+
+      Set_Etype (Result, Typ);
+      return Result;
+   end Unchecked_Convert_To;
+
+end Tbuild;

gcc/ada/tbuild.ads

@@ -0,0 +1,241 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T B U I L D                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.69 $
+--                                                                          --
+--          Copyright (C) 1992-2000, 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains various utility procedures to assist in
+--  building specific types of tree nodes.
+
+with Types; use Types;
+
+package Tbuild is
+
+   function Make_DT_Component
+     (Loc  : Source_Ptr;
+      Typ  : Entity_Id;
+      I    : Positive)
+      return Node_Id;
+   --  Gives a reference to the Ith component of the Dispatch Table of
+   --  a given Tagged Type.
+   --
+   --  I = 1    --> Inheritance_Depth
+   --  I = 2    --> Tags (array of ancestors)
+   --  I = 3, 4 --> predefined primitive
+   --            function _Size (X : Typ) return Long_Long_Integer;
+   --            function _Equality (X : Typ; Y : Typ'Class) return Boolean;
+   --  I >= 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
+   --  of a tagged record : Acc_Dt (Rec.tag).all
+
+   function Make_Implicit_If_Statement
+     (Node            : Node_Id;
+      Condition       : Node_Id;
+      Then_Statements : List_Id;
+      Elsif_Parts     : List_Id := No_List;
+      Else_Statements : List_Id := No_List)
+      return            Node_Id;
+   pragma Inline (Make_Implicit_If_Statement);
+   --  This function makes an N_If_Statement node whose fields are filled
+   --  in with the indicated values (see Sinfo), and whose Sloc field is
+   --  is set to Sloc (Node). The effect is identical to calling function
+   --  Nmake.Make_If_Statement except that there is a check for restriction
+   --  No_Implicit_Conditionals, and if this restriction is being violated,
+   --  an error message is posted on Node.
+
+   function Make_Implicit_Label_Declaration
+     (Loc                 : Source_Ptr;
+      Defining_Identifier : Node_Id;
+      Label_Construct     : Node_Id)
+      return                Node_Id;
+   --  Used to contruct an implicit label declaration node, including setting
+   --  the proper Label_Construct field (since Label_Construct is a semantic
+   --  field, the normal call to Make_Implicit_Label_Declaration does not
+   --  set this field).
+
+   function Make_Implicit_Loop_Statement
+     (Node                   : Node_Id;
+      Statements             : List_Id;
+      Identifier             : Node_Id := Empty;
+      Iteration_Scheme       : Node_Id := Empty;
+      Has_Created_Identifier : Boolean := False;
+      End_Label              : Node_Id := Empty)
+      return                   Node_Id;
+   --  This function makes an N_Loop_Statement node whose fields are filled
+   --  in with the indicated values (see Sinfo), and whose Sloc field is
+   --  is set to Sloc (Node). The effect is identical to calling function
+   --  Nmake.Make_Loop_Statement except that there is a check for restrictions
+   --  No_Implicit_Loops and No_Implicit_Conditionals (the first applying in
+   --  all cases, and the second only for while loops), and if one of these
+   --  restrictions is being violated, an error message is posted on Node.
+
+   function Make_Integer_Literal
+     (Loc    : Source_Ptr;
+      Intval : Int)
+      return   Node_Id;
+   pragma Inline (Make_Integer_Literal);
+   --  A convenient form of Make_Integer_Literal taking Int instead of Uint
+
+   function Make_Unsuppress_Block
+     (Loc   : Source_Ptr;
+      Check : Name_Id;
+      Stmts : List_Id)
+      return  Node_Id;
+   --  Build a block with a pragma Suppress on 'Check'. Stmts is the
+   --  statements list that needs protection against the check
+
+   function New_Constraint_Error (Loc : Source_Ptr) return Node_Id;
+   --  This function builds a tree corresponding to the Ada statement
+   --  "raise Constraint_Error" and returns the root of this tree,
+   --  the N_Raise_Statement node.
+
+   function New_External_Name
+     (Related_Id   : Name_Id;
+      Suffix       : Character := ' ';
+      Suffix_Index : Int       := 0;
+      Prefix       : Character := ' ')
+      return         Name_Id;
+   function New_External_Name
+     (Related_Id   : Name_Id;
+      Suffix       : String;
+      Suffix_Index : Int       := 0;
+      Prefix       : Character := ' ')
+      return         Name_Id;
+   --  Builds a new entry in the names table of the form:
+   --
+   --    [Prefix  &] Related_Id [& Suffix] [& Suffix_Index]
+   --
+   --  Prefix is prepended only if Prefix is non-blank (in which case it
+   --  must be an upper case letter other than O,Q,U,W (which are used for
+   --  identifier encoding, see Namet), and T is reserved for use by implicit
+   --  types. and X is reserved for use by debug type encoding (see package
+   --  Exp_Dbug). Note: the reason that Prefix is last is that it is almost
+   --  always omitted. The notable case of Prefix being non-null is when
+   --  it is 'T' for an implicit type.
+
+   --  Suffix_Index'Image is appended only if the value of Suffix_Index is
+   --  positive, or if Suffix_Index is negative 1, then a unique serialized
+   --  suffix is added. If Suffix_Index is zero, then no index is appended.
+
+   --  Suffix is also a single upper case letter other than O,Q,U,W,X and is a
+   --  required parameter (T is permitted). The constructed name is stored
+   --  using Find_Name so that it can be located using a subsequent Find_Name
+   --  operation (i.e. it is properly hashed into the names table). The upper
+   --  case letter given as the Suffix argument ensures that the name does
+   --  not clash with any Ada identifier name. These generated names are
+   --  permitted, but not required, to be made public by setting the flag
+   --  Is_Public in the associated entity.
+
+   function New_External_Name
+     (Suffix       : Character;
+      Suffix_Index : Nat)
+      return         Name_Id;
+   --  Builds a new entry in the names table of the form
+   --    Suffix & Suffix_Index'Image
+   --  where Suffix is a single upper case letter other than O,Q,U,W,X and is
+   --  a required parameter (T is permitted). The constructed name is stored
+   --  using Find_Name so that it can be located using a subsequent Find_Name
+   --  operation (i.e. it is properly hashed into the names table). The upper
+   --  case letter given as the Suffix argument ensures that the name does
+   --  not clash with any Ada identifier name. These generated names are
+   --  permitted, but not required, to be made public by setting the flag
+   --  Is_Public in the associated entity.
+
+   function New_Internal_Name (Id_Char : Character) return Name_Id;
+   --  Id_Char is an upper case letter other than O,Q,U,W (which are reserved
+   --  for identifier encoding (see Namet package for details) and X which is
+   --  used for debug encoding (see Exp_Dbug). The letter T is permitted, but
+   --  is reserved by convention for the case of internally generated types.
+   --  The result of the call is a new generated unique name of the form XyyyU
+   --  where X is Id_Char, yyy is a unique serial number, and U is either a
+   --  lower case s or b indicating if the current unit is a spec or a body.
+   --
+   --  The name is entered into the names table using Name_Enter rather than
+   --  Name_Find, because there can never be a need to locate the entry using
+   --  the Name_Find procedure later on. Names created by New_Internal_Name
+   --  are guaranteed to be consistent from one compilation to another (i.e.
+   --  if the identical unit is compiled with a semantically consistent set
+   --  of sources, the numbers will be consistent. This means that it is fine
+   --  to use these as public symbols.
+
+   function New_Suffixed_Name
+     (Related_Id : Name_Id;
+      Suffix     : String)
+      return       Name_Id;
+   --  This function is used to create special suffixed names used by the
+   --  debugger. Suffix is a string of upper case letters, used to construct
+   --  the required name. For instance, the special type used to record the
+   --  fixed-point small is called typ_SMALL where typ is the name of the
+   --  fixed-point type (as passed in Related_Id), and Suffix is "SMALL".
+
+   function New_Occurrence_Of
+     (Def_Id : Entity_Id;
+      Loc    : Source_Ptr)
+      return   Node_Id;
+   --  New_Occurrence_Of creates an N_Identifier node which is an
+   --  occurrence of the defining identifier which is passed as its
+   --  argument. The Entity and Etype of the result are set from
+   --  the given defining identifier as follows: Entity is simply
+   --  a copy of Def_Id. Etype is a copy of Def_Id for types, and
+   --  a copy of the Etype of Def_Id for other entities.
+
+   function New_Reference_To
+     (Def_Id : Entity_Id;
+      Loc    : Source_Ptr)
+      return   Node_Id;
+   --  This is like New_Occurrence_Of, but it does not set the Etype field.
+   --  It is used from the expander, where Etype fields are generally not set,
+   --  since they are set when the expanded tree is reanalyzed.
+
+   function Checks_Off (N : Node_Id) return Node_Id;
+   pragma Inline (Checks_Off);
+   --  Returns an N_Unchecked_Expression node whose expression is the given
+   --  argument. The results is a subexpression identical to the argument,
+   --  except that it will be analyzed and resolved with checks off.
+
+   function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
+   --  Returns an expression that represents the result of a checked convert
+   --  of expression Exp to type T. If the base type of Exp is T, then no
+   --  conversion is required, and Exp is returned unchanged. Otherwise an
+   --  N_Type_Conversion node is constructed to convert the expression.
+   --  If an N_Type_Conversion node is required, Relocate_Node is used on
+   --  Exp. This means that it is safe to replace a node by a Convert_To
+   --  of itself to some other type.
+
+   function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
+   --  Like Convert_To, except that a conversion node is always generated,
+   --  and the Conversion_OK flag is set on this conversion node.
+
+   function Unchecked_Convert_To
+     (Typ  : Entity_Id;
+      Expr : Node_Id)
+      return Node_Id;
+   --  Like Convert_To, but if a conversion is actually needed, constructs
+   --  an N_Unchecked_Type_Conversion node to do the required conversion.
+
+end Tbuild;

gcc/ada/text_io.ads

@@ -0,0 +1,21 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUNTIME COMPONENTS                          --
+--                                                                          --
+--                              T E X T _ I O                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Ada_95;
+with Ada.Text_IO;
+
+package Text_IO renames Ada.Text_IO;

gcc/ada/tree_gen.adb

@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             T R E E _ G E N                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          Copyright (C) 1992-1999, 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.                                                      --
+--                                                                          --
+-- 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 Atree;
+with Elists;
+with Fname;
+with Lib;
+with Namet;
+with Nlists;
+with Opt;
+with Osint;
+with Repinfo;
+with Sinput;
+with Stand;
+with Stringt;
+with Uintp;
+with Urealp;
+
+procedure Tree_Gen is
+begin
+   if Opt.Tree_Output then
+      Osint.Tree_Create;
+      Opt.Tree_Write;
+      Atree.Tree_Write;
+      Elists.Tree_Write;
+      Fname.Tree_Write;
+      Lib.Tree_Write;
+      Namet.Tree_Write;
+      Nlists.Tree_Write;
+      Sinput.Tree_Write;
+      Stand.Tree_Write;
+      Stringt.Tree_Write;
+      Uintp.Tree_Write;
+      Urealp.Tree_Write;
+      Repinfo.Tree_Write;
+      Osint.Tree_Close;
+   end if;
+end Tree_Gen;

gcc/ada/tree_gen.ads

@@ -0,0 +1,31 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             T R E E _ G E N                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $                              --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This procedure is used to write out the tree if the option is set
+
+procedure Tree_Gen;

gcc/ada/tree_in.adb

@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E _ I N                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--          Copyright (C) 1992-1999, 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 Atree;
+with Csets;
+with Elists;
+with Fname;
+with Lib;
+with Namet;
+with Nlists;
+with Opt;
+with Repinfo;
+with Sinput;
+with Stand;
+with Stringt;
+with Tree_IO;
+with Uintp;
+with Urealp;
+
+procedure Tree_In (Desc : File_Descriptor) is
+begin
+   Tree_IO.Tree_Read_Initialize (Desc);
+   Opt.Tree_Read;
+   Atree.Tree_Read;
+   Elists.Tree_Read;
+   Fname.Tree_Read;
+   Lib.Tree_Read;
+   Namet.Tree_Read;
+   Nlists.Tree_Read;
+   Sinput.Tree_Read;
+   Stand.Tree_Read;
+   Stringt.Tree_Read;
+   Uintp.Tree_Read;
+   Urealp.Tree_Read;
+   Repinfo.Tree_Read;
+   Csets.Initialize;
+end Tree_In;

gcc/ada/tree_in.ads

@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E _ I N                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This procedure is used to read in a tree if the option is set. Note that
+--  it is not part of the compiler proper, but rather the interface from
+--  tools that need to read the tree to the tree reading routines, and is
+--  thus bound as part of such tools.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+procedure Tree_In (Desc : File_Descriptor);
+--  Desc is the file descriptor for the file containing the tree, as written
+--  by the compiler in a previous compilation using Tree_Gen. On return the
+--  global data structures are appropriately initialized.

gcc/ada/tree_io.adb

@@ -0,0 +1,661 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E _ I O                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.13 $
+--                                                                          --
+--          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 Debug;  use Debug;
+with Output; use Output;
+with Unchecked_Conversion;
+
+package body Tree_IO is
+   Debug_Flag_Tree : Boolean := False;
+   --  Debug flag for debug output from tree read/write
+
+   -------------------------------------------
+   -- Compression Scheme Used for Tree File --
+   -------------------------------------------
+
+   --  We don't just write the data directly, but instead do a mild form
+   --  of compression, since we expect lots of compressible zeroes and
+   --  blanks. The compression scheme is as follows:
+
+   --    00nnnnnn followed by nnnnnn bytes (non compressed data)
+   --    01nnnnnn indicates nnnnnn binary zero bytes
+   --    10nnnnnn indicates nnnnnn ASCII space bytes
+   --    11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb
+
+   --  Since we expect many zeroes in trees, and many spaces in sources,
+   --  this compression should be reasonably efficient. We can put in
+   --  something better later on.
+
+   --  Note that this compression applies to the Write_Tree_Data and
+   --  Read_Tree_Data calls, not to the calls to read and write single
+   --  scalar values, which are written in memory format without any
+   --  compression.
+
+   C_Noncomp : constant := 2#00_000000#;
+   C_Zeros   : constant := 2#01_000000#;
+   C_Spaces  : constant := 2#10_000000#;
+   C_Repeat  : constant := 2#11_000000#;
+   --  Codes for compression sequences
+
+   Max_Count : constant := 63;
+   --  Maximum data length for one compression sequence
+
+   Max_Comp : constant := Max_Count + 1;
+   --  Maximum length of one compression sequence
+
+   --  The above compression scheme applies only to data written with the
+   --  Tree_Write routine and read with Tree_Read. Data written using the
+   --  Tree_Write_Char or Tree_Write_Int routines and read using the
+   --  corresponding input routines is not compressed.
+
+   type Int_Bytes is array (1 .. 4) of Byte;
+   for Int_Bytes'Size use 32;
+
+   function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
+   function To_Int       is new Unchecked_Conversion (Int_Bytes, Int);
+
+   ----------------------
+   -- Global Variables --
+   ----------------------
+
+   Tree_FD : File_Descriptor;
+   --  File descriptor for tree
+
+   Buflen : constant Int := 8_192;
+   --  Length of buffer for read and write file data
+
+   Buf : array (Pos range 1 .. Buflen) of Byte;
+   --  Read/write file data buffer
+
+   Bufn : Nat;
+   --  Number of bytes read/written from/to buffer
+
+   Buft : Nat;
+   --  Total number of bytes in input buffer containing valid data. Used only
+   --  for input operations. There is data left to be processed in the buffer
+   --  if Buft > Bufn. A value of zero for Buft means that the buffer is empty.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Read_Buffer;
+   --  Reads data into buffer, setting Bufe appropriately
+
+   function Read_Byte return Byte;
+   pragma Inline (Read_Byte);
+   --  Returns next byte from input file, raises Tree_Format_Error if none left
+
+   procedure Write_Buffer;
+   --  Writes out current buffer contents
+
+   procedure Write_Byte (B : Byte);
+   pragma Inline (Write_Byte);
+   --  Write one byte to output buffer, checking for buffer-full condition
+
+   -----------------
+   -- Read_Buffer --
+   -----------------
+
+   procedure Read_Buffer is
+   begin
+      Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
+
+      if Buft = 0 then
+         raise Tree_Format_Error;
+      else
+         Bufn := 0;
+      end if;
+   end Read_Buffer;
+
+   ---------------
+   -- Read_Byte --
+   ---------------
+
+   function Read_Byte return Byte is
+   begin
+      if Bufn = Buft then
+         Read_Buffer;
+      end if;
+
+      Bufn := Bufn + 1;
+      return Buf (Bufn);
+   end Read_Byte;
+
+   --------------------
+   -- Tree_Read_Bool --
+   --------------------
+
+   procedure Tree_Read_Bool (B : out Boolean) is
+   begin
+      B := Boolean'Val (Read_Byte);
+
+      if Debug_Flag_Tree then
+         if B then
+            Write_Str ("True");
+         else
+            Write_Str ("False");
+         end if;
+
+         Write_Eol;
+      end if;
+   end Tree_Read_Bool;
+
+   --------------------
+   -- Tree_Read_Char --
+   --------------------
+
+   procedure Tree_Read_Char (C : out Character) is
+   begin
+      C := Character'Val (Read_Byte);
+
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting Character = ");
+         Write_Char (C);
+         Write_Eol;
+      end if;
+   end Tree_Read_Char;
+
+   --------------------
+   -- Tree_Read_Data --
+   --------------------
+
+   procedure Tree_Read_Data (Addr : Address; Length : Int) is
+
+      type S is array (Pos) of Byte;
+      --  This is a big array, for which we have to suppress the warning
+
+      type SP is access all S;
+
+      function To_SP is new Unchecked_Conversion (Address, SP);
+
+      Data : constant SP := To_SP (Addr);
+      --  Data buffer to be read as an indexable array of bytes
+
+      OP : Pos := 1;
+      --  Pointer to next byte of data buffer to be read into
+
+      B : Byte;
+      C : Byte;
+      L : Int;
+
+   begin
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting ");
+         Write_Int (Length);
+         Write_Str (" data bytes");
+         Write_Eol;
+      end if;
+
+      --  Verify data length
+
+      Tree_Read_Int (L);
+
+      if L /= Length then
+         Write_Str ("==> transmitting, expected ");
+         Write_Int (Length);
+         Write_Str (" bytes, found length = ");
+         Write_Int (L);
+         Write_Eol;
+         raise Tree_Format_Error;
+      end if;
+
+      --  Loop to read data
+
+      while OP <= Length loop
+
+         --  Get compression control character
+
+         B := Read_Byte;
+         C := B and 2#00_111111#;
+         B := B and 2#11_000000#;
+
+         --  Non-repeat case
+
+         if B = C_Noncomp then
+            if Debug_Flag_Tree then
+               Write_Str ("==>    uncompressed:  ");
+               Write_Int (Int (C));
+               Write_Str (", starting at ");
+               Write_Int (OP);
+               Write_Eol;
+            end if;
+
+            for J in 1 .. C loop
+               Data (OP) := Read_Byte;
+               OP := OP + 1;
+            end loop;
+
+         --  Repeated zeroes
+
+         elsif B = C_Zeros then
+            if Debug_Flag_Tree then
+               Write_Str ("==>    zeroes:        ");
+               Write_Int (Int (C));
+               Write_Str (", starting at ");
+               Write_Int (OP);
+               Write_Eol;
+            end if;
+
+            for J in 1 .. C loop
+               Data (OP) := 0;
+               OP := OP + 1;
+            end loop;
+
+         --  Repeated spaces
+
+         elsif B = C_Spaces then
+            if Debug_Flag_Tree then
+               Write_Str ("==>    spaces:        ");
+               Write_Int (Int (C));
+               Write_Str (", starting at ");
+               Write_Int (OP);
+               Write_Eol;
+            end if;
+
+            for J in 1 .. C loop
+               Data (OP) := Character'Pos (' ');
+               OP := OP + 1;
+            end loop;
+
+         --  Specified repeated character
+
+         else -- B = C_Repeat
+            B := Read_Byte;
+
+            if Debug_Flag_Tree then
+               Write_Str ("==>    other char:    ");
+               Write_Int (Int (C));
+               Write_Str (" (");
+               Write_Int (Int (B));
+               Write_Char (')');
+               Write_Str (", starting at ");
+               Write_Int (OP);
+               Write_Eol;
+            end if;
+
+            for J in 1 .. C loop
+               Data (OP) := B;
+               OP := OP + 1;
+            end loop;
+         end if;
+      end loop;
+
+      --  At end of loop, data item must be exactly filled
+
+      if OP /= Length + 1 then
+         raise Tree_Format_Error;
+      end if;
+
+   end Tree_Read_Data;
+
+   --------------------------
+   -- Tree_Read_Initialize --
+   --------------------------
+
+   procedure Tree_Read_Initialize (Desc : File_Descriptor) is
+   begin
+      Buft := 0;
+      Bufn := 0;
+      Tree_FD := Desc;
+      Debug_Flag_Tree := Debug_Flag_5;
+   end Tree_Read_Initialize;
+
+   -------------------
+   -- Tree_Read_Int --
+   -------------------
+
+   procedure Tree_Read_Int (N : out Int) is
+      N_Bytes : Int_Bytes;
+
+   begin
+      for J in 1 .. 4 loop
+         N_Bytes (J) := Read_Byte;
+      end loop;
+
+      N := To_Int (N_Bytes);
+
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting Int = ");
+         Write_Int (N);
+         Write_Eol;
+      end if;
+   end Tree_Read_Int;
+
+   -------------------
+   -- Tree_Read_Str --
+   -------------------
+
+   procedure Tree_Read_Str (S : out String_Ptr) is
+      N : Nat;
+
+   begin
+      Tree_Read_Int (N);
+      S := new String (1 .. Natural (N));
+      Tree_Read_Data (S.all (1)'Address, N);
+   end Tree_Read_Str;
+
+   -------------------------
+   -- Tree_Read_Terminate --
+   -------------------------
+
+   procedure Tree_Read_Terminate is
+   begin
+      --  Must be at end of input buffer, so we should get Tree_Format_Error
+      --  if we try to read one more byte, if not, we have a format error.
+
+      declare
+         B : Byte;
+      begin
+         B := Read_Byte;
+      exception
+         when Tree_Format_Error => return;
+      end;
+
+      raise Tree_Format_Error;
+   end Tree_Read_Terminate;
+
+   ---------------------
+   -- Tree_Write_Bool --
+   ---------------------
+
+   procedure Tree_Write_Bool (B : Boolean) is
+   begin
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting Boolean = ");
+
+         if B then
+            Write_Str ("True");
+         else
+            Write_Str ("False");
+         end if;
+
+         Write_Eol;
+      end if;
+
+      Write_Byte (Boolean'Pos (B));
+   end Tree_Write_Bool;
+
+   ---------------------
+   -- Tree_Write_Char --
+   ---------------------
+
+   procedure Tree_Write_Char (C : Character) is
+   begin
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting Character = ");
+         Write_Char (C);
+         Write_Eol;
+      end if;
+
+      Write_Byte (Character'Pos (C));
+   end Tree_Write_Char;
+
+   ---------------------
+   -- Tree_Write_Data --
+   ---------------------
+
+   procedure Tree_Write_Data (Addr : Address; Length : Int) is
+
+      type S is array (Pos) of Byte;
+      --  This is a big array, for which we have to suppress the warning
+
+      type SP is access all S;
+
+      function To_SP is new Unchecked_Conversion (Address, SP);
+
+      Data : constant SP := To_SP (Addr);
+      --  Pointer to data to be written, converted to array type
+
+      IP : Pos := 1;
+      --  Input buffer pointer, next byte to be processed
+
+      NC : Nat range 0 .. Max_Count := 0;
+      --  Number of bytes of non-compressible sequence
+
+      C  : Byte;
+
+      procedure Write_Non_Compressed_Sequence;
+      --  Output currently collected sequence of non-compressible data
+
+      procedure Write_Non_Compressed_Sequence is
+      begin
+         if NC > 0 then
+            Write_Byte (C_Noncomp + Byte (NC));
+
+            if Debug_Flag_Tree then
+               Write_Str ("==>    uncompressed:  ");
+               Write_Int (NC);
+               Write_Str (", starting at ");
+               Write_Int (IP - NC);
+               Write_Eol;
+            end if;
+
+            for J in reverse 1 .. NC loop
+               Write_Byte (Data (IP - J));
+            end loop;
+
+            NC := 0;
+         end if;
+      end Write_Non_Compressed_Sequence;
+
+   --  Start of processing for Tree_Write_Data
+
+   begin
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting ");
+         Write_Int (Length);
+         Write_Str (" data bytes");
+         Write_Eol;
+      end if;
+
+      --  We write the count at the start, so that we can check it on
+      --  the corresponding read to make sure that reads and writes match
+
+      Tree_Write_Int (Length);
+
+      --  Conversion loop
+      --    IP is index of next input character
+      --    NC is number of non-compressible bytes saved up
+
+      loop
+         --  If input is completely processed, then we are all done
+
+         if IP > Length then
+            Write_Non_Compressed_Sequence;
+            return;
+         end if;
+
+         --  Test for compressible sequence, must be at least three identical
+         --  bytes in a row to be worthwhile compressing.
+
+         if IP + 2 <= Length
+           and then Data (IP) = Data (IP + 1)
+           and then Data (IP) = Data (IP + 2)
+         then
+            Write_Non_Compressed_Sequence;
+
+            --  Count length of new compression sequence
+
+            C := 3;
+            IP := IP + 3;
+
+            while IP < Length
+              and then Data (IP) = Data (IP - 1)
+              and then C < Max_Count
+            loop
+               C := C + 1;
+               IP := IP + 1;
+            end loop;
+
+            --  Output compression sequence
+
+            if Data (IP - 1) = 0 then
+               if Debug_Flag_Tree then
+                  Write_Str ("==>    zeroes:        ");
+                  Write_Int (Int (C));
+                  Write_Str (", starting at ");
+                  Write_Int (IP - Int (C));
+                  Write_Eol;
+               end if;
+
+               Write_Byte (C_Zeros + C);
+
+            elsif Data (IP - 1) = Character'Pos (' ') then
+               if Debug_Flag_Tree then
+                  Write_Str ("==>    spaces:        ");
+                  Write_Int (Int (C));
+                  Write_Str (", starting at ");
+                  Write_Int (IP - Int (C));
+                  Write_Eol;
+               end if;
+
+               Write_Byte (C_Spaces + C);
+
+            else
+               if Debug_Flag_Tree then
+                  Write_Str ("==>    other char:    ");
+                  Write_Int (Int (C));
+                  Write_Str (" (");
+                  Write_Int (Int (Data (IP - 1)));
+                  Write_Char (')');
+                  Write_Str (", starting at ");
+                  Write_Int (IP - Int (C));
+                  Write_Eol;
+               end if;
+
+               Write_Byte (C_Repeat + C);
+               Write_Byte (Data (IP - 1));
+            end if;
+
+         --  No compression possible here
+
+         else
+            --  Output non-compressed sequence if at maximum length
+
+            if NC = Max_Count then
+               Write_Non_Compressed_Sequence;
+            end if;
+
+            NC := NC + 1;
+            IP := IP + 1;
+         end if;
+      end loop;
+
+   end Tree_Write_Data;
+
+   ---------------------------
+   -- Tree_Write_Initialize --
+   ---------------------------
+
+   procedure Tree_Write_Initialize (Desc : File_Descriptor) is
+   begin
+      Bufn := 0;
+      Tree_FD := Desc;
+      Set_Standard_Error;
+      Debug_Flag_Tree := Debug_Flag_5;
+   end Tree_Write_Initialize;
+
+   --------------------
+   -- Tree_Write_Int --
+   --------------------
+
+   procedure Tree_Write_Int (N : Int) is
+      N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
+
+   begin
+      if Debug_Flag_Tree then
+         Write_Str ("==> transmitting Int = ");
+         Write_Int (N);
+         Write_Eol;
+      end if;
+
+      for J in 1 .. 4 loop
+         Write_Byte (N_Bytes (J));
+      end loop;
+   end Tree_Write_Int;
+
+   --------------------
+   -- Tree_Write_Str --
+   --------------------
+
+   procedure Tree_Write_Str (S : String_Ptr) is
+   begin
+      Tree_Write_Int (S'Length);
+      Tree_Write_Data (S (1)'Address, S'Length);
+   end Tree_Write_Str;
+
+   --------------------------
+   -- Tree_Write_Terminate --
+   --------------------------
+
+   procedure Tree_Write_Terminate is
+   begin
+      if Bufn > 0 then
+         Write_Buffer;
+      end if;
+   end Tree_Write_Terminate;
+
+   ------------------
+   -- Write_Buffer --
+   ------------------
+
+   procedure Write_Buffer is
+   begin
+      if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
+         Bufn := 0;
+
+      else
+         Set_Standard_Error;
+         Write_Str ("fatal error: disk full");
+         OS_Exit (2);
+      end if;
+   end Write_Buffer;
+
+   ----------------
+   -- Write_Byte --
+   ----------------
+
+   procedure Write_Byte (B : Byte) is
+   begin
+      Bufn := Bufn + 1;
+      Buf (Bufn) := B;
+
+      if Bufn = Buflen then
+         Write_Buffer;
+      end if;
+   end Write_Byte;
+
+end Tree_IO;

gcc/ada/tree_io.ads

@@ -0,0 +1,107 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E _ I O                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.5 $                              --
+--                                                                          --
+--          Copyright (C) 1992-1999 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the routines used to read and write the tree files
+--  used by ASIS. Only the actual read and write routines are here. The open,
+--  create and close routines are elsewhere (in Osint in the compiler, and in
+--  the tree read driver for the tree read interface).
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with System;      use System;
+with Types;       use Types;
+
+package Tree_IO is
+
+   Tree_Format_Error : exception;
+   --  Raised if a format error is detected in the input file
+
+   procedure Tree_Read_Initialize (Desc : File_Descriptor);
+   --  Called to initialize reading of a tree file. This call must be made
+   --  before calls to Tree_Read_xx. No calls to Tree_Write_xx are permitted
+   --  after this call.
+
+   procedure Tree_Read_Data (Addr : Address; Length : Int);
+   --  Checks that the Length provided is the same as what has been provided
+   --  to the corresponding Tree_Write_Data from the current tree file,
+   --  Tree_Format_Error is raised if it is not the case. If Length is
+   --  correct and non zero, reads Length bytes of information into memory
+   --  starting at Addr from the current tree file.
+
+   procedure Tree_Read_Bool (B : out Boolean);
+   --  Reads a single boolean value. The boolean value must have been written
+   --  with a call to the Tree_Write_Bool procedure.
+
+   procedure Tree_Read_Char (C : out Character);
+   --  Reads a single character. The character must have been written with a
+   --  call to the Tree_Write_Char procedure.
+
+   procedure Tree_Read_Int (N : out Int);
+   --  Reads a single integer value. The integer must have been written with
+   --  a call to the Tree_Write_Int procedure.
+
+   procedure Tree_Read_Str (S : out String_Ptr);
+   --  Read string, allocate on heap, and return pointer to allocated string
+   --  which always has a lower bound of 1.
+
+   procedure Tree_Read_Terminate;
+   --  Called after reading all data, checks that the buffer pointers is at
+   --  the end of file, raising Tree_Format_Error if not.
+
+   procedure Tree_Write_Initialize (Desc : File_Descriptor);
+   --  Called to initialize writing of a tree file. This call must be made
+   --  before calls to Tree_Write_xx. No calls to Tree_Read_xx are permitted
+   --  after this call.
+
+   procedure Tree_Write_Data (Addr : Address; Length : Int);
+   --  Writes Length then, if Length is not null, Length bytes of data
+   --  starting at Addr to current tree file
+
+   procedure Tree_Write_Bool (B : Boolean);
+   --  Writes a single boolean value to the current tree file
+
+   procedure Tree_Write_Char (C : Character);
+   --  Writes a single character to the current tree file
+
+   procedure Tree_Write_Int (N : Int);
+   --  Writes a single integer value to the current tree file
+
+   procedure Tree_Write_Str (S : String_Ptr);
+   --  Write out string value referenced by S. Low bound must be 1.
+
+   procedure Tree_Write_Terminate;
+   --  Terminates writing of the file (flushing the buffer), but does not
+   --  close the file (the caller is responsible for closing the file).
+
+end Tree_IO;

gcc/ada/treepr.ads

@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T R E E P R                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $                             --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 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.                                                      --
+--                                                                          --
+-- 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 Types; use Types;
+package Treepr is
+
+--  This package provides printing routines for the abstract syntax tree
+--  These routines are intended only for debugging use.
+
+   procedure Tree_Dump;
+   --  This routine is called from the GNAT main program to dump trees as
+   --  requested by debug options (including tree of Standard if requested).
+
+   procedure Print_Tree_Node (N : Node_Id; Label : String := "");
+   --  Prints a single tree node, without printing descendants. The Label
+   --  string is used to preface each line of the printed output.
+
+   procedure Print_Tree_List (L : List_Id);
+   --  Prints a single node list, without printing the descendants of any
+   --  of the nodes in the list
+
+   procedure Print_Tree_Elist (E : Elist_Id);
+   --  Prints a single node list, without printing the descendants of any
+   --  of the nodes in the list
+
+   procedure Print_Node_Subtree (N : Node_Id);
+   --  Prints the subtree routed at a specified tree node, including all
+   --  referenced descendants.
+
+   procedure Print_List_Subtree (L : List_Id);
+   --  Prints the subtree consisting of the given node list and all its
+   --  referenced descendants.
+
+   procedure Print_Elist_Subtree (E : Elist_Id);
+   --  Prints the subtree consisting of the given element list and all its
+   --  referenced descendants.
+
+   procedure PE (E : Elist_Id);
+   --  Debugging procedure (to be called within gdb)
+   --  same as Print_Tree_Elist
+
+   procedure PL (L : List_Id);
+   --  Debugging procedure (to be called within gdb)
+   --  same as Print_Tree_List
+
+   procedure PN (N : Node_Id);
+   --  Debugging procedure (to be called within gdb)
+   --  same as Print_Tree_Node with Label = ""
+
+   procedure PT (N : Node_Id);
+   --  Debugging procedure (to be called within gdb)
+   --  same as Print_Node_Subtree
+
+end Treepr;

gcc/ada/treeprs.ads

@@ -0,0 +1,795 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E P R S                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                Generated by xtreeprs revision 1.31 using                 --
+--                         sinfo.ads revision 1.430                          --
+--                        treeprs.adt revision 1.17                          --
+--                                                                          --
+--          Copyright (C) 1992-1997 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+
+--  This package contains the declaration of the string used by the Tree_Print
+--  package. It must be updated whenever the arrangements of the field names
+--  in package Sinfo is changed. The utility program XTREEPRS is used to
+--  do this update correctly using the template treeprs.adt as input.
+
+with Sinfo; use Sinfo;
+
+package Treeprs is
+
+   --------------------------------
+   -- String Data for Node Print --
+   --------------------------------
+
+   --  String data for print out. The Pchars array is a long string with the
+   --  the entry for each node type consisting of a single blank, followed by
+   --  a series of entries, one for each Op or Flag field used for the node.
+   --  Each entry has a single character which identifies the field, followed
+   --  by the synonym name. The starting location for a given node type is
+   --  found from the corresponding entry in the Pchars_Pos_Array.
+
+   --  The following characters identify the field. These are characters
+   --  which  could never occur in a field name, so they also mark the
+   --  end of the previous name.
+
+   subtype Fchar is Character range '#' .. '9';
+
+   F_Field1     : constant Fchar := '#'; -- Character'Val (16#23#)
+   F_Field2     : constant Fchar := '$'; -- Character'Val (16#24#)
+   F_Field3     : constant Fchar := '%'; -- Character'Val (16#25#)
+   F_Field4     : constant Fchar := '&'; -- Character'Val (16#26#)
+   F_Field5     : constant Fchar := '''; -- Character'Val (16#27#)
+   F_Flag1      : constant Fchar := '('; -- Character'Val (16#28#)
+   F_Flag2      : constant Fchar := ')'; -- Character'Val (16#29#)
+   F_Flag3      : constant Fchar := '*'; -- Character'Val (16#2A#)
+   F_Flag4      : constant Fchar := '+'; -- Character'Val (16#2B#)
+   F_Flag5      : constant Fchar := ','; -- Character'Val (16#2C#)
+   F_Flag6      : constant Fchar := '-'; -- Character'Val (16#2D#)
+   F_Flag7      : constant Fchar := '.'; -- Character'Val (16#2E#)
+   F_Flag8      : constant Fchar := '/'; -- Character'Val (16#2F#)
+   F_Flag9      : constant Fchar := '0'; -- Character'Val (16#30#)
+   F_Flag10     : constant Fchar := '1'; -- Character'Val (16#31#)
+   F_Flag11     : constant Fchar := '2'; -- Character'Val (16#32#)
+   F_Flag12     : constant Fchar := '3'; -- Character'Val (16#33#)
+   F_Flag13     : constant Fchar := '4'; -- Character'Val (16#34#)
+   F_Flag14     : constant Fchar := '5'; -- Character'Val (16#35#)
+   F_Flag15     : constant Fchar := '6'; -- Character'Val (16#36#)
+   F_Flag16     : constant Fchar := '7'; -- Character'Val (16#37#)
+   F_Flag17     : constant Fchar := '8'; -- Character'Val (16#38#)
+   F_Flag18     : constant Fchar := '9'; -- Character'Val (16#39#)
+
+   --  Note this table does not include entity field and flags whose access
+   --  functions are in Einfo (these are handled by the Print_Entity_Info
+   --  procedure in Treepr, which uses the routines in Einfo to get the
+   --  proper symbolic information). In addition, the following fields are
+   --  handled by Treepr, and do not appear in the Pchars array:
+
+   --    Analyzed
+   --    Cannot_Be_Constant
+   --    Chars
+   --    Comes_From_Source
+   --    Error_Posted
+   --    Etype
+   --    Is_Controlling_Actual
+   --    Is_Overloaded
+   --    Is_Static_Expression
+   --    Left_Opnd
+   --    Must_Check_Expr
+   --    Must_Not_Freeze
+   --    No_Overflow_Expr
+   --    Paren_Count
+   --    Raises_Constraint_Error
+   --    Right_Opnd
+
+   Pchars : constant String :=
+      --  Unused_At_Start
+      "" &
+      --  At_Clause
+      "#Identifier%Expression" &
+      --  Component_Clause
+      "#Component_Name$Position%First_Bit&Last_Bit" &
+      --  Enumeration_Representation_Clause
+      "#Identifier%Array_Aggregate&Next_Rep_Item" &
+      --  Mod_Clause
+      "%Expression&Pragmas_Before" &
+      --  Record_Representation_Clause
+      "#Identifier$Mod_Clause%Component_Clauses&Next_Rep_Item" &
+      --  Attribute_Definition_Clause
+      "$Name%Expression&Next_Rep_Item+From_At_Mod" &
+      --  Empty
+      "" &
+      --  Error
+      "" &
+      --  Pragma
+      "$Pragma_Argument_Associations%Debug_Statement&Next_Rep_Item" &
+      --  Pragma_Argument_Association
+      "%Expression" &
+      --  Defining_Character_Literal
+      "$Next_Entity%Scope" &
+      --  Defining_Identifier
+      "$Next_Entity%Scope" &
+      --  Defining_Operator_Symbol
+      "$Next_Entity%Scope" &
+      --  Expanded_Name
+      "%Prefix$Selector_Name&Entity4Redundant_Use2Has_Private_View" &
+      --  Identifier
+      "&Entity$Original_Discriminant4Redundant_Use2Has_Private_View" &
+      --  Operator_Symbol
+      "%Strval&Entity2Has_Private_View" &
+      --  Character_Literal
+      "$Char_Literal_Value&Entity2Has_Private_View" &
+      --  Op_Add
+      "" &
+      --  Op_Concat
+      "4Is_Component_Left_Opnd5Is_Component_Right_Opnd" &
+      --  Op_Divide
+      "5Treat_Fixed_As_Integer4Do_Division_Check9Rounded_Result" &
+      --  Op_Expon
+      "4Is_Power_Of_2_For_Shift" &
+      --  Op_Mod
+      "5Treat_Fixed_As_Integer4Do_Division_Check" &
+      --  Op_Multiply
+      "5Treat_Fixed_As_Integer9Rounded_Result" &
+      --  Op_Rem
+      "5Treat_Fixed_As_Integer4Do_Division_Check" &
+      --  Op_Subtract
+      "" &
+      --  Op_And
+      "+Do_Length_Check" &
+      --  Op_Eq
+      "" &
+      --  Op_Ge
+      "" &
+      --  Op_Gt
+      "" &
+      --  Op_Le
+      "" &
+      --  Op_Lt
+      "" &
+      --  Op_Ne
+      "" &
+      --  Op_Or
+      "+Do_Length_Check" &
+      --  Op_Xor
+      "+Do_Length_Check" &
+      --  Op_Rotate_Left
+      "+Shift_Count_OK" &
+      --  Op_Rotate_Right
+      "+Shift_Count_OK" &
+      --  Op_Shift_Left
+      "+Shift_Count_OK" &
+      --  Op_Shift_Right
+      "+Shift_Count_OK" &
+      --  Op_Shift_Right_Arithmetic
+      "+Shift_Count_OK" &
+      --  Op_Abs
+      "" &
+      --  Op_Minus
+      "" &
+      --  Op_Not
+      "" &
+      --  Op_Plus
+      "" &
+      --  Attribute_Reference
+      "%Prefix$Attribute_Name#Expressions&Entity2Do_Access_Check8Do_Overflow" &
+         "_Check4Redundant_Use+OK_For_Stream" &
+      --  And_Then
+      "#Actions" &
+      --  Conditional_Expression
+      "#Expressions$Then_Actions%Else_Actions" &
+      --  Explicit_Dereference
+      "%Prefix2Do_Access_Check" &
+      --  Function_Call
+      "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" &
+         "Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" &
+      --  In
+      "" &
+      --  Indexed_Component
+      "%Prefix#Expressions2Do_Access_Check" &
+      --  Integer_Literal
+      "%Intval4Print_In_Hex" &
+      --  Not_In
+      "" &
+      --  Null
+      "" &
+      --  Or_Else
+      "#Actions" &
+      --  Procedure_Call_Statement
+      "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" &
+         "Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" &
+      --  Qualified_Expression
+      "&Subtype_Mark%Expression" &
+      --  Raise_Constraint_Error
+      "#Condition" &
+      --  Raise_Program_Error
+      "#Condition" &
+      --  Raise_Storage_Error
+      "#Condition" &
+      --  Aggregate
+      "#Expressions$Component_Associations8Null_Record_Present%Aggregate_Bou" &
+         "nds+Static_Processing_OK9Compile_Time_Known_Aggregate2Expansion_De" &
+         "layed" &
+      --  Allocator
+      "%Expression#Storage_Pool&Procedure_To_Call4No_Initialization8Do_Stora" &
+         "ge_Check" &
+      --  Extension_Aggregate
+      "%Ancestor_Part#Expressions$Component_Associations8Null_Record_Present" &
+         "2Expansion_Delayed" &
+      --  Range
+      "#Low_Bound$High_Bound2Includes_Infinities" &
+      --  Real_Literal
+      "%Realval&Corresponding_Integer_Value2Is_Machine_Number" &
+      --  Reference
+      "%Prefix" &
+      --  Selected_Component
+      "%Prefix$Selector_Name2Do_Access_Check4Do_Discriminant_Check" &
+      --  Slice
+      "%Prefix&Discrete_Range2Do_Access_Check" &
+      --  String_Literal
+      "%Strval2Has_Wide_Character" &
+      --  Subprogram_Info
+      "#Identifier" &
+      --  Type_Conversion
+      "&Subtype_Mark%Expression8Do_Overflow_Check4Do_Tag_Check+Do_Length_Che" &
+         "ck2Float_Truncate9Rounded_Result5Conversion_OK" &
+      --  Unchecked_Expression
+      "%Expression" &
+      --  Unchecked_Type_Conversion
+      "&Subtype_Mark%Expression2Kill_Range_Check" &
+      --  Subtype_Indication
+      "&Subtype_Mark%Constraint/Must_Not_Freeze" &
+      --  Component_Declaration
+      "#Defining_Identifier+Aliased_Present'Subtype_Indication%Expression,Mo" &
+         "re_Ids-Prev_Ids" &
+      --  Entry_Declaration
+      "#Defining_Identifier&Discrete_Subtype_Definition%Parameter_Specificat" &
+         "ions" &
+      --  Formal_Object_Declaration
+      "#Defining_Identifier6In_Present8Out_Present&Subtype_Mark%Expression,M" &
+         "ore_Ids-Prev_Ids" &
+      --  Formal_Type_Declaration
+      "#Defining_Identifier%Formal_Type_Definition&Discriminant_Specificatio" &
+         "ns4Unknown_Discriminants_Present" &
+      --  Full_Type_Declaration
+      "#Defining_Identifier&Discriminant_Specifications%Type_Definition2Disc" &
+         "r_Check_Funcs_Built" &
+      --  Incomplete_Type_Declaration
+      "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
+         "s_Present" &
+      --  Loop_Parameter_Specification
+      "#Defining_Identifier6Reverse_Present&Discrete_Subtype_Definition" &
+      --  Object_Declaration
+      "#Defining_Identifier+Aliased_Present8Constant_Present&Object_Definiti" &
+         "on%Expression$Handler_List_Entry'Corresponding_Generic_Association" &
+         ",More_Ids-Prev_Ids4No_Initialization6Assignment_OK2Exception_Junk5" &
+         "Delay_Finalize_Attach7Is_Subprogram_Descriptor" &
+      --  Protected_Type_Declaration
+      "#Defining_Identifier&Discriminant_Specifications%Protected_Definition" &
+         "'Corresponding_Body" &
+      --  Private_Extension_Declaration
+      "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
+         "s_Present+Abstract_Present'Subtype_Indication" &
+      --  Private_Type_Declaration
+      "#Defining_Identifier&Discriminant_Specifications4Unknown_Discriminant" &
+         "s_Present+Abstract_Present6Tagged_Present8Limited_Present" &
+      --  Subtype_Declaration
+      "#Defining_Identifier'Subtype_Indication&Generic_Parent_Type2Exception" &
+         "_Junk" &
+      --  Function_Specification
+      "#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications&Subt" &
+         "ype_Mark'Generic_Parent" &
+      --  Procedure_Specification
+      "#Defining_Unit_Name$Elaboration_Boolean%Parameter_Specifications'Gene" &
+         "ric_Parent" &
+      --  Entry_Index_Specification
+      "#Defining_Identifier&Discrete_Subtype_Definition" &
+      --  Freeze_Entity
+      "&Entity$Access_Types_To_Process%TSS_Elist#Actions'First_Subtype_Link" &
+      --  Access_Function_Definition
+      "6Protected_Present%Parameter_Specifications&Subtype_Mark" &
+      --  Access_Procedure_Definition
+      "6Protected_Present%Parameter_Specifications" &
+      --  Task_Type_Declaration
+      "#Defining_Identifier$Task_Body_Procedure&Discriminant_Specifications%" &
+         "Task_Definition'Corresponding_Body" &
+      --  Package_Body_Stub
+      "#Defining_Identifier&Library_Unit'Corresponding_Body" &
+      --  Protected_Body_Stub
+      "#Defining_Identifier&Library_Unit'Corresponding_Body" &
+      --  Subprogram_Body_Stub
+      "#Specification&Library_Unit'Corresponding_Body" &
+      --  Task_Body_Stub
+      "#Defining_Identifier&Library_Unit'Corresponding_Body" &
+      --  Function_Instantiation
+      "#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" &
+         "ec9ABE_Is_Certain" &
+      --  Package_Instantiation
+      "#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec'Instance_Sp" &
+         "ec9ABE_Is_Certain" &
+      --  Procedure_Instantiation
+      "#Defining_Unit_Name$Name&Parent_Spec%Generic_Associations'Instance_Sp" &
+         "ec9ABE_Is_Certain" &
+      --  Package_Body
+      "#Defining_Unit_Name$Declarations&Handled_Statement_Sequence'Correspon" &
+         "ding_Spec4Was_Originally_Stub" &
+      --  Subprogram_Body
+      "#Specification$Declarations&Handled_Statement_Sequence%Activation_Cha" &
+         "in_Entity'Corresponding_Spec+Acts_As_Spec6Bad_Is_Detected8Do_Stora" &
+         "ge_Check-Has_Priority_Pragma.Is_Protected_Subprogram_Body,Is_Task_" &
+         "Master4Was_Originally_Stub" &
+      --  Protected_Body
+      "#Defining_Identifier$Declarations&End_Label'Corresponding_Spec4Was_Or" &
+         "iginally_Stub" &
+      --  Task_Body
+      "#Defining_Identifier$Declarations&Handled_Statement_Sequence,Is_Task_" &
+         "Master%Activation_Chain_Entity'Corresponding_Spec4Was_Originally_S" &
+         "tub" &
+      --  Implicit_Label_Declaration
+      "#Defining_Identifier$Label_Construct" &
+      --  Package_Declaration
+      "#Specification'Corresponding_Body&Parent_Spec%Activation_Chain_Entity" &
+      --  Single_Task_Declaration
+      "#Defining_Identifier%Task_Definition" &
+      --  Subprogram_Declaration
+      "#Specification%Body_To_Inline'Corresponding_Body&Parent_Spec" &
+      --  Use_Package_Clause
+      "$Names%Next_Use_Clause&Hidden_By_Use_Clause" &
+      --  Generic_Package_Declaration
+      "#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" &
+         "Spec%Activation_Chain_Entity" &
+      --  Generic_Subprogram_Declaration
+      "#Specification'Corresponding_Body$Generic_Formal_Declarations&Parent_" &
+         "Spec" &
+      --  Constrained_Array_Definition
+      "$Discrete_Subtype_Definitions+Aliased_Present'Subtype_Indication" &
+      --  Unconstrained_Array_Definition
+      "$Subtype_Marks+Aliased_Present'Subtype_Indication" &
+      --  Exception_Renaming_Declaration
+      "#Defining_Identifier$Name" &
+      --  Object_Renaming_Declaration
+      "#Defining_Identifier&Subtype_Mark$Name'Corresponding_Generic_Associat" &
+         "ion" &
+      --  Package_Renaming_Declaration
+      "#Defining_Unit_Name$Name&Parent_Spec" &
+      --  Subprogram_Renaming_Declaration
+      "#Specification$Name&Parent_Spec'Corresponding_Spec" &
+      --  Generic_Function_Renaming_Declaration
+      "#Defining_Unit_Name$Name&Parent_Spec" &
+      --  Generic_Package_Renaming_Declaration
+      "#Defining_Unit_Name$Name&Parent_Spec" &
+      --  Generic_Procedure_Renaming_Declaration
+      "#Defining_Unit_Name$Name&Parent_Spec" &
+      --  Abort_Statement
+      "$Names" &
+      --  Accept_Statement
+      "#Entry_Direct_Name'Entry_Index%Parameter_Specifications&Handled_State" &
+         "ment_Sequence$Declarations" &
+      --  Assignment_Statement
+      "$Name%Expression4Do_Tag_Check+Do_Length_Check,Forwards_OK-Backwards_O" &
+         "K.No_Ctrl_Actions" &
+      --  Asynchronous_Select
+      "#Triggering_Alternative$Abortable_Part" &
+      --  Block_Statement
+      "#Identifier$Declarations&Handled_Statement_Sequence,Is_Task_Master%Ac" &
+         "tivation_Chain_Entity6Has_Created_Identifier-Is_Task_Allocation_Bl" &
+         "ock.Is_Asynchronous_Call_Block" &
+      --  Case_Statement
+      "%Expression&Alternatives'End_Span" &
+      --  Code_Statement
+      "%Expression" &
+      --  Conditional_Entry_Call
+      "#Entry_Call_Alternative&Else_Statements" &
+      --  Delay_Relative_Statement
+      "%Expression" &
+      --  Delay_Until_Statement
+      "%Expression" &
+      --  Entry_Call_Statement
+      "$Name%Parameter_Associations&First_Named_Actual" &
+      --  Free_Statement
+      "%Expression#Storage_Pool&Procedure_To_Call" &
+      --  Goto_Statement
+      "$Name2Exception_Junk" &
+      --  Loop_Statement
+      "#Identifier$Iteration_Scheme%Statements&End_Label6Has_Created_Identif" &
+         "ier" &
+      --  Null_Statement
+      "" &
+      --  Raise_Statement
+      "$Name" &
+      --  Requeue_Statement
+      "$Name6Abort_Present" &
+      --  Return_Statement
+      "%Expression#Storage_Pool&Procedure_To_Call4Do_Tag_Check$Return_Type,B" &
+         "y_Ref" &
+      --  Selective_Accept
+      "#Select_Alternatives&Else_Statements" &
+      --  Timed_Entry_Call
+      "#Entry_Call_Alternative&Delay_Alternative" &
+      --  Exit_Statement
+      "$Name#Condition" &
+      --  If_Statement
+      "#Condition$Then_Statements%Elsif_Parts&Else_Statements'End_Span" &
+      --  Accept_Alternative
+      "$Accept_Statement#Condition%Statements&Pragmas_Before'Accept_Handler_" &
+         "Records" &
+      --  Delay_Alternative
+      "$Delay_Statement#Condition%Statements&Pragmas_Before" &
+      --  Elsif_Part
+      "#Condition$Then_Statements%Condition_Actions" &
+      --  Entry_Body_Formal_Part
+      "&Entry_Index_Specification%Parameter_Specifications#Condition" &
+      --  Iteration_Scheme
+      "#Condition%Condition_Actions&Loop_Parameter_Specification" &
+      --  Terminate_Alternative
+      "#Condition&Pragmas_Before'Pragmas_After" &
+      --  Abortable_Part
+      "%Statements" &
+      --  Abstract_Subprogram_Declaration
+      "#Specification" &
+      --  Access_Definition
+      "&Subtype_Mark" &
+      --  Access_To_Object_Definition
+      "6All_Present'Subtype_Indication8Constant_Present" &
+      --  Case_Statement_Alternative
+      "&Discrete_Choices%Statements" &
+      --  Compilation_Unit
+      "&Library_Unit#Context_Items6Private_Present$Unit'Aux_Decls_Node8Has_N" &
+         "o_Elaboration_Code4Body_Required+Acts_As_Spec%First_Inlined_Subpro" &
+         "gram" &
+      --  Compilation_Unit_Aux
+      "$Declarations#Actions'Pragmas_After" &
+      --  Component_Association
+      "#Choices$Loop_Actions%Expression" &
+      --  Component_List
+      "%Component_Items&Variant_Part4Null_Present" &
+      --  Derived_Type_Definition
+      "+Abstract_Present'Subtype_Indication%Record_Extension_Part" &
+      --  Decimal_Fixed_Point_Definition
+      "%Delta_Expression$Digits_Expression&Real_Range_Specification" &
+      --  Defining_Program_Unit_Name
+      "$Name#Defining_Identifier" &
+      --  Delta_Constraint
+      "%Delta_Expression&Range_Constraint" &
+      --  Designator
+      "$Name#Identifier" &
+      --  Digits_Constraint
+      "$Digits_Expression&Range_Constraint" &
+      --  Discriminant_Association
+      "#Selector_Names%Expression" &
+      --  Discriminant_Specification
+      "#Defining_Identifier'Discriminant_Type%Expression,More_Ids-Prev_Ids" &
+      --  Enumeration_Type_Definition
+      "#Literals" &
+      --  Entry_Body
+      "#Defining_Identifier'Entry_Body_Formal_Part$Declarations&Handled_Stat" &
+         "ement_Sequence%Activation_Chain_Entity" &
+      --  Entry_Call_Alternative
+      "#Entry_Call_Statement%Statements&Pragmas_Before" &
+      --  Exception_Declaration
+      "#Defining_Identifier%Expression,More_Ids-Prev_Ids" &
+      --  Exception_Handler
+      "$Choice_Parameter&Exception_Choices%Statements,Zero_Cost_Handling" &
+      --  Floating_Point_Definition
+      "$Digits_Expression&Real_Range_Specification" &
+      --  Formal_Decimal_Fixed_Point_Definition
+      "" &
+      --  Formal_Derived_Type_Definition
+      "&Subtype_Mark6Private_Present+Abstract_Present" &
+      --  Formal_Discrete_Type_Definition
+      "" &
+      --  Formal_Floating_Point_Definition
+      "" &
+      --  Formal_Modular_Type_Definition
+      "" &
+      --  Formal_Ordinary_Fixed_Point_Definition
+      "" &
+      --  Formal_Package_Declaration
+      "#Defining_Identifier$Name%Generic_Associations6Box_Present'Instance_S" &
+         "pec9ABE_Is_Certain" &
+      --  Formal_Private_Type_Definition
+      "+Abstract_Present6Tagged_Present8Limited_Present" &
+      --  Formal_Signed_Integer_Type_Definition
+      "" &
+      --  Formal_Subprogram_Declaration
+      "#Specification$Default_Name6Box_Present" &
+      --  Generic_Association
+      "$Selector_Name#Explicit_Generic_Actual_Parameter" &
+      --  Handled_Sequence_Of_Statements
+      "%Statements&End_Label'Exception_Handlers#At_End_Proc$First_Real_State" &
+         "ment,Zero_Cost_Handling" &
+      --  Index_Or_Discriminant_Constraint
+      "#Constraints" &
+      --  Itype_Reference
+      "#Itype" &
+      --  Label
+      "#Identifier2Exception_Junk" &
+      --  Modular_Type_Definition
+      "%Expression" &
+      --  Number_Declaration
+      "#Defining_Identifier%Expression,More_Ids-Prev_Ids" &
+      --  Ordinary_Fixed_Point_Definition
+      "%Delta_Expression&Real_Range_Specification" &
+      --  Others_Choice
+      "#Others_Discrete_Choices2All_Others" &
+      --  Package_Specification
+      "#Defining_Unit_Name$Visible_Declarations%Private_Declarations&End_Lab" &
+         "el'Generic_Parent" &
+      --  Parameter_Association
+      "$Selector_Name%Explicit_Actual_Parameter&Next_Named_Actual" &
+      --  Parameter_Specification
+      "#Defining_Identifier6In_Present8Out_Present$Parameter_Type%Expression" &
+         "4Do_Accessibility_Check,More_Ids-Prev_Ids'Default_Expression" &
+      --  Protected_Definition
+      "$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" &
+         "gma" &
+      --  Range_Constraint
+      "&Range_Expression" &
+      --  Real_Range_Specification
+      "#Low_Bound$High_Bound" &
+      --  Record_Definition
+      "&End_Label+Abstract_Present6Tagged_Present8Limited_Present#Component_" &
+         "List4Null_Present" &
+      --  Signed_Integer_Type_Definition
+      "#Low_Bound$High_Bound" &
+      --  Single_Protected_Declaration
+      "#Defining_Identifier%Protected_Definition" &
+      --  Subunit
+      "$Name#Proper_Body%Corresponding_Stub" &
+      --  Task_Definition
+      "$Visible_Declarations%Private_Declarations&End_Label-Has_Priority_Pra" &
+         "gma,Has_Storage_Size_Pragma.Has_Task_Info_Pragma/Has_Task_Name_Pra" &
+         "gma" &
+      --  Triggering_Alternative
+      "#Triggering_Statement%Statements&Pragmas_Before" &
+      --  Use_Type_Clause
+      "$Subtype_Marks%Next_Use_Clause&Hidden_By_Use_Clause" &
+      --  Validate_Unchecked_Conversion
+      "#Source_Type$Target_Type" &
+      --  Variant
+      "&Discrete_Choices#Component_List$Enclosing_Variant%Present_Expr'Dchec" &
+         "k_Function" &
+      --  Variant_Part
+      "$Name#Variants" &
+      --  With_Clause
+      "$Name&Library_Unit'Corresponding_Spec,First_Name-Last_Name4Context_In" &
+         "stalled+Elaborate_Present6Elaborate_All_Present8Implicit_With.Unre" &
+         "ferenced_In_Spec/No_Entities_Ref_In_Spec" &
+      --  With_Type_Clause
+      "$Name6Tagged_Present" &
+      --  Unused_At_End
+      "";
+
+   type Pchar_Pos_Array is array (Node_Kind) of Positive;
+   Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(
+      N_Unused_At_Start                        => 1,
+      N_At_Clause                              => 1,
+      N_Component_Clause                       => 23,
+      N_Enumeration_Representation_Clause      => 66,
+      N_Mod_Clause                             => 107,
+      N_Record_Representation_Clause           => 133,
+      N_Attribute_Definition_Clause            => 187,
+      N_Empty                                  => 229,
+      N_Error                                  => 229,
+      N_Pragma                                 => 229,
+      N_Pragma_Argument_Association            => 288,
+      N_Defining_Character_Literal             => 299,
+      N_Defining_Identifier                    => 317,
+      N_Defining_Operator_Symbol               => 335,
+      N_Expanded_Name                          => 353,
+      N_Identifier                             => 412,
+      N_Operator_Symbol                        => 472,
+      N_Character_Literal                      => 503,
+      N_Op_Add                                 => 546,
+      N_Op_Concat                              => 546,
+      N_Op_Divide                              => 593,
+      N_Op_Expon                               => 649,
+      N_Op_Mod                                 => 673,
+      N_Op_Multiply                            => 714,
+      N_Op_Rem                                 => 752,
+      N_Op_Subtract                            => 793,
+      N_Op_And                                 => 793,
+      N_Op_Eq                                  => 809,
+      N_Op_Ge                                  => 809,
+      N_Op_Gt                                  => 809,
+      N_Op_Le                                  => 809,
+      N_Op_Lt                                  => 809,
+      N_Op_Ne                                  => 809,
+      N_Op_Or                                  => 809,
+      N_Op_Xor                                 => 825,
+      N_Op_Rotate_Left                         => 841,
+      N_Op_Rotate_Right                        => 856,
+      N_Op_Shift_Left                          => 871,
+      N_Op_Shift_Right                         => 886,
+      N_Op_Shift_Right_Arithmetic              => 901,
+      N_Op_Abs                                 => 916,
+      N_Op_Minus                               => 916,
+      N_Op_Not                                 => 916,
+      N_Op_Plus                                => 916,
+      N_Attribute_Reference                    => 916,
+      N_And_Then                               => 1019,
+      N_Conditional_Expression                 => 1027,
+      N_Explicit_Dereference                   => 1065,
+      N_Function_Call                          => 1088,
+      N_In                                     => 1209,
+      N_Indexed_Component                      => 1209,
+      N_Integer_Literal                        => 1244,
+      N_Not_In                                 => 1264,
+      N_Null                                   => 1264,
+      N_Or_Else                                => 1264,
+      N_Procedure_Call_Statement               => 1272,
+      N_Qualified_Expression                   => 1393,
+      N_Raise_Constraint_Error                 => 1417,
+      N_Raise_Program_Error                    => 1427,
+      N_Raise_Storage_Error                    => 1437,
+      N_Aggregate                              => 1447,
+      N_Allocator                              => 1587,
+      N_Extension_Aggregate                    => 1664,
+      N_Range                                  => 1751,
+      N_Real_Literal                           => 1792,
+      N_Reference                              => 1846,
+      N_Selected_Component                     => 1853,
+      N_Slice                                  => 1912,
+      N_String_Literal                         => 1950,
+      N_Subprogram_Info                        => 1976,
+      N_Type_Conversion                        => 1987,
+      N_Unchecked_Expression                   => 2102,
+      N_Unchecked_Type_Conversion              => 2113,
+      N_Subtype_Indication                     => 2154,
+      N_Component_Declaration                  => 2194,
+      N_Entry_Declaration                      => 2278,
+      N_Formal_Object_Declaration              => 2351,
+      N_Formal_Type_Declaration                => 2436,
+      N_Full_Type_Declaration                  => 2537,
+      N_Incomplete_Type_Declaration            => 2625,
+      N_Loop_Parameter_Specification           => 2703,
+      N_Object_Declaration                     => 2767,
+      N_Protected_Type_Declaration             => 3014,
+      N_Private_Extension_Declaration          => 3102,
+      N_Private_Type_Declaration               => 3216,
+      N_Subtype_Declaration                    => 3342,
+      N_Function_Specification                 => 3416,
+      N_Procedure_Specification                => 3508,
+      N_Entry_Index_Specification              => 3587,
+      N_Freeze_Entity                          => 3635,
+      N_Access_Function_Definition             => 3703,
+      N_Access_Procedure_Definition            => 3759,
+      N_Task_Type_Declaration                  => 3802,
+      N_Package_Body_Stub                      => 3905,
+      N_Protected_Body_Stub                    => 3957,
+      N_Subprogram_Body_Stub                   => 4009,
+      N_Task_Body_Stub                         => 4055,
+      N_Function_Instantiation                 => 4107,
+      N_Package_Instantiation                  => 4193,
+      N_Procedure_Instantiation                => 4279,
+      N_Package_Body                           => 4365,
+      N_Subprogram_Body                        => 4463,
+      N_Protected_Body                         => 4690,
+      N_Task_Body                              => 4772,
+      N_Implicit_Label_Declaration             => 4910,
+      N_Package_Declaration                    => 4946,
+      N_Single_Task_Declaration                => 5015,
+      N_Subprogram_Declaration                 => 5051,
+      N_Use_Package_Clause                     => 5111,
+      N_Generic_Package_Declaration            => 5154,
+      N_Generic_Subprogram_Declaration         => 5251,
+      N_Constrained_Array_Definition           => 5324,
+      N_Unconstrained_Array_Definition         => 5388,
+      N_Exception_Renaming_Declaration         => 5437,
+      N_Object_Renaming_Declaration            => 5462,
+      N_Package_Renaming_Declaration           => 5534,
+      N_Subprogram_Renaming_Declaration        => 5570,
+      N_Generic_Function_Renaming_Declaration  => 5620,
+      N_Generic_Package_Renaming_Declaration   => 5656,
+      N_Generic_Procedure_Renaming_Declaration => 5692,
+      N_Abort_Statement                        => 5728,
+      N_Accept_Statement                       => 5734,
+      N_Assignment_Statement                   => 5829,
+      N_Asynchronous_Select                    => 5915,
+      N_Block_Statement                        => 5953,
+      N_Case_Statement                         => 6118,
+      N_Code_Statement                         => 6151,
+      N_Conditional_Entry_Call                 => 6162,
+      N_Delay_Relative_Statement               => 6201,
+      N_Delay_Until_Statement                  => 6212,
+      N_Entry_Call_Statement                   => 6223,
+      N_Free_Statement                         => 6270,
+      N_Goto_Statement                         => 6312,
+      N_Loop_Statement                         => 6332,
+      N_Null_Statement                         => 6404,
+      N_Raise_Statement                        => 6404,
+      N_Requeue_Statement                      => 6409,
+      N_Return_Statement                       => 6428,
+      N_Selective_Accept                       => 6502,
+      N_Timed_Entry_Call                       => 6538,
+      N_Exit_Statement                         => 6579,
+      N_If_Statement                           => 6594,
+      N_Accept_Alternative                     => 6657,
+      N_Delay_Alternative                      => 6733,
+      N_Elsif_Part                             => 6785,
+      N_Entry_Body_Formal_Part                 => 6829,
+      N_Iteration_Scheme                       => 6890,
+      N_Terminate_Alternative                  => 6947,
+      N_Abortable_Part                         => 6986,
+      N_Abstract_Subprogram_Declaration        => 6997,
+      N_Access_Definition                      => 7011,
+      N_Access_To_Object_Definition            => 7024,
+      N_Case_Statement_Alternative             => 7072,
+      N_Compilation_Unit                       => 7100,
+      N_Compilation_Unit_Aux                   => 7239,
+      N_Component_Association                  => 7274,
+      N_Component_List                         => 7306,
+      N_Derived_Type_Definition                => 7348,
+      N_Decimal_Fixed_Point_Definition         => 7406,
+      N_Defining_Program_Unit_Name             => 7466,
+      N_Delta_Constraint                       => 7491,
+      N_Designator                             => 7525,
+      N_Digits_Constraint                      => 7541,
+      N_Discriminant_Association               => 7576,
+      N_Discriminant_Specification             => 7602,
+      N_Enumeration_Type_Definition            => 7669,
+      N_Entry_Body                             => 7678,
+      N_Entry_Call_Alternative                 => 7785,
+      N_Exception_Declaration                  => 7832,
+      N_Exception_Handler                      => 7881,
+      N_Floating_Point_Definition              => 7946,
+      N_Formal_Decimal_Fixed_Point_Definition  => 7989,
+      N_Formal_Derived_Type_Definition         => 7989,
+      N_Formal_Discrete_Type_Definition        => 8035,
+      N_Formal_Floating_Point_Definition       => 8035,
+      N_Formal_Modular_Type_Definition         => 8035,
+      N_Formal_Ordinary_Fixed_Point_Definition => 8035,
+      N_Formal_Package_Declaration             => 8035,
+      N_Formal_Private_Type_Definition         => 8122,
+      N_Formal_Signed_Integer_Type_Definition  => 8170,
+      N_Formal_Subprogram_Declaration          => 8170,
+      N_Generic_Association                    => 8209,
+      N_Handled_Sequence_Of_Statements         => 8257,
+      N_Index_Or_Discriminant_Constraint       => 8349,
+      N_Itype_Reference                        => 8361,
+      N_Label                                  => 8367,
+      N_Modular_Type_Definition                => 8393,
+      N_Number_Declaration                     => 8404,
+      N_Ordinary_Fixed_Point_Definition        => 8453,
+      N_Others_Choice                          => 8495,
+      N_Package_Specification                  => 8530,
+      N_Parameter_Association                  => 8616,
+      N_Parameter_Specification                => 8674,
+      N_Protected_Definition                   => 8803,
+      N_Range_Constraint                       => 8875,
+      N_Real_Range_Specification               => 8892,
+      N_Record_Definition                      => 8913,
+      N_Signed_Integer_Type_Definition         => 8999,
+      N_Single_Protected_Declaration           => 9020,
+      N_Subunit                                => 9061,
+      N_Task_Definition                        => 9097,
+      N_Triggering_Alternative                 => 9235,
+      N_Use_Type_Clause                        => 9282,
+      N_Validate_Unchecked_Conversion          => 9333,
+      N_Variant                                => 9357,
+      N_Variant_Part                           => 9436,
+      N_With_Clause                            => 9450,
+      N_With_Type_Clause                       => 9625,
+      N_Unused_At_End                          => 9645);
+
+end Treeprs;

gcc/ada/treeprs.adt

@@ -0,0 +1,108 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              T R E E P R S                               --
+--                                                                          --
+--                             T e m p l a t e                              --
+--                                                                          --
+--                            $Revision: 1.17 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1997 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This file is a template used as input to the utility program XTreeprs,
+--  which reads this template, and the spec of Sinfo (sinfo.ads) and generates
+--  the spec for the Treeprs package (file treeprs.ads)
+
+--  This package contains the declaration of the string used by the Tree_Print
+--  package. It must be updated whenever the arrangements of the field names
+--  in package Sinfo is changed. The utility program XTREEPRS is used to
+--  do this update correctly using the template treeprs.adt as input.
+
+with Sinfo; use Sinfo;
+
+package Treeprs is
+
+   --------------------------------
+   -- String Data for Node Print --
+   --------------------------------
+
+   --  String data for print out. The Pchars array is a long string with the
+   --  the entry for each node type consisting of a single blank, followed by
+   --  a series of entries, one for each Op or Flag field used for the node.
+   --  Each entry has a single character which identifies the field, followed
+   --  by the synonym name. The starting location for a given node type is
+   --  found from the corresponding entry in the Pchars_Pos_Array.
+
+   --  The following characters identify the field. These are characters
+   --  which  could never occur in a field name, so they also mark the
+   --  end of the previous name.
+
+   subtype Fchar is Character range '#' .. '9';
+
+   F_Field1     : constant Fchar := '#'; -- Character'Val (16#23#)
+   F_Field2     : constant Fchar := '$'; -- Character'Val (16#24#)
+   F_Field3     : constant Fchar := '%'; -- Character'Val (16#25#)
+   F_Field4     : constant Fchar := '&'; -- Character'Val (16#26#)
+   F_Field5     : constant Fchar := '''; -- Character'Val (16#27#)
+   F_Flag1      : constant Fchar := '('; -- Character'Val (16#28#)
+   F_Flag2      : constant Fchar := ')'; -- Character'Val (16#29#)
+   F_Flag3      : constant Fchar := '*'; -- Character'Val (16#2A#)
+   F_Flag4      : constant Fchar := '+'; -- Character'Val (16#2B#)
+   F_Flag5      : constant Fchar := ','; -- Character'Val (16#2C#)
+   F_Flag6      : constant Fchar := '-'; -- Character'Val (16#2D#)
+   F_Flag7      : constant Fchar := '.'; -- Character'Val (16#2E#)
+   F_Flag8      : constant Fchar := '/'; -- Character'Val (16#2F#)
+   F_Flag9      : constant Fchar := '0'; -- Character'Val (16#30#)
+   F_Flag10     : constant Fchar := '1'; -- Character'Val (16#31#)
+   F_Flag11     : constant Fchar := '2'; -- Character'Val (16#32#)
+   F_Flag12     : constant Fchar := '3'; -- Character'Val (16#33#)
+   F_Flag13     : constant Fchar := '4'; -- Character'Val (16#34#)
+   F_Flag14     : constant Fchar := '5'; -- Character'Val (16#35#)
+   F_Flag15     : constant Fchar := '6'; -- Character'Val (16#36#)
+   F_Flag16     : constant Fchar := '7'; -- Character'Val (16#37#)
+   F_Flag17     : constant Fchar := '8'; -- Character'Val (16#38#)
+   F_Flag18     : constant Fchar := '9'; -- Character'Val (16#39#)
+
+   --  Note this table does not include entity field and flags whose access
+   --  functions are in Einfo (these are handled by the Print_Entity_Info
+   --  procedure in Treepr, which uses the routines in Einfo to get the
+   --  proper symbolic information). In addition, the following fields are
+   --  handled by Treepr, and do not appear in the Pchars array:
+
+   --    Analyzed
+   --    Cannot_Be_Constant
+   --    Chars
+   --    Comes_From_Source
+   --    Error_Posted
+   --    Etype
+   --    Is_Controlling_Actual
+   --    Is_Overloaded
+   --    Is_Static_Expression
+   --    Left_Opnd
+   --    Must_Check_Expr
+   --    Must_Not_Freeze
+   --    No_Overflow_Expr
+   --    Paren_Count
+   --    Raises_Constraint_Error
+   --    Right_Opnd
+
+!!TEMPLATE INSERTION POINT
+
+end Treeprs;

gcc/ada/ttypef.ads

@@ -0,0 +1,207 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T T Y P E F                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.21 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This module contains values for the predefined floating-point attributes.
+--  All references to these attribute values in a program being compiled must
+--  use the values in this package, not the values returned by referencing
+--  the corresponding attributes (since that would give host machine values).
+--  Boolean-valued attributes are defined in System.Parameters, because they
+--  need a finer control than what is provided by the formats described below.
+
+--  The codes for the eight floating-point formats supported are:
+
+--      IEEES - IEEE Single Float
+--      IEEEL - IEEE Double Float
+--      IEEEX - IEEE Double Extended Float
+--      VAXFF - VAX F Float
+--      VAXDF - VAX D Float
+--      VAXGF - VAX G Float
+--      AAMPS - AAMP 32-bit Float
+--      AAMPL - AAMP 48-bit Float
+
+package Ttypef is
+
+   ----------------------------------
+   -- Universal Integer Attributes --
+   ----------------------------------
+
+   --  Note that the constant declarations below specify values
+   --  using the Ada model, so IEEES_Machine_Emax does not specify
+   --  the IEEE definition of the single precision float type,
+   --  but the value of the Ada attribute which is one higher
+   --  as the binary point is at a different location.
+
+   IEEES_Digits            : constant := 6;
+   IEEEL_Digits            : constant := 15;
+   IEEEX_Digits            : constant := 18;
+   VAXFF_Digits            : constant := 6;
+   VAXDF_Digits            : constant := 9;
+   VAXGF_Digits            : constant := 15;
+   AAMPS_Digits            : constant := 6;
+   AAMPL_Digits            : constant := 9;
+
+   IEEES_Machine_Emax      : constant := 128;
+   IEEEL_Machine_Emax      : constant := 1024;
+   IEEEX_Machine_Emax      : constant := 16384;
+   VAXFF_Machine_Emax      : constant := 127;
+   VAXDF_Machine_Emax      : constant := 127;
+   VAXGF_Machine_Emax      : constant := 1023;
+   AAMPS_Machine_Emax      : constant := 127;
+   AAMPL_Machine_Emax      : constant := 127;
+
+   IEEES_Machine_Emin      : constant := -125;
+   IEEEL_Machine_Emin      : constant := -1021;
+   IEEEX_Machine_Emin      : constant := -16381;
+   VAXFF_Machine_Emin      : constant := -127;
+   VAXDF_Machine_Emin      : constant := -127;
+   VAXGF_Machine_Emin      : constant := -1023;
+   AAMPS_Machine_Emin      : constant := -127;
+   AAMPL_Machine_Emin      : constant := -127;
+
+   IEEES_Machine_Mantissa  : constant := 24;
+   IEEEL_Machine_Mantissa  : constant := 53;
+   IEEEX_Machine_Mantissa  : constant := 64;
+   VAXFF_Machine_Mantissa  : constant := 24;
+   VAXDF_Machine_Mantissa  : constant := 56;
+   VAXGF_Machine_Mantissa  : constant := 53;
+   AAMPS_Machine_Mantissa  : constant := 24;
+   AAMPL_Machine_Mantissa  : constant := 40;
+
+   IEEES_Model_Emin        : constant := -125;
+   IEEEL_Model_Emin        : constant := -1021;
+   IEEEX_Model_Emin        : constant := -16381;
+   VAXFF_Model_Emin        : constant := -127;
+   VAXDF_Model_Emin        : constant := -127;
+   VAXGF_Model_Emin        : constant := -1023;
+   AAMPS_Model_Emin        : constant := -127;
+   AAMPL_Model_Emin        : constant := -127;
+
+   IEEES_Model_Mantissa    : constant := 24;
+   IEEEL_Model_Mantissa    : constant := 53;
+   IEEEX_Model_Mantissa    : constant := 64;
+   VAXFF_Model_Mantissa    : constant := 24;
+   VAXDF_Model_Mantissa    : constant := 56;
+   VAXGF_Model_Mantissa    : constant := 53;
+   AAMPS_Model_Mantissa    : constant := 24;
+   AAMPL_Model_Mantissa    : constant := 40;
+
+   IEEES_Safe_Emax         : constant := 128;
+   IEEEL_Safe_Emax         : constant := 1024;
+   IEEEX_Safe_Emax         : constant := 16384;
+   VAXFF_Safe_Emax         : constant := 127;
+   VAXDF_Safe_Emax         : constant := 127;
+   VAXGF_Safe_Emax         : constant := 1023;
+   AAMPS_Safe_Emax         : constant := 127;
+   AAMPL_Safe_Emax         : constant := 127;
+
+   -------------------------------
+   -- Universal Real Attributes --
+   -------------------------------
+
+   IEEES_Model_Epsilon     : constant := 2#1.0#E-23;
+   IEEEL_Model_Epsilon     : constant := 2#1.0#E-52;
+   IEEEX_Model_Epsilon     : constant := 2#1.0#E-63;
+   VAXFF_Model_Epsilon     : constant := 16#0.1000_000#E-4;
+   VAXDF_Model_Epsilon     : constant := 16#0.4000_0000_0000_000#E-7;
+   VAXGF_Model_Epsilon     : constant := 16#0.4000_0000_0000_00#E-12;
+   AAMPS_Model_Epsilon     : constant := 2#1.0#E-23;
+   AAMPL_Model_Epsilon     : constant := 2#1.0#E-39;
+
+   IEEES_Model_Small       : constant := 2#1.0#E-126;
+   IEEEL_Model_Small       : constant := 2#1.0#E-1022;
+   IEEEX_Model_Small       : constant := 2#1.0#E-16381;
+   VAXFF_Model_Small       : constant := 16#0.8000_000#E-21;
+   VAXDF_Model_Small       : constant := 16#0.8000_0000_0000_000#E-31;
+   VAXGF_Model_Small       : constant := 16#0.8000_0000_0000_00#E-51;
+   AAMPS_Model_Small       : constant := 16#0.8000_000#E-21;
+   AAMPL_Model_Small       : constant := 16#0.8000_0000_000#E-31;
+
+   IEEES_Safe_First        : constant := -16#0.FFFF_FF#E+32;
+   IEEEL_Safe_First        : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
+   IEEEX_Safe_First        : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
+   VAXFF_Safe_First        : constant := -16#0.7FFF_FF8#E+32;
+   VAXDF_Safe_First        : constant := -16#0.7FFF_FFFF_FFFF_FF8#E-38;
+   VAXGF_Safe_First        : constant := -16#0.7FFF_FFFF_FFFF_FC#E-256;
+   AAMPS_Safe_First        : constant := -16#0.7FFF_FF8#E+32;
+   AAMPL_Safe_First        : constant := -16#0.7FFF_FFFF_FF8#E+32;
+
+   IEEES_Safe_Large        : constant := 16#0.FFFF_FF#E+32;
+   IEEEL_Safe_Large        : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
+   IEEEX_Safe_Large        : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
+   VAXFF_Safe_Large        : constant := 16#0.7FFF_FC0#E+32;
+   VAXDF_Safe_Large        : constant := 16#0.7FFF_FFFF_0000_000#E+32;
+   VAXGF_Safe_Large        : constant := 16#0.7FFF_FFFF_FFFF_F0#E+256;
+   AAMPS_Safe_Large        : constant := 16#0.7FFF_FC0#E+32;
+   AAMPL_Safe_Large        : constant := 16#0.7FFF_FFFF#E+32;
+
+   IEEES_Safe_Last         : constant := 16#0.FFFF_FF#E+32;
+   IEEEL_Safe_Last         : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
+   IEEEX_Safe_Last         : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
+   VAXFF_Safe_Last         : constant := 16#0.7FFF_FF8#E+32;
+   VAXDF_Safe_Last         : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32;
+   VAXGF_Safe_Last         : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
+   AAMPS_Safe_Last         : constant := 16#0.7FFF_FF8#E+32;
+   AAMPL_Safe_Last         : constant := 16#0.7FFF_FFFF_FF8#E+32;
+
+   IEEES_Safe_Small        : constant := 2#1.0#E-126;
+   IEEEL_Safe_Small        : constant := 2#1.0#E-1022;
+   IEEEX_Safe_Small        : constant := 2#1.0#E-16381;
+   VAXFF_Safe_Small        : constant := 16#0.1000_000#E-31;
+   VAXDF_Safe_Small        : constant := 16#0.1000_0000_0000_000#E-31;
+   VAXGF_Safe_Small        : constant := 16#0.1000_0000_0000_00#E-255;
+   AAMPS_Safe_Small        : constant := 16#0.1000_000#E-31;
+   AAMPL_Safe_Small        : constant := 16#0.1000_0000_000#E-31;
+
+   ----------------------
+   -- Typed Attributes --
+   ----------------------
+
+   --  The attributes First and Last are typed attributes in Ada, and yield
+   --  values of the appropriate float type. However we still describe them
+   --  as universal real values in this file, since we are talking about the
+   --  target floating-point types, not the host floating-point types.
+
+   IEEES_First             : constant := -16#0.FFFF_FF#E+32;
+   IEEEL_First             : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
+   IEEEX_First             : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
+   VAXFF_First             : constant := -16#0.7FFF_FF8#E+32;
+   VAXDF_First             : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32;
+   VAXGF_First             : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256;
+   AAMPS_First             : constant := -16#0.7FFF_FF8#E+32;
+   AAMPL_First             : constant := -16#0.7FFF_FFFF_FF8#E+32;
+
+   IEEES_Last              : constant := 16#0.FFFF_FF#E+32;
+   IEEEL_Last              : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
+   IEEEX_Last              : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
+   VAXFF_Last              : constant := 16#0.7FFF_FF8#E+32;
+   VAXDF_Last              : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32;
+   VAXGF_Last              : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
+   AAMPS_Last              : constant := 16#0.7FFF_FF8#E+32;
+   AAMPL_Last              : constant := 16#0.7FFF_FFFF_FF8#E+32;
+
+end Ttypef;

gcc/ada/ttypes.ads

@@ -0,0 +1,211 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               T T Y P E S                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                             $Revision: 1.25 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains constants describing target properties
+
+with Types;    use Types;
+with Get_Targ; use Get_Targ;
+
+package Ttypes is
+
+   ------------------------------
+   -- Host/Target Dependencies --
+   ------------------------------
+
+   --  It is vital to maintain a clear distinction between properties of
+   --  types on the host and types on the target, since in the general
+   --  case of a cross-compiler these will be different.
+
+   --  This package and its companion Ttypef provide definitions of values
+   --  that describe the properties of the target types. All instances of
+   --  target dependencies, including the definitions of such packages as
+   --  Standard and System depend directly or indirectly on the definitions
+   --  in the Ttypes and Ttypef packages.
+
+   --  In the source of the compiler, references to attributes such as
+   --  Integer'Size will give information regarding the host types (i.e.
+   --  the types within the compiler itself). Such references are therefore
+   --  almost always suspicious (it is hard for example to see that the
+   --  code in the compiler should even be using type Integer very much,
+   --  and certainly this code should not depend on the size of Integer).
+
+   --  On the other hand, it is perfectly reasonable for the compiler to
+   --  require access to the size of type Integer for the target machine,
+   --  e.g. in constructing the internal representation of package Standard.
+   --  For this purpose, instead of referencing the attribute Integer'Size,
+   --  a reference to Ttypes.Standard_Integer_Size will provide the needed
+   --  value for the target type.
+
+   --  Two approaches are used for handling target dependent values in the
+   --  standard library packages. Package Standard is handled specially,
+   --  being constructed internally (by package Stand). Target dependent
+   --  values needed in Stand are obtained by direct reference to Ttypes
+   --  and Ttypef.
+
+   --  For package System, the required constant values are obtained by
+   --  referencing appropriate attributes. Ada 95 already defines most of
+   --  the required attributes, and GNAT specific attributes have been
+   --  defined to cover the remaining cases (such as Storage_Unit). The
+   --  evaluation of these attributes obtains the required target dependent
+   --  values from Ttypes and Ttypef. The additional attributes that have
+   --  been added to GNAT (Address_Size, Storage_Unit, Word_Size, Max_Priority,
+   --  and Max_Interrupt_Priority) are for almost all purposes redundant with
+   --  respect to the corresponding references to System constants. For example
+   --  in a program, System.Address_Size and Standard'Address_Size yield the
+   --  same value. The critical use of the attribute is in writing the System
+   --  declaration of Address_Size which of course cannot refer to itself. By
+   --  this means we achieve complete target independence in the source code
+   --  of package System, i.e. there is only one copy of the source of System
+   --  for all targets.
+
+   --  Note that during compilation there are two versions of package System
+   --  around. The version that is directly WITH'ed by compiler packages
+   --  contains host-dependent definitions, which is what is needed in that
+   --  case (for example, System.Storage_Unit referenced in the source of the
+   --  compiler refers to the storage unit of the host, not the target. This
+   --  means that, like attribute references, any references to constants in
+   --  package System in the compiler code are suspicious, since it is strange
+   --  for the compiler to have such host dependencies. If the compiler needs
+   --  to access the target dependent values of such quantities as Storage_Unit
+   --  then it should reference the constants in this package (Ttypes), rather
+   --  than referencing System.Storage_Unit, or Standard'Storage_Unit, both of
+   --  which would yield the host value.
+
+   ---------------------------------------------------
+   -- Target-Dependent Values for Types in Standard --
+   ---------------------------------------------------
+
+   --  Note: GNAT always supplies all the following integer and float types,
+   --  but depending on the machine, some of the types may be identical. For
+   --  example, on some machines, Short_Float may be the same as Float, and
+   --  Long_Long_Float may be the same as Long_Float.
+
+   Standard_Short_Short_Integer_Size   : constant Pos := Get_Char_Size;
+   Standard_Short_Short_Integer_Width  : constant Pos :=
+                           Width_From_Size (Standard_Short_Short_Integer_Size);
+
+   Standard_Short_Integer_Size         : constant Pos := Get_Short_Size;
+   Standard_Short_Integer_Width        : constant Pos :=
+                           Width_From_Size (Standard_Short_Integer_Size);
+
+   Standard_Integer_Size               : constant Pos := Get_Int_Size;
+   Standard_Integer_Width              : constant Pos :=
+                           Width_From_Size (Standard_Integer_Size);
+
+   Standard_Long_Integer_Size          : constant Pos := Get_Long_Size;
+   Standard_Long_Integer_Width         : constant Pos :=
+                           Width_From_Size (Standard_Long_Integer_Size);
+
+   Standard_Long_Long_Integer_Size     : constant Pos := Get_Long_Long_Size;
+   Standard_Long_Long_Integer_Width    : constant Pos :=
+                           Width_From_Size (Standard_Long_Long_Integer_Size);
+
+   Standard_Short_Float_Size           : constant Pos := Get_Float_Size;
+   Standard_Short_Float_Digits         : constant Pos :=
+                           Digits_From_Size (Standard_Short_Float_Size);
+
+   Standard_Float_Size                 : constant Pos := Get_Float_Size;
+   Standard_Float_Digits               : constant Pos :=
+                           Digits_From_Size (Standard_Float_Size);
+
+   Standard_Long_Float_Size            : constant Pos := Get_Double_Size;
+   Standard_Long_Float_Digits          : constant Pos :=
+                           Digits_From_Size (Standard_Long_Float_Size);
+
+   Standard_Long_Long_Float_Size       : constant Pos := Get_Long_Double_Size;
+   Standard_Long_Long_Float_Digits     : constant Pos :=
+                           Digits_From_Size (Standard_Long_Long_Float_Size);
+
+   Standard_Character_Size             : constant Pos := Get_Char_Size;
+
+   Standard_Wide_Character_Size        : constant Pos := 2 * Get_Char_Size;
+   --  The Standard.Wide_Character type is special in the sense that
+   --  it is not defined in terms of its corresponding C type (wchar_t).
+   --  Unfortunately this makes the representation of Wide_Character
+   --  incompatible with the C wchar_t type.
+   --  ??? This is required by the RM or backward compatibility
+
+   --  Note: there is no specific control over the representation of
+   --  enumeration types. The convention used is that if an enumeration
+   --  type has fewer than 2**(Character'Size) elements, then the size
+   --  used is Character'Size, otherwise Integer'Size is used.
+
+   --  Similarly, the size of fixed-point types depends on the size of the
+   --  corresponding integer type, which is the smallest predefined integer
+   --  type capable of representing the required range of values.
+
+   -------------------------------------------------
+   -- Target-Dependent Values for Types in System --
+   -------------------------------------------------
+
+   System_Address_Size : constant Pos := Get_Pointer_Size;
+   --  System.Address'Size (also size of all thin pointers)
+
+   System_Max_Binary_Modulus_Power    : constant Pos :=
+                                          Standard_Long_Long_Integer_Size;
+
+   System_Max_Nonbinary_Modulus_Power : constant Pos :=
+                                          Standard_Integer_Size - 1;
+
+   System_Storage_Unit : constant Pos := Get_Bits_Per_Unit;
+   System_Word_Size    : constant Pos := Get_Bits_Per_Word;
+
+   System_Tick_Nanoseconds : constant Pos := 1_000_000_000;
+   --  Value of System.Tick in nanoseconds. At the moment, this is a fixed
+   --  constant (with value of 1.0 seconds), but later we should add this
+   --  value to the GCC configuration file so that its value can be made
+   --  configuration dependent.
+
+   -----------------------------------------------------
+   -- Target-Dependent Values for Types in Interfaces --
+   -----------------------------------------------------
+
+   Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size;
+
+   ----------------------------------------
+   -- Other Target-Dependent Definitions --
+   ----------------------------------------
+
+   Maximum_Alignment : constant Pos := Get_Maximum_Alignment;
+   --  The maximum alignment, in storage units, that an object or
+   --  type may require on the target machine.
+
+   Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0;
+   --  Important note: for Ada purposes, the important setting is the bytes
+   --  endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian).
+   --  This is because Ada bit addressing must be compatible with the byte
+   --  ordering (otherwise we would end up with non-contiguous fields). It
+   --  is rare for the two to be different, but if they are, Bits_Big_Endian
+   --  is relevant only for the generation of instructions with bit numbers,
+   --  and thus relevant only to the back end. Note that this is a variable
+   --  rather than a constant, since it can be modified (flipped) by -gnatd8.
+
+   Target_Strict_Alignment : Boolean := Get_Strict_Alignment /= 0;
+   --  True if instructions will fail if data is misaligned
+
+end Ttypes;

gcc/ada/types.adb

@@ -0,0 +1,235 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                T Y P E S                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.20 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+package body Types is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat;
+   --  Extract two decimal digit value from time stamp
+
+   ---------
+   -- "<" --
+   ---------
+
+   function "<" (Left, Right : Time_Stamp_Type) return Boolean is
+   begin
+      return not (Left = Right) and then String (Left) < String (Right);
+   end "<";
+
+   ----------
+   -- "<=" --
+   ----------
+
+   function "<=" (Left, Right : Time_Stamp_Type) return Boolean is
+   begin
+      return not (Left > Right);
+   end "<=";
+
+   ---------
+   -- "=" --
+   ---------
+
+   function "=" (Left, Right : Time_Stamp_Type) return Boolean is
+      Sleft  : Nat;
+      Sright : Nat;
+
+   begin
+      if String (Left) = String (Right) then
+         return True;
+
+      elsif Left (1) = ' ' or else Right (1) = ' ' then
+         return False;
+      end if;
+
+      --  In the following code we check for a difference of 2 seconds or less
+
+      --  Recall that the time stamp format is:
+
+      --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
+      --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
+
+      --  Note that we do not bother to worry about shifts in the day.
+      --  It seems unlikely that such shifts could ever occur in practice
+      --  and even if they do we err on the safe side, ie we say that the time
+      --  stamps are different.
+
+      Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09));
+      Sleft  := V (Left,  13) + 60 * (V (Left,  11) + 60 * V (Left,  09));
+
+      --  So the check is: dates must be the same, times differ 2 sec at most
+
+      return abs (Sleft - Sright) <= 2
+         and then String (Left (1 .. 8)) = String (Right (1 .. 8));
+   end "=";
+
+   ---------
+   -- ">" --
+   ---------
+
+   function ">" (Left, Right : Time_Stamp_Type) return Boolean is
+   begin
+      return not (Left = Right) and then String (Left) > String (Right);
+   end ">";
+
+   ----------
+   -- ">=" --
+   ----------
+
+   function ">=" (Left, Right : Time_Stamp_Type) return Boolean is
+   begin
+      return not (Left < Right);
+   end ">=";
+
+   -------------------
+   -- Get_Char_Code --
+   -------------------
+
+   function Get_Char_Code (C : Character) return Char_Code is
+   begin
+      return Char_Code'Val (Character'Pos (C));
+   end Get_Char_Code;
+
+   -------------------
+   -- Get_Character --
+   -------------------
+
+   --  Note: raises Constraint_Error if checks on and C out of range
+
+   function Get_Character (C : Char_Code) return Character is
+   begin
+      return Character'Val (C);
+   end Get_Character;
+
+   --------------------
+   -- Get_Hex_String --
+   --------------------
+
+   subtype Wordh is Word range 0 .. 15;
+   Hex : constant array (Wordh) of Character := "0123456789ABCDEF";
+
+   function Get_Hex_String (W : Word) return Word_Hex_String is
+      X  : Word := W;
+      WS : Word_Hex_String;
+
+   begin
+      for J in reverse 1 .. 8 loop
+         WS (J) := Hex (X mod 16);
+         X := X / 16;
+      end loop;
+
+      return WS;
+   end Get_Hex_String;
+
+   ------------------------
+   -- In_Character_Range --
+   ------------------------
+
+   function In_Character_Range (C : Char_Code) return Boolean is
+   begin
+      return (C <= 255);
+   end In_Character_Range;
+
+   ---------------------
+   -- Make_Time_Stamp --
+   ---------------------
+
+   procedure Make_Time_Stamp
+     (Year    : Nat;
+      Month   : Nat;
+      Day     : Nat;
+      Hour    : Nat;
+      Minutes : Nat;
+      Seconds : Nat;
+      TS      : out Time_Stamp_Type)
+   is
+      Z : constant := Character'Pos ('0');
+
+   begin
+      TS (01) := Character'Val (Z + Year / 1000);
+      TS (02) := Character'Val (Z + (Year / 100) mod 10);
+      TS (03) := Character'Val (Z + (Year / 10) mod 10);
+      TS (04) := Character'Val (Z + Year mod 10);
+      TS (05) := Character'Val (Z + Month / 10);
+      TS (06) := Character'Val (Z + Month mod 10);
+      TS (07) := Character'Val (Z + Day / 10);
+      TS (08) := Character'Val (Z + Day mod 10);
+      TS (09) := Character'Val (Z + Hour / 10);
+      TS (10) := Character'Val (Z + Hour mod 10);
+      TS (11) := Character'Val (Z + Minutes / 10);
+      TS (12) := Character'Val (Z + Minutes mod 10);
+      TS (13) := Character'Val (Z + Seconds / 10);
+      TS (14) := Character'Val (Z + Seconds mod 10);
+   end Make_Time_Stamp;
+
+   ----------------------
+   -- Split_Time_Stamp --
+   ----------------------
+
+   procedure Split_Time_Stamp
+     (TS      : Time_Stamp_Type;
+      Year    : out Nat;
+      Month   : out Nat;
+      Day     : out Nat;
+      Hour    : out Nat;
+      Minutes : out Nat;
+      Seconds : out Nat)
+   is
+
+   begin
+      --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
+      --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
+
+      Year    := 100 * V (TS, 01) + V (TS, 03);
+      Month   := V (TS, 05);
+      Day     := V (TS, 07);
+      Hour    := V (TS, 09);
+      Minutes := V (TS, 11);
+      Seconds := V (TS, 13);
+   end Split_Time_Stamp;
+
+   -------
+   -- V --
+   -------
+
+   function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
+   begin
+      return 10 * (Character'Pos (T (X))     - Character'Pos ('0')) +
+                   Character'Pos (T (X + 1)) - Character'Pos ('0');
+   end V;
+
+end Types;

gcc/ada/types.ads

@@ -0,0 +1,720 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                T Y P E S                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.87 $
+--                                                                          --
+--          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 Unchecked_Deallocation;
+
+package Types is
+pragma Preelaborate (Types);
+
+--  This package contains host independent type definitions which are used
+--  in more than one unit in the compiler. They are gathered here for easy
+--  reference, though in some cases the full description is found in the
+--  relevant module which implements the definition. The main reason that
+--  they are not in their "natural" specs is that this would cause a lot of
+--  inter-spec dependencies, and in particular some awkward circular
+--  dependencies would have to be dealt with.
+
+--  WARNING: There is a C version of this package. Any changes to this
+--  source file must be properly reflected in the C header file a-types.h
+
+--  Note: the declarations in this package reflect an expectation that the
+--  host machine has an efficient integer base type with a range at least
+--  32 bits 2s-complement. If there are any machines for which this is not
+--  a correct assumption, a significant number of changes will be required!
+
+   -------------------------------
+   -- General Use Integer Types --
+   -------------------------------
+
+   type Int is range -2 ** 31 .. +2 ** 31 - 1;
+   --  Signed 32-bit integer
+
+   type Dint is range -2 ** 63 .. +2 ** 63 - 1;
+   --  Double length (64-bit) integer
+
+   subtype Nat is Int range 0 .. Int'Last;
+   --  Non-negative Int values
+
+   subtype Pos is Int range 1 .. Int'Last;
+   --  Positive Int values
+
+   type Word is mod 2 ** 32;
+   --  Unsigned 32-bit integer
+
+   type Short is range -32768 .. +32767;
+   for Short'Size use 16;
+   --  16-bit signed integer
+
+   type Byte is mod 2 ** 8;
+   for Byte'Size use 8;
+   --  8-bit unsigned integer
+
+   type size_t is mod 2 ** Standard'Address_Size;
+   --  Memory size value, for use in calls to C routines
+
+   --------------------------------------
+   -- 8-Bit Character and String Types --
+   --------------------------------------
+
+   --  We use Standard.Character and Standard.String freely, since we are
+   --  compiling ourselves, and we properly implement the required 8-bit
+   --  character code as required in Ada 95. This section defines a few
+   --  general use constants and subtypes.
+
+   EOF : constant Character := ASCII.SUB;
+   --  The character SUB (16#1A#) is used in DOS and other systems derived
+   --  from DOS (OS/2, NT etc) to signal the end of a text file. Internally
+   --  all source files are ended by an EOF character, even on Unix systems.
+   --  An EOF character acts as the end of file only as the last character
+   --  of a source buffer, in any other position, it is treated as a blank
+   --  if it appears between tokens, and as an illegal character otherwise.
+   --  This makes life easier dealing with files that originated from DOS,
+   --  including concatenated files with interspersed EOF characters.
+
+   subtype Graphic_Character is Character range ' ' .. '~';
+   --  Graphic characters, as defined in ARM
+
+   subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR;
+   --  Line terminator characters (LF, VT, FF, CR)
+
+   subtype Upper_Half_Character is
+     Character range Character'Val (16#80#) .. Character'Val (16#FF#);
+   --  Characters with the upper bit set
+
+   type Character_Ptr is access all Character;
+   type String_Ptr    is access all String;
+   --  Standard character and string pointers
+
+   procedure Free is new Unchecked_Deallocation (String, String_Ptr);
+   --  Procedure for freeing dynamically allocated String values
+
+   subtype Word_Hex_String is String (1 .. 8);
+   --  Type used to represent Word value as 8 hex digits, with upper case
+   --  letters for the alphabetic cases.
+
+   function Get_Hex_String (W : Word) return Word_Hex_String;
+   --  Convert word value to 8-character hex string
+
+   -----------------------------------------
+   -- Types Used for Text Buffer Handling --
+   -----------------------------------------
+
+   --  We can't use type String for text buffers, since we must use the
+   --  standard 32-bit integer as an index value, since we count on all
+   --  index values being the same size.
+
+   type Text_Ptr is new Int;
+   --  Type used for subscripts in text buffer
+
+   type Text_Buffer is array (Text_Ptr range <>) of Character;
+   --  Text buffer used to hold source file or library information file
+
+   type Text_Buffer_Ptr is access all Text_Buffer;
+   --  Text buffers for input files are allocated dynamically and this type
+   --  is used to reference these text buffers.
+
+   procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr);
+   --  Procedure for freeing dynamically allocated text buffers
+
+   ------------------------------------------
+   -- Types Used for Source Input Handling --
+   ------------------------------------------
+
+   type Logical_Line_Number is range 0 .. Int'Last;
+   for Logical_Line_Number'Size use 32;
+   --  Line number type, used for storing logical line numbers (i.e. line
+   --  numbers that include effects of any Source_Reference pragmas in the
+   --  source file). The value zero indicates a line containing a source
+   --  reference pragma.
+
+   No_Line_Number : constant Logical_Line_Number := 0;
+   --  Special value used to indicate no line number
+
+   type Physical_Line_Number is range 1 .. Int'Last;
+   for Physical_Line_Number'Size use 32;
+   --  Line number type, used for storing physical line numbers (i.e.
+   --  line numbers in the physical file being compiled, unaffected by
+   --  the presence of source reference pragmas.
+
+   type Column_Number is range 0 .. 32767;
+   for Column_Number'Size use 16;
+   --  Column number (assume that 2**15 is large enough, see declaration
+   --  of Hostparm.Max_Line_Length)
+
+   No_Column_Number : constant Column_Number := 0;
+   --  Special value used to indicate no column number
+
+   subtype Source_Buffer is Text_Buffer;
+   --  Type used to store text of a source file . The buffer for the main
+   --  source (the source specified on the command line) has a lower bound
+   --  starting at zero. Subsequent subsidiary sources have lower bounds
+   --  which are one greater than the previous upper bound.
+
+   subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last);
+   --  This is a virtual type used as the designated type of the access
+   --  type Source_Buffer_Ptr, see Osint.Read_Source_File for details.
+
+   type Source_Buffer_Ptr is access all Big_Source_Buffer;
+   --  Pointer to source buffer. We use virtual origin addressing for
+   --  source buffers, with thin pointers. The pointer points to a virtual
+   --  instance of type Big_Source_Buffer, where the actual type is in fact
+   --  of type Source_Buffer. The address is adjusted so that the virtual
+   --  origin addressing works correctly. See Osint.Read_Source_Buffer for
+   --  further details.
+
+   subtype Source_Ptr is Text_Ptr;
+   --  Type used to represent a source location, which is a subscript of a
+   --  character in the source buffer. As noted above, diffferent source
+   --  buffers have different ranges, so it is possible to tell from a
+   --  Source_Ptr value which source it refers to. Note that negative numbers
+   --  are allowed to accomodate the following special values.
+
+   No_Location : constant Source_Ptr := -1;
+   --  Value used to indicate no source position set in a node
+
+   Standard_Location : constant Source_Ptr := -2;
+   --  Used for all nodes in the representation of package Standard other
+   --  than nodes representing the contents of Standard.ASCII. Note that
+   --  testing for <= Standard_Location tests for both Standard_Location
+   --  and for Standard_ASCII_Location.
+
+   Standard_ASCII_Location : constant Source_Ptr := -3;
+   --  Used for all nodes in the presentation of package Standard.ASCII
+
+   First_Source_Ptr : constant Source_Ptr := 0;
+   --  Starting source pointer index value for first source program
+
+   -------------------------------------
+   -- Range Definitions for Tree Data --
+   -------------------------------------
+
+   --  The tree has fields that can hold any of the following types:
+
+   --    Pointers to other tree nodes (type Node_Id)
+   --    List pointers (type List_Id)
+   --    Element list pointers (type Elist_Id)
+   --    Names (type Name_Id)
+   --    Strings (type String_Id)
+   --    Universal integers (type Uint)
+   --    Universal reals (type Ureal)
+   --    Character codes (type Char_Code stored with a bias)
+
+   --  In most contexts, the strongly typed interface determines which of
+   --  these types is present. However, there are some situations (involving
+   --  untyped traversals of the tree), where it is convenient to be easily
+   --  able to distinguish these values. The underlying representation in all
+   --  cases is an integer type Union_Id, and we ensure that the range of
+   --  the various possible values for each of the above types is disjoint
+   --  so that this distinction is possible.
+
+   type Union_Id is new Int;
+   --  The type in the tree for a union of possible ID values
+
+   --  Note: it is also helpful for debugging purposes to make these ranges
+   --  distinct. If a bug leads to misidentification of a value, then it will
+   --  typically result in an out of range value and a Constraint_Error.
+
+   List_Low_Bound : constant := -100_000_000;
+   --  The List_Id values are subscripts into an array of list headers which
+   --  has List_Low_Bound as its lower bound. This value is chosen so that all
+   --  List_Id values are negative, and the value zero is in the range of both
+   --  List_Id and Node_Id values (see further description below).
+
+   List_High_Bound : constant := 0;
+   --  Maximum List_Id subscript value. This allows up to 100 million list
+   --  Id values, which is in practice infinite, and there is no need to
+   --  check the range. The range overlaps the node range by one element
+   --  (with value zero), which is used both for the Empty node, and for
+   --  indicating no list. The fact that the same value is used is convenient
+   --  because it means that the default value of Empty applies to both nodes
+   --  and lists, and also is more efficient to test for.
+
+   Node_Low_Bound : constant := 0;
+   --  The tree Id values start at zero, because we use zero for Empty (to
+   --  allow a zero test for Empty). Actual tree node subscripts start at 0
+   --  since Empty is a legitimate node value.
+
+   Node_High_Bound : constant := 099_999_999;
+   --  Maximum number of nodes that can be allocated is 100 million, which
+   --  is in practice infinite, and there is no need to check the range.
+
+   Elist_Low_Bound : constant := 100_000_000;
+   --  The Elist_Id values are subscripts into an array of elist headers which
+   --  has Elist_Low_Bound as its lower bound.
+
+   Elist_High_Bound : constant := 199_999_999;
+   --  Maximum Elist_Id subscript value. This allows up to 100 million Elists,
+   --  which is in practice infinite and there is no need to check the range.
+
+   Elmt_Low_Bound : constant := 200_000_000;
+   --  Low bound of element Id values. The use of these values is internal to
+   --  the Elists package, but the definition of the range is included here
+   --  since it must be disjoint from other Id values. The Elmt_Id values are
+   --  subscripts into an array of list elements which has this as lower bound.
+
+   Elmt_High_Bound : constant := 299_999_999;
+   --  Upper bound of Elmt_Id values. This allows up to 100 million element
+   --  list members, which is in practice infinite (no range check needed).
+
+   Names_Low_Bound : constant := 300_000_000;
+   --  Low bound for name Id values
+
+   Names_High_Bound : constant := 399_999_999;
+   --  Maximum number of names that can be allocated is 100 million, which is
+   --  in practice infinite and there is no need to check the range.
+
+   Strings_Low_Bound : constant := 400_000_000;
+   --  Low bound for string Id values
+
+   Strings_High_Bound : constant := 499_999_999;
+   --  Maximum number of strings that can be allocated is 100 million, which
+   --  is in practice infinite and there is no need to check the range.
+
+   Ureal_Low_Bound : constant := 500_000_000;
+   --  Low bound for Ureal values.
+
+   Ureal_High_Bound : constant := 599_999_999;
+   --  Maximum number of Ureal values stored is 100_000_000 which is in
+   --  practice infinite so that no check is required.
+
+   Uint_Low_Bound : constant := 600_000_000;
+   --  Low bound for Uint values.
+
+   Uint_Table_Start : constant := 2_000_000_000;
+   --  Location where table entries for universal integers start (see
+   --  Uintp spec for details of the representation of Uint values).
+
+   Uint_High_Bound : constant := 2_099_999_999;
+   --  The range of Uint values is very large, since a substantial part
+   --  of this range is used to store direct values, see Uintp for details.
+
+   Char_Code_Bias : constant := 2_100_000_000;
+   --  A bias value added to character code values stored in the tree which
+   --  ensures that they have different values from any of the above types.
+
+   --  The following subtype definitions are used to provide convenient names
+   --  for membership tests on Int values to see what data type range they
+   --  lie in. Such tests appear only in the lowest level packages.
+
+   subtype List_Range      is Union_Id
+     range List_Low_Bound   .. List_High_Bound;
+
+   subtype Node_Range      is Union_Id
+     range Node_Low_Bound   .. Node_High_Bound;
+
+   subtype Elist_Range     is Union_Id
+     range Elist_Low_Bound  .. Elist_High_Bound;
+
+   subtype Elmt_Range      is Union_Id
+     range Elmt_Low_Bound   .. Elmt_High_Bound;
+
+   subtype Names_Range     is Union_Id
+     range Names_Low_Bound   .. Names_High_Bound;
+
+   subtype Strings_Range   is Union_Id
+     range Strings_Low_Bound .. Strings_High_Bound;
+
+   subtype Uint_Range      is Union_Id
+     range Uint_Low_Bound    .. Uint_High_Bound;
+
+   subtype Ureal_Range     is Union_Id
+     range Ureal_Low_Bound    .. Ureal_High_Bound;
+
+   subtype Char_Code_Range is Union_Id
+     range Char_Code_Bias    .. Char_Code_Bias + 2**16 - 1;
+
+   -----------------------------
+   -- Types for Namet Package --
+   -----------------------------
+
+   --  Name_Id values are used to identify entries in the names table. Except
+   --  for the special values No_Name, and Error_Name, they are subscript
+   --  values for the Names table defined in package Namet.
+
+   --  Note that with only a few exceptions, which are clearly documented, the
+   --  type Name_Id should be regarded as a private type. In particular it is
+   --  never appropriate to perform arithmetic operations using this type.
+
+   type Name_Id is range Names_Low_Bound .. Names_High_Bound;
+   for Name_Id'Size use 32;
+   --  Type used to identify entries in the names table
+
+   No_Name : constant Name_Id := Names_Low_Bound;
+   --  The special Name_Id value No_Name is used in the parser to indicate
+   --  a situation where no name is present (e.g. on a loop or block).
+
+   Error_Name : constant Name_Id := Names_Low_Bound +  1;
+   --  The special Name_Id value Error_Name is used in the parser to
+   --  indicate that some kind of error was encountered in scanning out
+   --  the relevant name, so it does not have a representable label.
+
+   First_Name_Id : constant Name_Id := Names_Low_Bound + 2;
+   --  Subscript of first entry in names table
+
+   ----------------------------
+   -- Types for Atree Package --
+   ----------------------------
+
+   --  Node_Id values are used to identify nodes in the tree. They are
+   --  subscripts into the Node table declared in package Tree. Note that
+   --  the special values Empty and Error are subscripts into this table,
+   --  See package Atree for further details.
+
+   type Node_Id is range Node_Low_Bound .. Node_High_Bound;
+   --  Type used to identify nodes in the tree
+
+   subtype Entity_Id is Node_Id;
+   --  A synonym for node types, used in the entity package to refer to
+   --  nodes that are entities (i.e. nodes with an Nkind of N_Defining_xxx)
+   --  All such nodes are extended nodes and these are the only extended
+   --  nodes, so that in practice entity and extended nodes are synonymous.
+
+   subtype Node_Or_Entity_Id is Node_Id;
+   --  A synonym for node types, used in cases where a given value may be used
+   --  to represent either a node or an entity. We like to minimize such uses
+   --  for obvious reasons of logical type consistency, but where such uses
+   --  occur, they should be documented by use of this type.
+
+   Empty : constant Node_Id := Node_Low_Bound;
+   --  Used to indicate null node. A node is actually allocated with this
+   --  Id value, so that Nkind (Empty) = N_Empty. Note that Node_Low_Bound
+   --  is zero, so Empty = No_List = zero.
+
+   Empty_List_Or_Node : constant := 0;
+   --  This constant is used in situations (e.g. initializing empty fields)
+   --  where the value set will be used to represent either an empty node
+   --  or a non-existent list, depending on the context.
+
+   Error : constant Node_Id := Node_Low_Bound + 1;
+   --  Used to indicate that there was an error in the source program. A node
+   --  is actually allocated at this address, so that Nkind (Error) = N_Error.
+
+   Empty_Or_Error : constant Node_Id := Error;
+   --  Since Empty and Error are the first two Node_Id values, the test for
+   --  N <= Empty_Or_Error tests to see if N is Empty or Error. This definition
+   --  provides convenient self-documentation for such tests.
+
+   First_Node_Id  : constant Node_Id := Node_Low_Bound;
+   --  Subscript of first allocated node. Note that Empty and Error are both
+   --  allocated nodes, whose Nkind fields can be accessed without error.
+
+   ------------------------------
+   -- Types for Nlists Package --
+   ------------------------------
+
+   --  List_Id values are used to identify node lists in the tree. They are
+   --  subscripts into the Lists table declared in package Tree. Note that
+   --  the special value Error_List is a subscript in this table, but the
+   --  value No_List is *not* a valid subscript, and any attempt to apply
+   --  list operations to No_List will cause a (detected) error.
+
+   type List_Id is range List_Low_Bound .. List_High_Bound;
+   --  Type used to identify a node list
+
+   No_List : constant List_Id := List_High_Bound;
+   --  Used to indicate absence of a list. Note that the value is zero, which
+   --  is the same as Empty, which is helpful in intializing nodes where a
+   --  value of zero can represent either an empty node or an empty list.
+
+   Error_List : constant List_Id := List_Low_Bound;
+   --  Used to indicate that there was an error in the source program in a
+   --  context which would normally require a list. This node appears to be
+   --  an empty list to the list operations (a null list is actually allocated
+   --  which has this Id value).
+
+   First_List_Id : constant List_Id := Error_List;
+   --  Subscript of first allocated list header
+
+   ------------------------------
+   -- Types for Elists Package --
+   ------------------------------
+
+   --  Element list Id values are used to identify element lists stored in
+   --  the tree (see package Tree for further details). They are formed by
+   --  adding a bias (Element_List_Bias) to subscript values in the same
+   --  array that is used for node list headers.
+
+   type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound;
+   --  Type used to identify an element list (Elist header table subscript)
+
+   No_Elist : constant Elist_Id := Elist_Low_Bound;
+   --  Used to indicate absense of an element list. Note that this is not
+   --  an actual Elist header, so element list operations on this value
+   --  are not valid.
+
+   First_Elist_Id : constant Elist_Id := No_Elist + 1;
+   --  Subscript of first allocated Elist header.
+
+   --  Element Id values are used to identify individual elements of an
+   --  element list (see package Elists for further details).
+
+   type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound;
+   --  Type used to identify an element list
+
+   No_Elmt : constant Elmt_Id := Elmt_Low_Bound;
+   --  Used to represent empty element
+
+   First_Elmt_Id : constant Elmt_Id := No_Elmt + 1;
+   --  Subscript of first allocated Elmt table entry
+
+   -------------------------------
+   -- Types for Stringt Package --
+   -------------------------------
+
+   --  String_Id values are used to identify entries in the strings table.
+   --  They are subscripts into the strings table defined in package Strings.
+
+   --  Note that with only a few exceptions, which are clearly documented, the
+   --  type String_Id should be regarded as a private type. In particular it is
+   --  never appropriate to perform arithmetic operations using this type.
+
+   type String_Id is range Strings_Low_Bound .. Strings_High_Bound;
+   --  Type used to identify entries in the strings table
+
+   No_String : constant String_Id := Strings_Low_Bound;
+   --  Used to indicate missing string Id. Note that the value zero is used
+   --  to indicate a missing data value for all the Int types in this section.
+
+   First_String_Id : constant String_Id := No_String + 1;
+   --  First subscript allocated in string table
+
+   -------------------------
+   -- Character Code Type --
+   -------------------------
+
+   --  The type Char is used for character data internally in the compiler,
+   --  but character codes in the source are represented by the Char_Code
+   --  type. Each character literal in the source is interpreted as being one
+   --  of the 2**16 possible Wide_Character codes, and a unique integer value
+   --  is assigned, corresponding to the POS value in the Wide_Character type.
+   --  String literals are similarly interpreted as a sequence of such codes.
+
+   --  Note: when character code values are stored in the tree, they are stored
+   --  by adding a bias value (Char_Code_Bias) that results in values that can
+   --  be distinguished from other types of values stored in the tree.
+
+   type Char_Code is mod 2 ** 16;
+   for Char_Code'Size use 16;
+
+   function Get_Char_Code (C : Character) return Char_Code;
+   pragma Inline (Get_Char_Code);
+   --  Function to obtain internal character code from source character. For
+   --  the moment, the internal character code is simply the Pos value of the
+   --  input source character, but we provide this interface for possible
+   --  later support of alternative character sets.
+
+   function In_Character_Range (C : Char_Code) return Boolean;
+   pragma Inline (In_Character_Range);
+   --  Determines if the given character code is in range of type Character,
+   --  and if so, returns True. If not, returns False.
+
+   function Get_Character (C : Char_Code) return Character;
+   pragma Inline (Get_Character);
+   --  For a character C that is in character range (see above function), this
+   --  function returns the corresponding Character value. It is an error to
+   --  call Get_Character if C is not in character range
+
+   ---------------------------------------
+   -- Types used for Library Management --
+   ---------------------------------------
+
+   type Unit_Number_Type is new Int;
+   --  Unit number. The main source is unit 0, and subsidiary sources have
+   --  non-zero numbers starting with 1. Unit numbers are used to index the
+   --  file table in Lib.
+
+   Main_Unit : constant Unit_Number_Type := 0;
+   --  Unit number value for main unit
+
+   No_Unit : constant Unit_Number_Type := -1;
+   --  Special value used to signal no unit
+
+   type Source_File_Index is new Nat;
+   --  Type used to index the source file table (see package Sinput)
+
+   No_Source_File : constant Source_File_Index := 0;
+   --  Value used to indicate no source file present
+
+   System_Source_File_Index : constant Source_File_Index := 1;
+   --  Value used for source file table entry for system.ads, which is
+   --  always the first source file read (see unit Targparm for details).
+
+   subtype File_Name_Type is Name_Id;
+   --  File names are stored in the names table and this synonym is used to
+   --  indicate that a Name_Id value is being used to hold a simple file
+   --  name (which does not include any directory information).
+
+   No_File : constant File_Name_Type := File_Name_Type (No_Name);
+   --  Constant used to indicate no file found
+
+   subtype Unit_Name_Type is Name_Id;
+   --  Unit names are stored in the names table and this synonym is used to
+   --  indicate that a Name_Id value is being used to hold a unit name.
+
+   -----------------------------------
+   -- Representation of Time Stamps --
+   -----------------------------------
+
+   --  All compiled units are marked with a time stamp which is derived from
+   --  the source file (we assume that the host system has the concept of a
+   --  file time stamp which is modified when a file is modified). These
+   --  time stamps are used to ensure consistency of the set of units that
+   --  constitutes a library. Time stamps are 12 character strings with
+   --  with the following format:
+
+   --     YYYYMMDDHHMMSS
+
+   --       YYYY   year
+   --       MM     month (2 digits 01-12)
+   --       DD     day (2 digits 01-31)
+   --       HH     hour (2 digits 00-23)
+   --       MM     minutes (2 digits 00-59)
+   --       SS     seconds (2 digits 00-59)
+
+   --  In the case of Unix systems (and other systems which keep the time in
+   --  GMT), the time stamp is the GMT time of the file, not the local time.
+   --  This solves problems in using libraries across networks with clients
+   --  spread across multiple time-zones.
+
+   Time_Stamp_Length : constant := 14;
+   --  Length of time stamp value
+
+   subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length;
+   type Time_Stamp_Type is new String (Time_Stamp_Index);
+   --  Type used to represent time stamp
+
+   Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' ');
+   --  Type used to represent an empty or missing time stamp. Looks less
+   --  than any real time stamp if two time stamps are compared. Note that
+   --  although this is not a private type, clients should not rely on the
+   --  exact way in which this string is represented, and instead should
+   --  use the subprograms below.
+
+   function "="  (Left, Right : Time_Stamp_Type) return Boolean;
+   function "<=" (Left, Right : Time_Stamp_Type) return Boolean;
+   function ">=" (Left, Right : Time_Stamp_Type) return Boolean;
+   function "<"  (Left, Right : Time_Stamp_Type) return Boolean;
+   function ">"  (Left, Right : Time_Stamp_Type) return Boolean;
+   --  Comparison functions on time stamps. Note that two time stamps
+   --  are defined as being equal if they have the same day/month/year
+   --  and the hour/minutes/seconds values are within 2 seconds of one
+   --  another. This deals with rounding effects in library file time
+   --  stamps caused by copying operations during installation. We have
+   --  particularly noticed that WinNT seems susceptible to such changes.
+   --  Note: the Empty_Time_Stamp value looks equal to itself, and less
+   --  than any non-empty time stamp value.
+
+   procedure Split_Time_Stamp
+     (TS      : Time_Stamp_Type;
+      Year    : out Nat;
+      Month   : out Nat;
+      Day     : out Nat;
+      Hour    : out Nat;
+      Minutes : out Nat;
+      Seconds : out Nat);
+   --  Given a time stamp, decompose it into its components
+
+   procedure Make_Time_Stamp
+     (Year    : Nat;
+      Month   : Nat;
+      Day     : Nat;
+      Hour    : Nat;
+      Minutes : Nat;
+      Seconds : Nat;
+      TS      : out Time_Stamp_Type);
+   --  Given the components of a time stamp, initialize the value
+
+   -----------------------------------------------
+   -- Types used for Pragma Suppress Management --
+   -----------------------------------------------
+
+   --  The following record contains an entry for each recognized check name
+   --  for pragma Suppress. It is used to represent current settings of scope
+   --  based suppress actions from pragma Suppress or command line settings.
+
+   type Suppress_Record is record
+      Access_Checks        : Boolean;
+      Accessibility_Checks : Boolean;
+      Discriminant_Checks  : Boolean;
+      Division_Checks      : Boolean;
+      Elaboration_Checks   : Boolean;
+      Index_Checks         : Boolean;
+      Length_Checks        : Boolean;
+      Overflow_Checks      : Boolean;
+      Range_Checks         : Boolean;
+      Storage_Checks       : Boolean;
+      Tag_Checks           : Boolean;
+   end record;
+
+   --  To add a new check type to GNAT, the following steps are required:
+
+   --    1.  Add an appropriate entry to the above record type
+   --    2.  Add an entry to Snames spec and body for the new name
+   --    3.  Add an entry to the definition of Check_Id in the Snames spec
+   --    4.  Add a new entity flag definition in Einfo for the check
+   --    5.  Add a new function to Sem.Util to handle the new check test
+   --    6.  Add appropriate processing for pragma Suppress in Sem.Prag
+   --    7.  Add a branch to the case statement in Sem.Ch8.Pop_Scope
+   --    8.  Add a new Do_xxx_Check flag to Sinfo (if required)
+   --    9.  Add appropriate checks for the new test
+
+   -----------------------------------
+   -- Global Exception Declarations --
+   -----------------------------------
+
+   --  This section contains declarations of exceptions that are used
+   --  throughout the compiler.
+
+   Unrecoverable_Error : exception;
+   --  This exception is raised to immediately terminate the compilation
+   --  of the current source program. Used in situations where things are
+   --  bad enough that it doesn't seem worth continuing (e.g. max errors
+   --  reached, or a required file is not found). Also raised when the
+   --  compiler finds itself in trouble after an error (see Comperr).
+
+   ---------------------------------
+   -- Parameter Mechanism Control --
+   ---------------------------------
+
+   --  Function and parameter entities have a field that records the
+   --  passing mechanism. See specification of Sem_Mech for full details.
+   --  The following subtype is used to represent values of this type:
+
+   subtype Mechanism_Type is Int range -10 .. Int'Last;
+   --  Type used to represent a mechanism value. This is a subtype rather
+   --  than a type to avoid some annoying processing problems with certain
+   --  routines in Einfo (processing them to create the corresponding C).
+
+end Types;

gcc/ada/types.h

@@ -0,0 +1,335 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                T Y P E S                                 *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                             $Revision: 1.1 $
+ *                                                                          *
+ *          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.                                                      *
+ *                                                                          *
+ * 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). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This is the C file that corresponds to the Ada package spec Types. It was
+   created manually from the files types.ads and types.adb.
+
+   This package contains host independent type definitions which are used 
+   throughout the compiler modules. The comments in the C version are brief
+   reminders of the purpose of each declaration.  For complete documentation,
+   see the Ada version of these definitions.  */
+
+/* Boolean Types:  */
+
+/* Boolean type (cannot use enum, because of bit field restriction on some
+   compilers).  */
+typedef unsigned char Boolean;
+#define False 0
+#define True  1
+
+/* General Use Integer Types */
+
+/* Signed 32/bit integer */
+typedef int Int;
+
+/* Signed 16 bit integer */
+typedef short Short;
+
+/* Non/negative Int values */
+typedef Int Nat;
+
+/* Positive Int values */
+typedef Int Pos;
+
+/* 8/bit unsigned integer */
+typedef char Byte;
+
+/* 8/Bit Character and String Types:  */
+
+/* 8/bit character type */
+typedef char Char;
+
+/* Graphic characters, as defined in ARM */
+typedef Char Graphic_Character;
+
+/* Line terminator characters (LF, VT, FF, CR) */
+typedef Char Line_Terminator;
+
+/* Characters with the upper bit set */
+typedef Char Upper_Half_Character;
+
+/* String type built on Char (note that zero is an OK index) */
+typedef Char *Str;
+
+/* Pointer to string of Chars */
+typedef Char *Str_Ptr;
+
+/* Types for the fat pointer used for strings and the template it
+   points to.  */
+typedef struct {int Low_Bound, High_Bound; } String_Template;
+typedef struct {const char *Array; String_Template *Bounds; } 
+	__attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer;
+
+/* Types for Node/Entity Kinds:  */
+
+/* The reason that these are defined here in the C version, rather than in the
+   corresponding packages is that the requirement for putting bodies of
+   inlined stuff IN the C header changes the dependencies.  Both a-sinfo.h
+   and a-einfo.h now reference routines defined in tree.h.
+
+   Note: these types would more naturally be defined as unsigned  char, but
+   once again, the annoying restriction on bit fields for some compilers
+   bites us!  */
+
+typedef unsigned int Node_Kind;
+typedef unsigned int Entity_Kind;
+
+/* Types used for Text Buffer Handling:  */
+
+/* Type used for subscripts in text buffer.  */
+typedef Int Text_Ptr;
+
+/* Text buffer used to hold source file or library information file.  */
+typedef Char *Text_Buffer;
+
+/* Pointer to text buffer.  */
+typedef Char *Text_Buffer_Ptr;
+
+/* Types used for Source Input Handling:  */
+
+/* Line number type, used for storing all line numbers.  */
+typedef Int Line_Number_Type;
+
+/* Column number type, used for storing all column numbers.  */
+typedef Int Column_Number_Type;
+
+/* Type used to store text of a source file.  */
+typedef Text_Buffer Source_Buffer;
+
+/* Pointer to source buffer. */
+typedef Text_Buffer_Ptr Source_Buffer_Ptr;
+
+/* Type used for source location.  */
+typedef Text_Ptr Source_Ptr;
+
+/* Value used to indicate no source position set.  */
+#define No_Location -1
+
+/* Used for Sloc in all nodes in the representation of package Standard.  */
+#define Standard_Location -2
+
+/* Type used for union of all possible ID values covering all ranges */
+typedef int Union_Id;
+
+/* Range definitions for Tree Data:  */
+
+#define List_Low_Bound		-100000000
+#define List_High_Bound		0
+
+#define Node_Low_Bound		0
+#define Node_High_Bound		99999999
+
+#define Elist_Low_Bound		100000000
+#define Elist_High_Bound	199999999
+
+#define Elmt_Low_Bound		200000000
+#define Elmt_High_Bound		299999999
+
+#define Names_Low_Bound		300000000
+#define Names_High_Bound	399999999
+
+#define Strings_Low_Bound	400000000
+#define Strings_High_Bound	499999999
+
+#define Ureal_Low_Bound		500000000
+#define Ureal_High_Bound        599999999
+
+#define Uint_Low_Bound		600000000
+#define Uint_Table_Start        2000000000
+#define Uint_High_Bound	        2099999999
+
+#define Char_Code_Bias		2100000000
+
+SUBTYPE (List_Range,      Int, List_Low_Bound,    List_High_Bound)
+SUBTYPE (Node_Range,      Int, Node_Low_Bound,    Node_High_Bound)
+SUBTYPE (Elist_Range,     Int, Elist_Low_Bound,   Elist_High_Bound)
+SUBTYPE (Elmt_Range,      Int, Elmt_Low_Bound,    Elmt_High_Bound)
+SUBTYPE (Names_Range,     Int, Names_Low_Bound,   Names_High_Bound)
+SUBTYPE (Strings_Range,   Int, Strings_Low_Bound, Strings_High_Bound)
+SUBTYPE (Uint_Range,      Int, Uint_Low_Bound,    Uint_High_Bound)
+SUBTYPE (Ureal_Range,     Int, Ureal_Low_Bound,   Ureal_High_Bound)
+SUBTYPE (Char_Code_Range, Int, Char_Code_Bias,    (Char_Code_Bias + 65535))
+
+/* Types for Names_Table Package:  */
+
+typedef Int Name_Id;
+
+/* Name_Id value for no name present.  */
+#define No_Name Names_Low_Bound
+
+/* Name_Id value for bad name.  */
+#define Error_Name (Names_Low_Bound + 1)
+
+/* First subscript of names table. */
+#define First_Name_Id (Names_Low_Bound + 2)
+
+/* Types for Tree Package:  */
+
+/* Subscript of nodes table entry.  */
+typedef Int Node_Id;
+
+/* Used in semantics for Node_Id value referencing an entity.  */
+typedef Node_Id Entity_Id;
+
+/* Null node.  */
+#define Empty 0
+
+/* Error node.  */
+#define Error 1
+
+/* Subscript of first allocated node.  */
+#define First_Node_Id Empty
+
+/* Subscript of entry in lists table.  */
+typedef Int List_Id;
+
+/* Indicates absence of a list.  */
+#define No_List 0
+
+/* Error list. */
+#define Error_List List_Low_Bound
+
+/* Subscript of first allocated list header.  */
+#define First_List_Id Error_List
+
+/* Element list Id, subscript value of entry in lists table.  */
+typedef Int Elist_Id;
+
+/* Used to indicate absence of an element list.  */
+#define No_Elist Elist_Low_Bound
+
+/* Subscript of first allocated elist header */
+#define First_Elist_Id (No_Elist + 1)
+
+/* Element Id, subscript value of entry in elements table.  */
+typedef Int Elmt_Id;
+
+/* Used to indicate absence of a list element.  */
+#define No_Elmt Elmt_Low_Bound
+
+/* Subscript of first allocated element */
+#define First_Elmt_Id (No_Elmt + 1)
+
+/* Types for String_Table Package:  */
+
+/* Subscript of strings table entry.  */
+typedef Int String_Id;
+
+/* Used to indicate missing string Id.  */
+#define No_String Strings_Low_Bound
+
+/* Subscript of first entry in strings table.  */
+#define First_String_Id (No_String + 1)
+
+/* Types for Uint_Support Package:  */
+
+/* Type used for representation of universal integers.  */
+typedef Int Uint;
+
+/* Used to indicate missing Uint value.  */
+#define No_Uint Uint_Low_Bound
+
+/* Base value used to represent Uint values.  */
+#define Base 32768
+
+/* Minimum and maximum integers directly representable as Uint values */
+#define Min_Direct (-(Base - 1))
+#define Max_Direct ((Base - 1) * (Base - 1))
+
+#define Uint_Direct_Bias  (Uint_Low_Bound + Base)
+#define Uint_Direct_First (Uint_Direct_Bias + Min_Direct)
+#define Uint_Direct_Last  (Uint_Direct_Bias + Max_Direct)
+
+/* Define range of direct biased values */
+SUBTYPE (Uint_Direct, Uint, Uint_Direct_First, Uint_Direct_Last)
+
+/* Constants in Uint format.  */
+#define Uint_0  (Uint_Direct_Bias + 0)
+#define Uint_1  (Uint_Direct_Bias + 1)
+#define Uint_2  (Uint_Direct_Bias + 2)
+#define Uint_10 (Uint_Direct_Bias + 10)
+#define Uint_16 (Uint_Direct_Bias + 16)
+
+/* Types for Ureal_Support Package:  */
+
+/* Type used for representation of universal reals.  */
+typedef Int Ureal;
+
+/* Used to indicate missing Uint value.  */
+#define No_Ureal Ureal_Low_Bound
+
+/* Subscript of first entry in Ureal table.  */
+#define Ureal_First_Entry (No_Ureal + 1)
+
+/* Character Code Type:  */
+
+/* Character code value, intended to be 16 bits.  */
+typedef short Char_Code;
+
+/* Types Used for Library Management:  */
+
+/* Unit number.  */
+typedef Int Unit_Number_Type;
+
+/* Unit number value for main unit.  */
+#define Main_Unit 0
+
+/* Type used for lines table.  */
+typedef Source_Ptr *Lines_Table_Type;
+
+/* Type used for pointer to lines table.  */
+typedef Source_Ptr *Lines_Table_Ptr;
+
+/* Length of time stamp value.  */
+#define Time_Stamp_Length 22
+
+/* Type used to represent time stamp.  */
+typedef Char *Time_Stamp_Type;
+
+/* Name_Id synonym used for file names.  */
+typedef Name_Id File_Name_Type;
+
+/* Constant used to indicate no file found.  */
+#define No_File No_Name
+
+/* Name_Id synonym used for unit names.  */
+typedef Name_Id Unit_Name_Type;
+
+/* Definitions for mechanism type and values */
+typedef Int Mechanism_Type;
+#define Default            0
+#define By_Copy            (-1)
+#define By_Reference       (-2)
+#define By_Descriptor      (-3)
+#define By_Descriptor_UBS  (-4)
+#define By_Descriptor_UBSB (-5)
+#define By_Descriptor_UBA  (-6)
+#define By_Descriptor_S    (-7)
+#define By_Descriptor_SB   (-8)
+#define By_Descriptor_A    (-9)
+#define By_Descriptor_NCA  (-10)

gcc/ada/uintp.ads

@@ -0,0 +1,505 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                U I N T P                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.58 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Support for universal integer arithmetic
+
+--  WARNING: There is a C version of this package. Any changes to this
+--  source file must be properly reflected in the C header file sinfo.h
+
+with Alloc;
+with Table;
+with Types; use Types;
+
+package Uintp is
+
+   -------------------------------------------------
+   -- Basic Types and Constants for Uintp Package --
+   -------------------------------------------------
+
+   type Uint is private;
+   --  The basic universal integer type
+
+   No_Uint : constant Uint;
+   --  A constant value indicating a missing or unset Uint value
+
+   Uint_0   : constant Uint;
+   Uint_1   : constant Uint;
+   Uint_2   : constant Uint;
+   Uint_3   : constant Uint;
+   Uint_4   : constant Uint;
+   Uint_5   : constant Uint;
+   Uint_6   : constant Uint;
+   Uint_7   : constant Uint;
+   Uint_8   : constant Uint;
+   Uint_9   : constant Uint;
+   Uint_10  : constant Uint;
+   Uint_12  : constant Uint;
+   Uint_15  : constant Uint;
+   Uint_16  : constant Uint;
+   Uint_24  : constant Uint;
+   Uint_32  : constant Uint;
+   Uint_63  : constant Uint;
+   Uint_64  : constant Uint;
+   Uint_128 : constant Uint;
+
+   Uint_Minus_1   : constant Uint;
+   Uint_Minus_2   : constant Uint;
+   Uint_Minus_3   : constant Uint;
+   Uint_Minus_4   : constant Uint;
+   Uint_Minus_5   : constant Uint;
+   Uint_Minus_6   : constant Uint;
+   Uint_Minus_7   : constant Uint;
+   Uint_Minus_8   : constant Uint;
+   Uint_Minus_9   : constant Uint;
+   Uint_Minus_12  : constant Uint;
+   Uint_Minus_128 : constant Uint;
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Initialize;
+   --  Initialize Uint tables. Note that Initialize must not be called if
+   --  Tree_Read is used. Note also that there is no lock routine in this
+   --  unit, these are among the few tables that can be expanded during
+   --  gigi processing.
+
+   procedure Tree_Read;
+   --  Initializes internal tables from current tree file using Tree_Read.
+   --  Note that Initialize should not be called if Tree_Read is used.
+   --  Tree_Read includes all necessary initialization.
+
+   procedure Tree_Write;
+   --  Writes out internal tables to current tree file using Tree_Write.
+
+   function UI_Abs (Right : Uint) return Uint;
+   pragma Inline (UI_Abs);
+   --  Returns abs function of universal integer.
+
+   function UI_Add (Left : Uint; Right : Uint) return Uint;
+   function UI_Add (Left : Int;  Right : Uint) return Uint;
+   function UI_Add (Left : Uint; Right : Int)  return Uint;
+   --  Returns sum of two integer values.
+
+   function UI_Decimal_Digits_Hi (U : Uint) return Nat;
+   --  Returns an estimate of the number of decimal digits required to
+   --  represent the absolute value of U. This estimate is correct or high,
+   --  i.e. it never returns a value that is too low. The accuracy of the
+   --  estimate affects only the effectiveness of comparison optimizations
+   --  in Urealp.
+
+   function UI_Decimal_Digits_Lo (U : Uint) return Nat;
+   --  Returns an estimate of the number of decimal digits required to
+   --  represent the absolute value of U. This estimate is correct or low,
+   --  i.e. it never returns a value that is too high. The accuracy of the
+   --  estimate affects only the effectiveness of comparison optimizations
+   --  in Urealp.
+
+   function UI_Div (Left : Uint; Right : Uint) return Uint;
+   function UI_Div (Left : Int;  Right : Uint) return Uint;
+   function UI_Div (Left : Uint; Right : Int)  return Uint;
+   --  Returns quotient of two integer values. Fatal error if Right = 0
+
+   function UI_Eq (Left : Uint; Right : Uint) return Boolean;
+   function UI_Eq (Left : Int;  Right : Uint) return Boolean;
+   function UI_Eq (Left : Uint; Right : Int)  return Boolean;
+   pragma Inline (UI_Eq);
+   --  Compares integer values for equality.
+
+   function UI_Expon (Left : Uint; Right : Uint) return Uint;
+   function UI_Expon (Left : Int;  Right : Uint) return Uint;
+   function UI_Expon (Left : Uint; Right : Int)  return Uint;
+   function UI_Expon (Left : Int;  Right : Int)  return Uint;
+   --  Returns result of exponentiating two integer values
+   --  Fatal error if Right is negative.
+
+   function UI_GCD (Uin, Vin : Uint) return Uint;
+   --  Computes GCD of input values. Assumes Uin >= Vin >= 0.
+
+   function UI_Ge (Left : Uint; Right : Uint) return Boolean;
+   function UI_Ge (Left : Int;  Right : Uint) return Boolean;
+   function UI_Ge (Left : Uint; Right : Int)  return Boolean;
+   pragma Inline (UI_Ge);
+   --  Compares integer values for greater than or equal.
+
+   function UI_Gt (Left : Uint; Right : Uint) return Boolean;
+   function UI_Gt (Left : Int;  Right : Uint) return Boolean;
+   function UI_Gt (Left : Uint; Right : Int)  return Boolean;
+   pragma Inline (UI_Gt);
+   --  Compares integer values for greater than.
+
+   function UI_Is_In_Int_Range (Input : Uint) return Boolean;
+   pragma Inline (UI_Is_In_Int_Range);
+   --  Determines if universal integer is in Int range.
+
+   function UI_Le (Left : Uint; Right : Uint) return Boolean;
+   function UI_Le (Left : Int;  Right : Uint) return Boolean;
+   function UI_Le (Left : Uint; Right : Int)  return Boolean;
+   pragma Inline (UI_Le);
+   --  Compares integer values for less than or equal.
+
+   function UI_Lt (Left : Uint; Right : Uint) return Boolean;
+   function UI_Lt (Left : Int;  Right : Uint) return Boolean;
+   function UI_Lt (Left : Uint; Right : Int)  return Boolean;
+   --  Compares integer values for less than.
+
+   function UI_Max (Left : Uint; Right : Uint) return Uint;
+   function UI_Max (Left : Int;  Right : Uint) return Uint;
+   function UI_Max (Left : Uint; Right : Int)  return Uint;
+   --  Returns maximum of two integer values
+
+   function UI_Min (Left : Uint; Right : Uint) return Uint;
+   function UI_Min (Left : Int;  Right : Uint) return Uint;
+   function UI_Min (Left : Uint; Right : Int)  return Uint;
+   --  Returns minimum of two integer values.
+
+   function UI_Mod (Left : Uint; Right : Uint) return Uint;
+   function UI_Mod (Left : Int;  Right : Uint) return Uint;
+   function UI_Mod (Left : Uint; Right : Int)  return Uint;
+   pragma Inline (UI_Mod);
+   --  Returns mod function of two integer values.
+
+   function UI_Mul (Left : Uint; Right : Uint) return Uint;
+   function UI_Mul (Left : Int;  Right : Uint) return Uint;
+   function UI_Mul (Left : Uint; Right : Int)  return Uint;
+   --  Returns product of two integer values
+
+   function UI_Ne (Left : Uint; Right : Uint) return Boolean;
+   function UI_Ne (Left : Int;  Right : Uint) return Boolean;
+   function UI_Ne (Left : Uint; Right : Int)  return Boolean;
+   pragma Inline (UI_Ne);
+   --  Compares integer values for inequality.
+
+   function UI_Negate (Right : Uint) return Uint;
+   pragma Inline (UI_Negate);
+   --  Returns negative of universal integer.
+
+   function UI_Rem (Left : Uint; Right : Uint) return Uint;
+   function UI_Rem (Left : Int;  Right : Uint) return Uint;
+   function UI_Rem (Left : Uint; Right : Int)  return Uint;
+   --  Returns rem of two integer values.
+
+   function UI_Sub (Left : Uint; Right : Uint) return Uint;
+   function UI_Sub (Left : Int;  Right : Uint) return Uint;
+   function UI_Sub (Left : Uint; Right : Int)  return Uint;
+   pragma Inline (UI_Sub);
+   --  Returns difference of two integer values
+
+   function UI_From_Dint (Input : Dint) return Uint;
+   --  Converts Dint value to universal integer form.
+
+   function UI_From_Int (Input : Int) return Uint;
+   --  Converts Int value to universal integer form.
+
+   function UI_To_Int (Input : Uint) return Int;
+   --  Converts universal integer value to Int. Fatal error
+   --  if value is not in appropriate range.
+
+   function Num_Bits (Input : Uint) return Nat;
+   --  Approximate number of binary bits in given universal integer.
+   --  This function is used for capacity checks, and it can be one
+   --  bit off without affecting its usage.
+
+   ---------------------
+   -- Output Routines --
+   ---------------------
+
+   type UI_Format is (Hex, Decimal, Auto);
+   --  Used to determine whether UI_Image/UI_Write output is in hexadecimal
+   --  or decimal format. Auto, the default setting, lets the routine make
+   --  a decision based on the value.
+
+   UI_Image_Max    : constant := 32;
+   UI_Image_Buffer : String (1 .. UI_Image_Max);
+   UI_Image_Length : Natural;
+   --  Buffer used for UI_Image as described below
+
+   procedure UI_Image (Input : Uint; Format : UI_Format := Auto);
+   --  Places a representation of Uint, consisting of a possible minus sign,
+   --  followed by the value in UI_Image_Buffer. The form of the value is an
+   --  integer literal in either decimal (no base) or hexadecimal (base 16)
+   --  format. If Hex is True on entry, then hex mode is forced, otherwise
+   --  UI_Image makes a guess at which output format is more convenient. The
+   --  value must fit in UI_Image_Buffer. If necessary, the result is an
+   --  approximation of the proper value, using an exponential format. The
+   --  image of No_Uint is output as a single question mark.
+
+   procedure UI_Write (Input : Uint; Format : UI_Format := Auto);
+   --  Writes a representation of Uint, consisting of a possible minus sign,
+   --  followed by the value to the output file. The form of the value is an
+   --  integer literal in either decimal (no base) or hexadecimal (base 16)
+   --  format as appropriate. UI_Format shows which format to use. Auto,
+   --  the default, asks UI_Write to make a guess at which output format
+   --  will be more convenient to read.
+
+   procedure pid (Input : Uint);
+   --  Writes representation of Uint in decimal with a terminating line
+   --  return. This is intended for use from the debugger.
+
+   procedure pih (Input : Uint);
+   --  Writes representation of Uint in hex with a terminating line return.
+   --  This is intended for use from the debugger.
+
+   ------------------------
+   -- Operator Renamings --
+   ------------------------
+
+   function "+" (Left : Uint; Right : Uint) return Uint renames UI_Add;
+   function "+" (Left : Int;  Right : Uint) return Uint renames UI_Add;
+   function "+" (Left : Uint; Right : Int)  return Uint renames UI_Add;
+
+   function "/" (Left : Uint; Right : Uint) return Uint renames UI_Div;
+   function "/" (Left : Int;  Right : Uint) return Uint renames UI_Div;
+   function "/" (Left : Uint; Right : Int)  return Uint renames UI_Div;
+
+   function "*" (Left : Uint; Right : Uint) return Uint renames UI_Mul;
+   function "*" (Left : Int;  Right : Uint) return Uint renames UI_Mul;
+   function "*" (Left : Uint; Right : Int)  return Uint renames UI_Mul;
+
+   function "-" (Left : Uint; Right : Uint) return Uint renames UI_Sub;
+   function "-" (Left : Int;  Right : Uint) return Uint renames UI_Sub;
+   function "-" (Left : Uint; Right : Int)  return Uint renames UI_Sub;
+
+   function "**"  (Left : Uint; Right : Uint) return Uint renames UI_Expon;
+   function "**"  (Left : Uint; Right : Int)  return Uint renames UI_Expon;
+   function "**"  (Left : Int;  Right : Uint) return Uint renames UI_Expon;
+   function "**"  (Left : Int;  Right : Int)  return Uint renames UI_Expon;
+
+   function "abs" (Real : Uint) return Uint renames UI_Abs;
+
+   function "mod" (Left : Uint; Right : Uint) return Uint renames UI_Mod;
+   function "mod" (Left : Int;  Right : Uint) return Uint renames UI_Mod;
+   function "mod" (Left : Uint; Right : Int)  return Uint renames UI_Mod;
+
+   function "rem" (Left : Uint; Right : Uint) return Uint renames UI_Rem;
+   function "rem" (Left : Int;  Right : Uint) return Uint renames UI_Rem;
+   function "rem" (Left : Uint; Right : Int)  return Uint renames UI_Rem;
+
+   function "-"   (Real : Uint) return Uint renames UI_Negate;
+
+   function "="   (Left : Uint; Right : Uint) return Boolean renames UI_Eq;
+   function "="   (Left : Int;  Right : Uint) return Boolean renames UI_Eq;
+   function "="   (Left : Uint; Right : Int)  return Boolean renames UI_Eq;
+
+   function ">="  (Left : Uint; Right : Uint) return Boolean renames UI_Ge;
+   function ">="  (Left : Int;  Right : Uint) return Boolean renames UI_Ge;
+   function ">="  (Left : Uint; Right : Int)  return Boolean renames UI_Ge;
+
+   function ">"   (Left : Uint; Right : Uint) return Boolean renames UI_Gt;
+   function ">"   (Left : Int;  Right : Uint) return Boolean renames UI_Gt;
+   function ">"   (Left : Uint; Right : Int)  return Boolean renames UI_Gt;
+
+   function "<="  (Left : Uint; Right : Uint) return Boolean renames UI_Le;
+   function "<="  (Left : Int;  Right : Uint) return Boolean renames UI_Le;
+   function "<="  (Left : Uint; Right : Int)  return Boolean renames UI_Le;
+
+   function "<"   (Left : Uint; Right : Uint) return Boolean renames UI_Lt;
+   function "<"   (Left : Int;  Right : Uint) return Boolean renames UI_Lt;
+   function "<"   (Left : Uint; Right : Int)  return Boolean renames UI_Lt;
+
+   -----------------------------
+   -- Mark/Release Processing --
+   -----------------------------
+
+   --  The space used by Uint data is not automatically reclaimed. However,
+   --  a mark-release regime is implemented which allows storage to be
+   --  released back to a previously noted mark. This is used for example
+   --  when doing comparisons, where only intermediate results get stored
+   --  that do not need to be saved for future use.
+
+   type Save_Mark is private;
+
+   function Mark return Save_Mark;
+   --  Note mark point for future release
+
+   procedure Release (M : Save_Mark);
+   --  Release storage allocated since mark was noted
+
+   procedure Release_And_Save (M : Save_Mark; UI : in out Uint);
+   --  Like Release, except that the given Uint value (which is typically
+   --  among the data being released) is recopied after the release, so
+   --  that it is the most recent item, and UI is updated to point to
+   --  its copied location.
+
+   procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint);
+   --  Like Release, except that the given Uint values (which are typically
+   --  among the data being released) are recopied after the release, so
+   --  that they are the most recent items, and UI1 and UI2 are updated if
+   --  necessary to point to the copied locations. This routine is careful
+   --  to do things in the right order, so that the values do not clobber
+   --  one another.
+
+   -----------------------------------
+   -- Representation of Uint Values --
+   -----------------------------------
+
+private
+
+   type Uint is new Int range Uint_Low_Bound .. Uint_High_Bound;
+   for Uint'Size use 32;
+
+   No_Uint : constant Uint := Uint (Uint_Low_Bound);
+
+   --  Uint values are represented as multiple precision integers stored in
+   --  a multi-digit format using Base as the base. This value is chosen so
+   --  that the product Base*Base is within the range of allowed Int values.
+
+   --  Base is defined to allow efficient execution of the primitive
+   --  operations (a0, b0, c0) defined in the section "The Classical
+   --  Algorithms" (sec. 4.3.1) of Donald Knuth's "The Art of Computer
+   --  Programming", Vol. 2. These algorithms are used in this package.
+
+   Base_Bits : constant := 15;
+   --  Number of bits in base value
+
+   Base : constant Int := 2 ** Base_Bits;
+
+   --  Values in the range -(Base+1) .. maxdirect are encoded directly as
+   --  Uint values by adding a bias value. The value of maxdirect is chosen
+   --  so that a directly represented number always fits in two digits when
+   --  represented in base format.
+
+   Min_Direct : constant Int := -(Base - 1);
+   Max_Direct : constant Int := (Base - 1) * (Base - 1);
+
+   --  The following values define the bias used to store Uint values which
+   --  are in this range, as well as the biased values for the first and
+   --  last values in this range. We use a new derived type for these
+   --  constants to avoid accidental use of Uint arithmetic on these
+   --  values, which is never correct.
+
+   type Ctrl is range Int'First .. Int'Last;
+
+   Uint_Direct_Bias  : constant Ctrl := Ctrl (Uint_Low_Bound) + Ctrl (Base);
+   Uint_Direct_First : constant Ctrl := Uint_Direct_Bias + Ctrl (Min_Direct);
+   Uint_Direct_Last  : constant Ctrl := Uint_Direct_Bias + Ctrl (Max_Direct);
+
+   Uint_0   : constant Uint := Uint (Uint_Direct_Bias);
+   Uint_1   : constant Uint := Uint (Uint_Direct_Bias + 1);
+   Uint_2   : constant Uint := Uint (Uint_Direct_Bias + 2);
+   Uint_3   : constant Uint := Uint (Uint_Direct_Bias + 3);
+   Uint_4   : constant Uint := Uint (Uint_Direct_Bias + 4);
+   Uint_5   : constant Uint := Uint (Uint_Direct_Bias + 5);
+   Uint_6   : constant Uint := Uint (Uint_Direct_Bias + 6);
+   Uint_7   : constant Uint := Uint (Uint_Direct_Bias + 7);
+   Uint_8   : constant Uint := Uint (Uint_Direct_Bias + 8);
+   Uint_9   : constant Uint := Uint (Uint_Direct_Bias + 9);
+   Uint_10  : constant Uint := Uint (Uint_Direct_Bias + 10);
+   Uint_12  : constant Uint := Uint (Uint_Direct_Bias + 12);
+   Uint_15  : constant Uint := Uint (Uint_Direct_Bias + 15);
+   Uint_16  : constant Uint := Uint (Uint_Direct_Bias + 16);
+   Uint_24  : constant Uint := Uint (Uint_Direct_Bias + 24);
+   Uint_32  : constant Uint := Uint (Uint_Direct_Bias + 32);
+   Uint_63  : constant Uint := Uint (Uint_Direct_Bias + 63);
+   Uint_64  : constant Uint := Uint (Uint_Direct_Bias + 64);
+   Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128);
+
+   Uint_Minus_1   : constant Uint := Uint (Uint_Direct_Bias - 1);
+   Uint_Minus_2   : constant Uint := Uint (Uint_Direct_Bias - 2);
+   Uint_Minus_3   : constant Uint := Uint (Uint_Direct_Bias - 3);
+   Uint_Minus_4   : constant Uint := Uint (Uint_Direct_Bias - 4);
+   Uint_Minus_5   : constant Uint := Uint (Uint_Direct_Bias - 5);
+   Uint_Minus_6   : constant Uint := Uint (Uint_Direct_Bias - 6);
+   Uint_Minus_7   : constant Uint := Uint (Uint_Direct_Bias - 7);
+   Uint_Minus_8   : constant Uint := Uint (Uint_Direct_Bias - 8);
+   Uint_Minus_9   : constant Uint := Uint (Uint_Direct_Bias - 9);
+   Uint_Minus_12  : constant Uint := Uint (Uint_Direct_Bias - 12);
+   Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128);
+
+   type Save_Mark is record
+      Save_Uint   : Uint;
+      Save_Udigit : Int;
+   end record;
+
+   --  Values outside the range that is represented directly are stored
+   --  using two tables. The secondary table Udigits contains sequences of
+   --  Int values consisting of the digits of the number in a radix Base
+   --  system. The digits are stored from most significant to least
+   --  significant with the first digit only carrying the sign.
+
+   --  There is one entry in the primary Uints table for each distinct Uint
+   --  value. This table entry contains the length (number of digits) and
+   --  a starting offset of the value in the Udigits table.
+
+   Uint_First_Entry : constant Uint := Uint (Uint_Table_Start);
+
+   --  Some subprograms defined in this package manipulate the Udigits
+   --  table directly, while for others it is more convenient to work with
+   --  locally defined arrays of the digits of the Universal Integers.
+   --  The type UI_Vector is defined for this purpose and some internal
+   --  subprograms used for converting from one to the other are defined.
+
+   type UI_Vector is array (Pos range <>) of Int;
+   --  Vector containing the integer values of a Uint value
+
+   --  Note: An earlier version of this package used pointers of arrays
+   --  of Ints (dynamically allocated) for the Uint type. The change
+   --  leads to a few less natural idioms used throughout this code, but
+   --  eliminates all uses of the heap except for the table package itself.
+   --  For example, Uint parameters are often converted to UI_Vectors for
+   --  internal manipulation. This is done by creating the local UI_Vector
+   --  using the function N_Digits on the Uint to find the size needed for
+   --  the vector, and then calling Init_Operand to copy the values out
+   --  of the table into the vector.
+
+   type Uint_Entry is record
+      Length : Pos;
+      --  Length of entry in Udigits table in digits (i.e. in words)
+
+      Loc : Int;
+      --  Starting location in Udigits table of this Uint value
+   end record;
+
+   package Uints is new Table.Table (
+     Table_Component_Type => Uint_Entry,
+     Table_Index_Type     => Uint,
+     Table_Low_Bound      => Uint_First_Entry,
+     Table_Initial        => Alloc.Uints_Initial,
+     Table_Increment      => Alloc.Uints_Increment,
+     Table_Name           => "Uints");
+
+   package Udigits is new Table.Table (
+     Table_Component_Type => Int,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.Udigits_Initial,
+     Table_Increment      => Alloc.Udigits_Increment,
+     Table_Name           => "Udigits");
+
+   --  Note: the reason these tables are defined here in the private part of
+   --  the spec, rather than in the body, is that they are refrerenced
+   --  directly by gigi.
+
+end Uintp;

gcc/ada/uintp.h

@@ -0,0 +1,75 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                U I N T P                                 *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *          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.                                                      *
+ *                                                                          *
+ * 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). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file corresponds to the Ada package specification Uintp. It was
+   created manually from the files uintp.ads and uintp.adb  */
+
+/* Support for universal integer arithmetic */
+
+struct Uint_Entry
+{
+  Pos Length;
+  Int Loc;
+};
+
+/* See if a Uint is within the range of an integer.  */
+#define UI_Is_In_Int_Range  uintp__ui_is_in_int_range
+extern Boolean UI_Is_In_Int_Range	PARAMS((Uint));
+
+/* Obtain Int value from Uint input. This will abort if the result is
+   out of range.  */
+#define UI_To_Int uintp__ui_to_int
+extern Int UI_To_Int			PARAMS((Uint));
+
+/* Convert an Int into a Uint.  */
+#define UI_From_Int uintp__ui_from_int
+extern Uint UI_From_Int			PARAMS((int));
+
+/* Similarly, but return a GCC INTEGER_CST.  Overflow is tested by the
+   constant-folding used to build the node.  TYPE is the GCC type of the
+   resulting node.  */
+extern tree UI_To_gnu			PARAMS((Uint, tree));
+
+/* Universal integers are represented by the Uint type which is an index into
+   the Uints_Ptr table containing Uint_Entry values.  A Uint_Entry contains an
+   index and length for getting the "digits" of the universal integer from the
+   Udigits_Ptr table.
+
+   For efficiency, this method is used only for integer values larger than the
+   constant Uint_Bias.  If a Uint is less than this constant, then it contains
+   the integer value itself.  The origin of the Uints_Ptr table is adjusted so
+   that a Uint value of Uint_Bias indexes the first element.  */
+
+#define Uints_Ptr (uintp__uints__table - Uint_Table_Start)
+extern struct Uint_Entry *uintp__uints__table;
+
+#define Udigits_Ptr uintp__udigits__table
+extern int *uintp__udigits__table;
+
+#define Uint_0 (Uint_Direct_Bias + 0)
+#define Uint_1 (Uint_Direct_Bias + 1)

gcc/ada/uname.adb

@@ -0,0 +1,653 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                U N A M E                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.56 $
+--                                                                          --
+--          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 Atree;    use Atree;
+with Casing;   use Casing;
+with Einfo;    use Einfo;
+with Hostparm;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Output;   use Output;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+
+package body Uname is
+
+   -------------------
+   -- Get_Body_Name --
+   -------------------
+
+   function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
+   begin
+      Get_Name_String (N);
+
+      pragma Assert (Name_Len > 2
+                       and then Name_Buffer (Name_Len - 1) = '%'
+                       and then Name_Buffer (Name_Len) = 's');
+
+      Name_Buffer (Name_Len) := 'b';
+      return Name_Find;
+   end Get_Body_Name;
+
+   -----------------------------------
+   -- Get_External_Unit_Name_String --
+   -----------------------------------
+
+   procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
+      Pcount : Natural;
+      Newlen : Natural;
+
+   begin
+      --  Get unit name and eliminate trailing %s or %b
+
+      Get_Name_String (N);
+      Name_Len := Name_Len - 2;
+
+      --  Find number of components
+
+      Pcount := 0;
+      for J in 1 .. Name_Len loop
+         if Name_Buffer (J) = '.' then
+            Pcount := Pcount + 1;
+         end if;
+      end loop;
+
+      --  If simple name, nothing to do
+
+      if Pcount = 0 then
+         return;
+      end if;
+
+      --  If name has multiple components, replace dots by double underscore
+
+      Newlen := Name_Len + Pcount;
+
+      for J in reverse 1 .. Name_Len loop
+         if Name_Buffer (J) = '.' then
+            Name_Buffer (Newlen) := '_';
+            Name_Buffer (Newlen - 1) := '_';
+            Newlen := Newlen - 2;
+
+         else
+            Name_Buffer (Newlen) := Name_Buffer (J);
+            Newlen := Newlen - 1;
+         end if;
+      end loop;
+
+      Name_Len := Name_Len + Pcount;
+   end Get_External_Unit_Name_String;
+
+   --------------------------
+   -- Get_Parent_Body_Name --
+   --------------------------
+
+   function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
+   begin
+      Get_Name_String (N);
+
+      while Name_Buffer (Name_Len) /= '.' loop
+         pragma Assert (Name_Len > 1); -- not a child or subunit name
+         Name_Len := Name_Len - 1;
+      end loop;
+
+      Name_Buffer (Name_Len) := '%';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := 'b';
+      return Name_Find;
+
+   end Get_Parent_Body_Name;
+
+   --------------------------
+   -- Get_Parent_Spec_Name --
+   --------------------------
+
+   function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
+   begin
+      Get_Name_String (N);
+
+      while Name_Buffer (Name_Len) /= '.' loop
+         if Name_Len = 1 then
+            return No_Name; -- not a child or subunit name
+         else
+            Name_Len := Name_Len - 1;
+         end if;
+      end loop;
+
+      Name_Buffer (Name_Len) := '%';
+      Name_Len := Name_Len + 1;
+      Name_Buffer (Name_Len) := 's';
+      return Name_Find;
+
+   end Get_Parent_Spec_Name;
+
+   -------------------
+   -- Get_Spec_Name --
+   -------------------
+
+   function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
+   begin
+      Get_Name_String (N);
+
+      pragma Assert (Name_Len > 2
+                       and then Name_Buffer (Name_Len - 1) = '%'
+                       and then Name_Buffer (Name_Len) = 'b');
+
+      Name_Buffer (Name_Len) := 's';
+      return Name_Find;
+   end Get_Spec_Name;
+
+   -------------------
+   -- Get_Unit_Name --
+   -------------------
+
+   function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
+
+      Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
+      --  Buffer used to build name of unit. Note that we cannot use the
+      --  Name_Buffer in package Name_Table because we use it to read
+      --  component names.
+
+      Unit_Name_Length : Natural := 0;
+      --  Length of name stored in Unit_Name_Buffer
+
+      Node : Node_Id;
+      --  Program unit node
+
+      procedure Add_Char (C : Character);
+      --  Add a single character to stored unit name
+
+      procedure Add_Name (Name : Name_Id);
+      --  Add the characters of a names table entry to stored unit name
+
+      procedure Add_Node_Name (Node : Node_Id);
+      --  Recursive procedure adds characters associated with Node
+
+      function Get_Parent (Node : Node_Id) return Node_Id;
+      --  Get parent compilation unit of a stub
+
+      --------------
+      -- Add_Char --
+      --------------
+
+      procedure Add_Char (C : Character) is
+      begin
+         --  Should really check for max length exceeded here???
+         Unit_Name_Length := Unit_Name_Length + 1;
+         Unit_Name_Buffer (Unit_Name_Length) := C;
+      end Add_Char;
+
+      --------------
+      -- Add_Name --
+      --------------
+
+      procedure Add_Name (Name : Name_Id) is
+      begin
+         Get_Name_String (Name);
+
+         for J in 1 .. Name_Len loop
+            Add_Char (Name_Buffer (J));
+         end loop;
+      end Add_Name;
+
+      -------------------
+      -- Add_Node_Name --
+      -------------------
+
+      procedure Add_Node_Name (Node : Node_Id) is
+         Kind : Node_Kind := Nkind (Node);
+
+      begin
+         --  Just ignore an error node (someone else will give a message)
+
+         if Node = Error then
+            return;
+
+         --  Otherwise see what kind of node we have
+
+         else
+            case Kind is
+
+               when N_Identifier                      |
+                    N_Defining_Identifier             |
+                    N_Defining_Operator_Symbol        =>
+
+                  --  Note: it is of course an error to have a defining
+                  --  operator symbol at this point, but this is not where
+                  --  the error is signalled, so we handle it nicely here!
+
+                  Add_Name (Chars (Node));
+
+               when N_Defining_Program_Unit_Name      =>
+                  Add_Node_Name (Name (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Defining_Identifier (Node));
+
+               when N_Selected_Component              |
+                    N_Expanded_Name                   =>
+                  Add_Node_Name (Prefix (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Selector_Name (Node));
+
+               when N_Subprogram_Specification        |
+                    N_Package_Specification           =>
+                  Add_Node_Name (Defining_Unit_Name (Node));
+
+               when N_Subprogram_Body                 |
+                    N_Subprogram_Declaration          |
+                    N_Package_Declaration             |
+                    N_Generic_Declaration             =>
+                  Add_Node_Name (Specification (Node));
+
+               when N_Generic_Instantiation           =>
+                  Add_Node_Name (Defining_Unit_Name (Node));
+
+               when N_Package_Body                    =>
+                  Add_Node_Name (Defining_Unit_Name (Node));
+
+               when N_Task_Body                       |
+                    N_Protected_Body                  =>
+                  Add_Node_Name (Defining_Identifier (Node));
+
+               when N_Package_Renaming_Declaration    =>
+                  Add_Node_Name (Defining_Unit_Name (Node));
+
+               when N_Subprogram_Renaming_Declaration =>
+                  Add_Node_Name (Specification (Node));
+
+               when N_Generic_Renaming_Declaration   =>
+                  Add_Node_Name (Defining_Unit_Name (Node));
+
+               when N_Subprogram_Body_Stub            =>
+                  Add_Node_Name (Get_Parent (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Specification (Node));
+
+               when N_Compilation_Unit                =>
+                  Add_Node_Name (Unit (Node));
+
+               when N_Package_Body_Stub               =>
+                  Add_Node_Name (Get_Parent (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Defining_Identifier (Node));
+
+               when N_Task_Body_Stub                  |
+                    N_Protected_Body_Stub             =>
+                  Add_Node_Name (Get_Parent (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Defining_Identifier (Node));
+
+               when N_Subunit                         =>
+                  Add_Node_Name (Name (Node));
+                  Add_Char ('.');
+                  Add_Node_Name (Proper_Body (Node));
+
+               when N_With_Clause                     =>
+                  Add_Node_Name (Name (Node));
+
+               when N_Pragma                          =>
+                  Add_Node_Name (Expression (First
+                    (Pragma_Argument_Associations (Node))));
+
+               --  Tasks and protected stuff appear only in an error context,
+               --  but the error has been posted elsewhere, so we deal nicely
+               --  with these error situations here, and produce a reasonable
+               --  unit name using the defining identifier.
+
+               when N_Task_Type_Declaration           |
+                    N_Single_Task_Declaration         |
+                    N_Protected_Type_Declaration      |
+                    N_Single_Protected_Declaration    =>
+                  Add_Node_Name (Defining_Identifier (Node));
+
+               when others =>
+                  raise Program_Error;
+
+            end case;
+         end if;
+      end Add_Node_Name;
+
+      ----------------
+      -- Get_Parent --
+      ----------------
+
+      function Get_Parent (Node : Node_Id) return Node_Id is
+         N : Node_Id := Node;
+
+      begin
+         while Nkind (N) /= N_Compilation_Unit loop
+            N := Parent (N);
+         end loop;
+
+         return N;
+      end Get_Parent;
+
+   --------------------------------------------
+   --  Start of Processing for Get_Unit_Name --
+   --------------------------------------------
+
+   begin
+      Node := N;
+
+      --  If we have Defining_Identifier, find the associated unit node
+
+      if Nkind (Node) = N_Defining_Identifier then
+         Node := Declaration_Node (Node);
+
+      --  If an expanded name, it is an already analyzed child unit, find
+      --  unit node.
+
+      elsif Nkind (Node) = N_Expanded_Name then
+         Node := Declaration_Node (Entity (Node));
+      end if;
+
+      if Nkind (Node) = N_Package_Specification
+        or else Nkind (Node) in N_Subprogram_Specification
+      then
+         Node := Parent (Node);
+      end if;
+
+      --  Node points to the unit, so get its name and add proper suffix
+
+      Add_Node_Name (Node);
+      Add_Char ('%');
+
+      case Nkind (Node) is
+         when N_Generic_Declaration             |
+              N_Subprogram_Declaration          |
+              N_Package_Declaration             |
+              N_With_Clause                     |
+              N_Pragma                          |
+              N_Generic_Instantiation           |
+              N_Package_Renaming_Declaration    |
+              N_Subprogram_Renaming_Declaration |
+              N_Generic_Renaming_Declaration    |
+              N_Single_Task_Declaration         |
+              N_Single_Protected_Declaration    |
+              N_Task_Type_Declaration           |
+              N_Protected_Type_Declaration      =>
+
+            Add_Char ('s');
+
+         when N_Subprogram_Body                 |
+              N_Package_Body                    |
+              N_Subunit                         |
+              N_Body_Stub                       |
+              N_Task_Body                       |
+              N_Protected_Body                  |
+              N_Identifier                      |
+              N_Selected_Component              =>
+
+            Add_Char ('b');
+
+         when others =>
+            raise Program_Error;
+      end case;
+
+      Name_Buffer (1 .. Unit_Name_Length) :=
+        Unit_Name_Buffer (1 .. Unit_Name_Length);
+      Name_Len := Unit_Name_Length;
+      return Name_Find;
+
+   end Get_Unit_Name;
+
+   --------------------------
+   -- Get_Unit_Name_String --
+   --------------------------
+
+   procedure Get_Unit_Name_String (N : Unit_Name_Type) is
+      Unit_Is_Body : Boolean;
+
+   begin
+      Get_Decoded_Name_String (N);
+      Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
+      Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
+
+      --  A special fudge, normally we don't have operator symbols present,
+      --  since it is always an error to do so. However, if we do, at this
+      --  stage it has the form:
+
+      --    "and"
+
+      --  and the %s or %b has already been eliminated so put 2 chars back
+
+      if Name_Buffer (1) = '"' then
+         Name_Len := Name_Len + 2;
+      end if;
+
+      --  Now adjust the %s or %b to (spec) or (body)
+
+      if Unit_Is_Body then
+         Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
+      else
+         Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
+      end if;
+
+      for J in 1 .. Name_Len loop
+         if Name_Buffer (J) = '-' then
+            Name_Buffer (J) := '.';
+         end if;
+      end loop;
+
+      Name_Len := Name_Len + (7 - 2);
+   end Get_Unit_Name_String;
+
+   ------------------
+   -- Is_Body_Name --
+   ------------------
+
+   function Is_Body_Name (N : Unit_Name_Type) return Boolean is
+   begin
+      Get_Name_String (N);
+      return Name_Len > 2
+        and then Name_Buffer (Name_Len - 1) = '%'
+        and then Name_Buffer (Name_Len) = 'b';
+   end Is_Body_Name;
+
+   -------------------
+   -- Is_Child_Name --
+   -------------------
+
+   function Is_Child_Name (N : Unit_Name_Type) return Boolean is
+      J : Natural;
+
+   begin
+      Get_Name_String (N);
+      J := Name_Len;
+
+      while Name_Buffer (J) /= '.' loop
+         if J = 1 then
+            return False; -- not a child or subunit name
+         else
+            J := J - 1;
+         end if;
+      end loop;
+
+      return True;
+   end Is_Child_Name;
+
+   ------------------
+   -- Is_Spec_Name --
+   ------------------
+
+   function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
+   begin
+      Get_Name_String (N);
+      return Name_Len > 2
+        and then Name_Buffer (Name_Len - 1) = '%'
+        and then Name_Buffer (Name_Len) = 's';
+   end Is_Spec_Name;
+
+   -----------------------
+   -- Name_To_Unit_Name --
+   -----------------------
+
+   function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
+   begin
+      Get_Name_String (N);
+      Name_Buffer (Name_Len + 1) := '%';
+      Name_Buffer (Name_Len + 2) := 's';
+      Name_Len := Name_Len + 2;
+      return Name_Find;
+   end Name_To_Unit_Name;
+
+   ---------------
+   -- New_Child --
+   ---------------
+
+   function New_Child
+     (Old  : Unit_Name_Type;
+      Newp : Unit_Name_Type)
+      return Unit_Name_Type
+   is
+      P : Natural;
+
+   begin
+      Get_Name_String (Old);
+
+      declare
+         Child : String := Name_Buffer (1 .. Name_Len);
+
+      begin
+         Get_Name_String (Newp);
+         Name_Len := Name_Len - 2;
+
+         P := Child'Last;
+         while Child (P) /= '.' loop
+            P := P - 1;
+         end loop;
+
+         while P <= Child'Last loop
+            Name_Len := Name_Len + 1;
+            Name_Buffer (Name_Len) := Child (P);
+            P := P + 1;
+         end loop;
+
+         return Name_Find;
+      end;
+   end New_Child;
+
+   --------------
+   -- Uname_Ge --
+   --------------
+
+   function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
+   begin
+      return Left = Right or else Uname_Gt (Left, Right);
+   end Uname_Ge;
+
+   --------------
+   -- Uname_Gt --
+   --------------
+
+   function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
+   begin
+      return Left /= Right and then not Uname_Lt (Left, Right);
+   end Uname_Gt;
+
+   --------------
+   -- Uname_Le --
+   --------------
+
+   function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
+   begin
+      return Left = Right or else Uname_Lt (Left, Right);
+   end Uname_Le;
+
+   --------------
+   -- Uname_Lt --
+   --------------
+
+   function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
+      Left_Name    : String (1 .. Hostparm.Max_Name_Length);
+      Left_Length  : Natural;
+      Right_Name   : String renames Name_Buffer;
+      Right_Length : Natural renames Name_Len;
+      J            : Natural;
+
+   begin
+      pragma Warnings (Off, Right_Length);
+      --  Suppress warnings on Right_Length, used in pragma Assert
+
+      if Left = Right then
+         return False;
+      end if;
+
+      Get_Name_String (Left);
+      Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
+      Left_Length := Name_Len;
+      Get_Name_String (Right);
+      J := 1;
+
+      loop
+         exit when Left_Name (J) = '%';
+
+         if Right_Name (J) = '%' then
+            return False; -- left name is longer
+         end if;
+
+         pragma Assert (J <= Left_Length and then J <= Right_Length);
+
+         if Left_Name (J) /= Right_Name (J) then
+            return Left_Name (J) < Right_Name (J); -- parent names different
+         end if;
+
+         J := J + 1;
+      end loop;
+
+      --  Come here pointing to % in left name
+
+      if Right_Name (J) /= '%' then
+         return True; -- right name is longer
+      end if;
+
+      --  Here the parent names are the same and specs sort low. If neither is
+      --  a spec, then we are comparing the same name and we want a result of
+      --  False in any case.
+
+      return Left_Name (J + 1) = 's';
+   end Uname_Lt;
+
+   ---------------------
+   -- Write_Unit_Name --
+   ---------------------
+
+   procedure Write_Unit_Name (N : Unit_Name_Type) is
+   begin
+      Get_Unit_Name_String (N);
+      Write_Str (Name_Buffer (1 .. Name_Len));
+   end Write_Unit_Name;
+
+end Uname;

gcc/ada/uname.ads

@@ -0,0 +1,176 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                U N A M E                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.23 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1998, 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 Types; use Types;
+package Uname is
+
+   ---------------------------
+   -- Unit Name Conventions --
+   ---------------------------
+
+   --  Units are associated with a unique ASCII name as follows. First we
+   --  have the fully expanded name of the unit, with lower case letters
+   --  (except for the use of upper case letters for encoding upper half
+   --  and wide characters, as described in Namet), and periods. Following
+   --  this is one of the following suffixes:
+
+   --    %s  for package/subprogram/generic declarations (specs)
+   --    %b  for package/subprogram/generic bodies and subunits
+
+   --  Unit names are stored in the names table, and referred to by the
+   --  corresponding Name_Id values. The subtype Unit_Name, which is a
+   --  synonym for Name_Id, is used to indicate that a Name_Id value that
+   --  holds a unit name (as defined above) is expected.
+
+   --  Note: as far as possible the conventions for unit names are encapsulated
+   --  in this package. The one exception is that package Fname, which provides
+   --  conversion routines from unit names to file names must be aware of the
+   --  precise conventions that are used.
+
+   -------------------
+   -- Display Names --
+   -------------------
+
+   --  For display purposes, unit names are printed out with the suffix
+   --  " (body)" for a body and " (spec)" for a spec. These formats are
+   --  used for the Write_Unit_Name and Get_Unit_Name_String subprograms.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type;
+   --  Given the name of a spec, this function returns the name of the
+   --  corresponding body, i.e. characters %s replaced by %b
+
+   function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type;
+   --  Given the name of a subunit, returns the name of the parent body.
+
+   function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type;
+   --  Given the name of a child unit spec or body, returns the unit name
+   --  of the parent spec. Returns No_Name if the given name is not the name
+   --  of a child unit.
+
+   procedure Get_External_Unit_Name_String (N : Unit_Name_Type);
+   --  Given the name of a body or spec unit, this procedure places in
+   --  Name_Buffer the name of the unit with periods replaced by double
+   --  underscores. The spec/body indication is eliminated. The length
+   --  of the stored name is placed in Name_Len. All letters are lower
+   --  case, corresponding to the string used in external names.
+
+   function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type;
+   --  Given the name of a body, this function returns the name of the
+   --  corresponding spec, i.e. characters %b replaced by %s
+
+   function Get_Unit_Name (N : Node_Id) return Unit_Name_Type;
+   --  This procedure returns the unit name that corresponds to the given node,
+   --  which is one of the following:
+   --
+   --    N_Subprogram_Declaration         (spec) cases
+   --    N_Package_Declaration
+   --    N_Generic_Declaration
+   --    N_With_Clause
+   --    N_Function_Instantiation
+   --    N_Package_Instantiation
+   --    N_Procedure_Instantiation
+   --    N_Pragma (Elaborate case)
+   --
+   --    N_Package_Body                   (body) cases
+   --    N_Subprogram_Body
+   --    N_Identifier
+   --    N_Selected_Component
+   --
+   --    N_Subprogram_Body_Stub           (subunit) cases
+   --    N_Package_Body_Stub
+   --    N_Task_Body_Stub
+   --    N_Protected_Body_Stub
+   --    N_Subunit
+
+   procedure Get_Unit_Name_String (N : Unit_Name_Type);
+   --  Places the display name of the unit in Name_Buffer and sets Name_Len
+   --  to the length of the stored name, i.e. it uses the same interface as
+   --  the Get_Name_String routine in the Namet package. The name contains
+   --  an indication of spec or body, and is decoded.
+
+   function Is_Body_Name (N : Unit_Name_Type) return Boolean;
+   --  Returns True iff the given name is the unit name of a body (i.e. if
+   --  it ends with the characters %b).
+
+   function Is_Child_Name (N : Unit_Name_Type) return Boolean;
+   --  Returns True iff the given name is a child unit name (of either a
+   --  body or a spec).
+
+   function Is_Spec_Name (N : Unit_Name_Type) return Boolean;
+   --  Returns True iff the given name is the unit name of a specification
+   --  (i.e. if it ends with the characters %s).
+
+   function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type;
+   --  Given the Id of the Ada name of a unit, this function returns the
+   --  corresponding unit name of the spec (by appending %s to the name).
+
+   function New_Child
+     (Old  : Unit_Name_Type;
+      Newp : Unit_Name_Type)
+      return Unit_Name_Type;
+   --   Old is a child unit name (for either a body or spec). Newp is the
+   --   unit name of the actual parent (this may be different from the
+   --   parent in old). The returned unit name is formed by taking the
+   --   parent name from Newp and the child unit name from Old, with the
+   --   result being a body or spec depending on Old. For example:
+   --
+   --     Old    = A.B.C (body)
+   --     Newp   = A.R (spec)
+   --     result = A.R.C (body)
+   --
+   --   See spec of Load_Unit for extensive discussion of why this routine
+   --   needs to be used (the call in the body of Load_Unit is the only one).
+
+   function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean;
+   function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean;
+   function Uname_Le (Left, Right : Unit_Name_Type) return Boolean;
+   function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean;
+   --  These functions perform lexicographic ordering of unit names. The
+   --  ordering is suitable for printing, and is not quite a straightforward
+   --  comparison of the names, since the convention is that specs appear
+   --  before bodies. Note that the standard = and /= operators work fine
+   --  because all unit names are hashed into the name table, so if two names
+   --  are the same, they always have the same Name_Id value.
+
+   procedure Write_Unit_Name (N : Unit_Name_Type);
+   --  Given a unit name, this procedure writes the display name to the
+   --  standard output file. Name_Buffer and Name_Len are set as described
+   --  above for the Get_Unit_Name_String call on return.
+
+end Uname;

gcc/ada/unchconv.ads

@@ -0,0 +1,24 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                  U N C H E C K E D _ C O N V E R S I O N                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.15 $                             --
+--                                                                          --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+generic
+   type Source (<>) is limited private;
+   type Target (<>) is limited private;
+
+function Unchecked_Conversion (S : Source) return Target;
+pragma Import (Intrinsic, Unchecked_Conversion);
+pragma Pure (Unchecked_Conversion);

gcc/ada/unchdeal.ads

@@ -0,0 +1,23 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--               U N C H E C K E D _ D E A L L O C A T I O N                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.15 $                             --
+--                                                                          --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+generic
+   type Object (<>) is limited private;
+   type Name is access Object;
+
+procedure Unchecked_Deallocation (X : in out Name);
+pragma Import (Intrinsic, Unchecked_Deallocation);

gcc/ada/urealp.ads

@@ -0,0 +1,355 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               U R E A L P                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                             $Revision: 1.35 $                            --
+--                                                                          --
+--          Copyright (C) 1992-1998 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Support for universal real arithmetic
+
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Urealp is
+
+   ---------------------------------------
+   -- Representation of Universal Reals --
+   ---------------------------------------
+
+   --  A universal real value is represented by a single value (which is
+   --  an index into an internal table). These values are not hashed, so
+   --  the equality operator should not be used on Ureal values (instead
+   --  use the UR_Eq function).
+
+   --  A Ureal value represents an arbitrary precision universal real value,
+   --  stored internally using four components
+
+   --    the numerator (Uint, always non-negative)
+   --    the denominator (Uint, always non-zero, always positive if base = 0)
+   --    a real base (Nat, either zero, or in the range 2 .. 16)
+   --    a sign flag (Boolean), set if negative
+
+   --  If the base is zero, then the absolute value of the Ureal is simply
+   --  numerator/denominator. If the base is non-zero, then the absolute
+   --  value is num / (rbase ** den).
+
+   --  Negative numbers are represented by the sign of the numerator being
+   --  negative. The denominator is always positive.
+
+   --  A normalized Ureal value has base = 0, and numerator/denominator
+   --  reduced to lowest terms, with zero itself being represented as 0/1.
+   --  This is a canonical format, so that for normalized Ureal values it
+   --  is the case that two equal values always have the same denominator
+   --  and numerator values.
+
+   --  Note: a value of minus zero is legitimate, and the operations in
+   --  Urealp preserve the handling of signed zeroes in accordance with
+   --  the rules of IEEE P754 ("IEEE floating point").
+
+   ------------------------------
+   -- Types for Urealp Package --
+   ------------------------------
+
+   type Ureal is private;
+   --  Type used for representation of universal reals
+
+   No_Ureal : constant Ureal;
+   --  Constant used to indicate missing or unset Ureal value
+
+   ---------------------
+   -- Ureal Constants --
+   ---------------------
+
+   function Ureal_0 return Ureal;
+   --  Returns value 0.0
+
+   function Ureal_M_0 return Ureal;
+   --  Returns value -0.0
+
+   function Ureal_Tenth return Ureal;
+   --  Returns value 0.1
+
+   function Ureal_Half return Ureal;
+   --  Returns value 0.5
+
+   function Ureal_1 return Ureal;
+   --  Returns value 1.0
+
+   function Ureal_2 return Ureal;
+   --  Returns value 2.0
+
+   function Ureal_10 return Ureal;
+   --  Returns value 10.0
+
+   function Ureal_100 return Ureal;
+   --  Returns value 100.0
+
+   function Ureal_2_128 return Ureal;
+   --  Returns value 2.0 ** 128
+
+   function Ureal_2_M_128 return Ureal;
+   --  Returns value 2.0 ** (-128)
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Initialize;
+   --  Initialize Ureal tables. Note that Initialize must not be called if
+   --  Tree_Read is used. Note also that there is no Lock routine in this
+   --  unit. These tables are among the few tables that can be expanded
+   --  during Gigi processing.
+
+   procedure Tree_Read;
+   --  Initializes internal tables from current tree file using Tree_Read.
+   --  Note that Initialize should not be called if Tree_Read is used.
+   --  Tree_Read includes all necessary initialization.
+
+   procedure Tree_Write;
+   --  Writes out internal tables to current tree file using Tree_Write
+
+   function Rbase (Real : Ureal) return Nat;
+   --  Return the base of the universal real.
+
+   function Denominator (Real : Ureal) return Uint;
+   --  Return the denominator of the universal real.
+
+   function Numerator (Real : Ureal) return Uint;
+   --  Return the numerator of the universal real.
+
+   function Norm_Den (Real : Ureal) return Uint;
+   --  Return the denominator of the universal real after a normalization.
+
+   function Norm_Num (Real : Ureal) return Uint;
+   --  Return the numerator of the universal real after a normalization.
+
+   function UR_From_Uint (UI : Uint) return Ureal;
+   --  Returns real corresponding to universal integer value
+
+   function UR_To_Uint (Real : Ureal) return Uint;
+   --  Return integer value obtained by accurate rounding of real value.
+   --  The rounding of values half way between two integers is away from
+   --  zero, as required by normal Ada 95 rounding semantics.
+
+   function UR_Trunc (Real : Ureal) return Uint;
+   --  Return integer value obtained by a truncation of real towards zero
+
+   function UR_Ceiling (Real : Ureal) return Uint;
+   --  Return value of smallest integer not less than the given value
+
+   function UR_Floor (Real : Ureal) return Uint;
+   --  Return value of smallest integer not greater than the given value
+
+   --  Conversion table for above four functions
+
+   --    Input    To_Uint    Trunc    Ceiling    Floor
+   --     1.0        1         1         1         1
+   --     1.2        1         1         2         1
+   --     1.5        2         1         2         1
+   --     1.7        2         1         2         1
+   --     2.0        2         2         2         2
+   --    -1.0       -1        -1        -1        -1
+   --    -1.2       -1        -1        -1        -2
+   --    -1.5       -2        -1        -1        -2
+   --    -1.7       -2        -1        -1        -2
+   --    -2.0       -2        -2        -2        -2
+
+   function UR_From_Components
+     (Num      : Uint;
+      Den      : Uint;
+      Rbase    : Nat := 0;
+      Negative : Boolean := False)
+      return     Ureal;
+   --  Builds real value from given numerator, denominator and base. The
+   --  value is negative if Negative is set to true, and otherwise is
+   --  non-negative.
+
+   function UR_Add (Left : Ureal; Right : Ureal) return Ureal;
+   function UR_Add (Left : Ureal; Right : Uint)  return Ureal;
+   function UR_Add (Left : Uint;  Right : Ureal) return Ureal;
+   --  Returns real sum of operands
+
+   function UR_Div (Left : Ureal; Right : Ureal) return Ureal;
+   function UR_Div (Left : Uint;  Right : Ureal) return Ureal;
+   function UR_Div (Left : Ureal; Right : Uint)  return Ureal;
+   --  Returns real quotient of operands. Fatal error if Right is zero
+
+   function UR_Mul (Left : Ureal; Right : Ureal) return Ureal;
+   function UR_Mul (Left : Uint;  Right : Ureal) return Ureal;
+   function UR_Mul (Left : Ureal; Right : Uint)  return Ureal;
+   --  Returns real product of operands
+
+   function UR_Sub (Left : Ureal; Right : Ureal) return Ureal;
+   function UR_Sub (Left : Uint;  Right : Ureal) return Ureal;
+   function UR_Sub (Left : Ureal; Right : Uint)  return Ureal;
+   --  Returns real difference of operands
+
+   function UR_Exponentiate (Real  : Ureal; N : Uint) return  Ureal;
+   --  Returns result of raising Ureal to Uint power.
+   --  Fatal error if Left is 0 and Right is negative.
+
+   function UR_Abs (Real : Ureal) return Ureal;
+   --  Returns abs function of real
+
+   function UR_Negate (Real : Ureal) return Ureal;
+   --  Returns negative of real
+
+   function UR_Eq (Left, Right : Ureal) return Boolean;
+   --  Compares reals for equality.
+
+   function UR_Max (Left, Right : Ureal) return Ureal;
+   --  Returns the maximum of two reals
+
+   function UR_Min (Left, Right : Ureal) return Ureal;
+   --  Returns the minimum of two reals
+
+   function UR_Ne (Left, Right : Ureal) return Boolean;
+   --  Compares reals for inequality.
+
+   function UR_Lt (Left, Right : Ureal) return Boolean;
+   --  Compares reals for less than.
+
+   function UR_Le (Left, Right : Ureal) return Boolean;
+   --  Compares reals for less than or equal.
+
+   function UR_Gt (Left, Right : Ureal) return Boolean;
+   --  Compares reals for greater than.
+
+   function UR_Ge (Left, Right : Ureal) return Boolean;
+   --  Compares reals for greater than or equal.
+
+   function UR_Is_Zero (Real : Ureal) return Boolean;
+   --  Tests if real value is zero
+
+   function UR_Is_Negative (Real : Ureal) return Boolean;
+   --  Tests if real value is negative, note that negative zero gives true
+
+   function UR_Is_Positive (Real : Ureal) return Boolean;
+   --  Test if real value is greater than zero
+
+   procedure UR_Write (Real : Ureal);
+   --  Writes value of Real to standard output. Used only for debugging and
+   --  tree/source output. If the result is easily representable as a standard
+   --  Ada literal, it will be given that way, but as a result of evaluation
+   --  of static expressions, it is possible to generate constants (e.g. 1/13)
+   --  which have no such representation. In such cases (and in cases where it
+   --  is too much work to figure out the Ada literal), the string that is
+   --  output is of the form [numerator/denominator].
+
+   procedure pr (Real : Ureal);
+   --  Writes value of Real to standard output with a terminating line return,
+   --  using UR_Write as described above. This is for use from the debugger.
+
+   ------------------------
+   -- Operator Renamings --
+   ------------------------
+
+   function "+" (Left : Ureal; Right : Ureal) return Ureal renames UR_Add;
+   function "+" (Left : Uint;  Right : Ureal) return Ureal renames UR_Add;
+   function "+" (Left : Ureal; Right : Uint)  return Ureal renames UR_Add;
+
+   function "/" (Left : Ureal; Right : Ureal) return Ureal renames UR_Div;
+   function "/" (Left : Uint;  Right : Ureal) return Ureal renames UR_Div;
+   function "/" (Left : Ureal; Right : Uint)  return Ureal renames UR_Div;
+
+   function "*" (Left : Ureal; Right : Ureal) return Ureal renames UR_Mul;
+   function "*" (Left : Uint;  Right : Ureal) return Ureal renames UR_Mul;
+   function "*" (Left : Ureal; Right : Uint)  return Ureal renames UR_Mul;
+
+   function "-" (Left : Ureal; Right : Ureal) return Ureal renames UR_Sub;
+   function "-" (Left : Uint;  Right : Ureal) return Ureal renames UR_Sub;
+   function "-" (Left : Ureal; Right : Uint)  return Ureal renames UR_Sub;
+
+   function "**"  (Real  : Ureal; N : Uint) return Ureal
+                                                     renames UR_Exponentiate;
+
+   function "abs" (Real : Ureal) return Ureal renames UR_Abs;
+
+   function "-"   (Real : Ureal) return Ureal renames UR_Negate;
+
+   function "="   (Left, Right : Ureal) return Boolean renames UR_Eq;
+
+   function "<"   (Left, Right : Ureal) return Boolean renames UR_Lt;
+
+   function "<="  (Left, Right : Ureal) return Boolean renames UR_Le;
+
+   function ">="  (Left, Right : Ureal) return Boolean renames UR_Ge;
+
+   function ">"   (Left, Right : Ureal) return Boolean renames UR_Gt;
+
+   -----------------------------
+   -- Mark/Release Processing --
+   -----------------------------
+
+   --  The space used by Ureal data is not automatically reclaimed. However,
+   --  a mark-release regime is implemented which allows storage to be
+   --  released back to a previously noted mark. This is used for example
+   --  when doing comparisons, where only intermediate results get stored
+   --  that do not need to be saved for future use.
+
+   type Save_Mark is private;
+
+   function Mark return Save_Mark;
+   --  Note mark point for future release
+
+   procedure Release (M : Save_Mark);
+   --  Release storage allocated since mark was noted
+
+   ------------------------------------
+   -- Representation of Ureal Values --
+   ------------------------------------
+
+private
+
+   type Ureal is new Int range Ureal_Low_Bound .. Ureal_High_Bound;
+   for Ureal'Size use 32;
+
+   No_Ureal : constant Ureal := Ureal'First;
+
+   type Save_Mark is new Int;
+
+   pragma Inline (Denominator);
+   pragma Inline (Mark);
+   pragma Inline (Norm_Num);
+   pragma Inline (Norm_Den);
+   pragma Inline (Numerator);
+   pragma Inline (Rbase);
+   pragma Inline (Release);
+   pragma Inline (Ureal_0);
+   pragma Inline (Ureal_M_0);
+   pragma Inline (Ureal_Tenth);
+   pragma Inline (Ureal_Half);
+   pragma Inline (Ureal_1);
+   pragma Inline (Ureal_2);
+   pragma Inline (Ureal_10);
+   pragma Inline (UR_From_Components);
+
+end Urealp;

gcc/ada/urealp.h

@@ -0,0 +1,50 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                               U R E A L P                                *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *          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.                                                      *
+ *                                                                          *
+ * 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). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file corresponds to the Ada package specification Urealp. It was
+   created manually from the files urealp.ads and urealp.adb  */
+
+/* Support for universal real arithmetic.  */
+
+#define Numerator urealp__numerator
+extern Uint Numerator		PARAMS ((Ureal));
+
+#define Denominator urealp__denominator
+extern Uint Denominator		PARAMS ((Ureal));
+
+#define Rbase urealp__rbase
+extern Nat Rbase		PARAMS ((Ureal));
+
+#define UR_Is_Negative urealp__ur_is_negative
+extern Boolean UR_Is_Negative	PARAMS ((Ureal));
+
+#define UR_Is_Zero urealp__ur_is_zero
+extern Boolean UR_Is_Zero	PARAMS ((Ureal));
+
+#define Machine eval_fat__machine
+extern Ureal Machine		PARAMS ((Entity_Id, Ureal));

gcc/ada/usage.adb

@@ -0,0 +1,390 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               U S A G E                                  --
+--                                                                          --
+--                                B o d y                                   --
+--                                                                          --
+--                           $Revision: 1.116 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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 Hostparm;
+with Namet;          use Namet;
+with Osint;          use Osint;
+with Output;         use Output;
+with System.WCh_Con; use System.WCh_Con;
+
+procedure Usage is
+
+   procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat");
+   --  Output two spaces followed by default switch character followed
+   --  Prefix, followed by the string given as the argument, and then
+   --  enough blanks to tab to column 13, i.e. assuming Sw is not longer
+   --  than 5 characters, the maximum allowed, Write_Switch_Char will
+   --  always output exactly 12 characters.
+
+   procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat") is
+   begin
+      Write_Str ("  ");
+      Write_Char (Switch_Character);
+      Write_Str (Prefix);
+      Write_Str (Sw);
+
+      for J in 1 .. 12 - 3 - Prefix'Length - Sw'Length loop
+         Write_Char (' ');
+      end loop;
+   end Write_Switch_Char;
+
+--  Start of processing for Usage
+
+begin
+   Find_Program_Name;
+
+   --  For gnatmake, we are appending this information to the end of
+   --  the normal gnatmake output, so generate appropriate header
+
+   if Name_Len >= 8
+     and then (Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatmake"
+                 or else
+               Name_Buffer (Name_Len - 7 .. Name_Len) = "GNATMAKE")
+   then
+      Write_Eol;
+      Write_Line ("Compiler switches (passed to the compiler by gnatmake):");
+
+   else
+      --  Usage line
+
+      Write_Str ("Usage: ");
+      Write_Program_Name;
+      Write_Char (' ');
+      Write_Str ("switches sfile");
+      Write_Eol;
+      Write_Eol;
+
+      --  Line for sfile
+
+      Write_Line ("  sfile     Source file name");
+   end if;
+
+   Write_Eol;
+
+   --  Common GCC switches not available in JGNAT
+
+   if not Hostparm.Java_VM then
+      Write_Switch_Char ("fstack-check ", "");
+      Write_Line ("Generate stack checking code");
+
+      Write_Switch_Char ("fno-inline   ", "");
+      Write_Line ("Inhibit all inlining (makes executable smaller)");
+   end if;
+
+   --  Common switches available to both GCC and JGNAT
+
+   Write_Switch_Char ("g            ", "");
+   Write_Line ("Generate debugging information");
+
+   Write_Switch_Char ("Idir         ", "");
+   Write_Line ("Specify source files search path");
+
+   Write_Switch_Char ("I-           ", "");
+   Write_Line ("Do not look for sources in current directory");
+
+   Write_Switch_Char ("O[0123]      ", "");
+   Write_Line ("Control the optimization level");
+
+   Write_Eol;
+
+   --  Individual lines for switches. Write_Switch_Char outputs fourteen
+   --  characters, so the remaining message is allowed to be a maximum
+   --  of 65 characters to be comfortable on an 80 character device.
+   --  If the Write_Str fits on one line, it is short enough!
+
+   --  Line for -gnata switch
+
+   Write_Switch_Char ("a");
+   Write_Line ("Assertions enabled. Pragma Assert/Debug to be activated");
+
+   --  Line for -gnatA switch
+
+   Write_Switch_Char ("A");
+   Write_Line ("Avoid processing gnat.adc, if present file will be ignored");
+
+   --  Line for -gnatb switch
+
+   Write_Switch_Char ("b");
+   Write_Line ("Generate brief messages to stderr even if verbose mode set");
+
+   --  Line for -gnatc switch
+
+   Write_Switch_Char ("c");
+   Write_Line ("Check syntax and semantics only (no code generation)");
+
+   Write_Switch_Char ("C");
+   Write_Line ("Compress names in external names and debug info tables");
+
+   --  Line for -gnatd switch
+
+   Write_Switch_Char ("d?");
+   Write_Line ("Compiler debug option ? (a-z,A-Z,0-9), see debug.adb");
+
+   --  Line for -gnatD switch
+
+   Write_Switch_Char ("D");
+   Write_Line ("Debug expanded generated code rather than source code");
+
+   --  Line for -gnatec switch
+
+   Write_Switch_Char ("ec?");
+   Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc");
+
+   --  Line for -gnatE switch
+
+   Write_Switch_Char ("E");
+   Write_Line ("Dynamic elaboration checking mode enabled");
+
+   --  Line for -gnatf switch
+
+   Write_Switch_Char ("f");
+   Write_Line ("Full errors. Verbose details, all undefined references");
+
+   --  Line for -gnatF switch
+
+   Write_Switch_Char ("F");
+   Write_Line ("Force all import/export external names to all uppercase");
+
+   --  Line for -gnatg switch
+
+   Write_Switch_Char ("g");
+   Write_Line ("GNAT implementation mode (used for compiling GNAT units)");
+
+   --  Line for -gnatG switch
+
+   Write_Switch_Char ("G");
+   Write_Line ("Output generated expanded code in source form");
+
+   --  Line for -gnath switch
+
+   Write_Switch_Char ("h");
+   Write_Line ("Output this usage (help) information");
+
+   --  Line for -gnati switch
+
+   Write_Switch_Char ("i?");
+   Write_Line ("Identifier char set (?=1/2/3/4/8/p/f/n/w)");
+
+   --  Line for -gnatk switch
+
+   Write_Switch_Char ("k");
+   Write_Line ("Limit file names to nnn characters (k = krunch)");
+
+   --  Line for -gnatl switch
+
+   Write_Switch_Char ("l");
+   Write_Line ("Output full source listing with embedded error messages");
+
+   --  Line for -gnatL switch
+
+   Write_Switch_Char ("L");
+   Write_Line ("Use longjmp/setjmp for exception handling");
+
+   --  Line for -gnatm switch
+
+   Write_Switch_Char ("mnnn");
+   Write_Line ("Limit number of detected errors to nnn (1-999)");
+
+   --  Line for -gnatn switch
+
+   Write_Switch_Char ("n");
+   Write_Line ("Inlining of subprograms (apply pragma Inline across units)");
+
+   --  Line for -gnatN switch
+
+   Write_Switch_Char ("N");
+   Write_Line ("Full (frontend) inlining of subprograqms");
+
+   --  Line for -gnato switch
+
+   Write_Switch_Char ("o");
+   Write_Line ("Enable overflow checking (off by default)");
+
+   --  Line for -gnatO switch
+
+   Write_Switch_Char ("O nm ");
+   Write_Line ("Set name of output ali file (internal switch)");
+
+   --  Line for -gnatp switch
+
+   Write_Switch_Char ("p");
+   Write_Line ("Suppress all checks");
+
+   --  Line for -gnatP switch
+
+   Write_Switch_Char ("P");
+   Write_Line ("Generate periodic calls to System.Polling.Poll");
+
+   --  Line for -gnatq switch
+
+   Write_Switch_Char ("q");
+   Write_Line ("Don't quit, try semantics, even if parse errors");
+
+   --  Line for -gnatQ switch
+
+   Write_Switch_Char ("Q");
+   Write_Line ("Don't quit, write ali/tree file even if compile errors");
+
+   --  Line for -gnatR switch
+
+   Write_Switch_Char ("R?");
+   Write_Line ("List rep inf (?=0/1/2/3 for none/types/all/variable)");
+
+   --  Lines for -gnats switch
+
+   Write_Switch_Char ("s");
+   Write_Line ("Syntax check only");
+
+   --  Lines for -gnatt switch
+
+   Write_Switch_Char ("t");
+   Write_Line ("Tree output file to be generated");
+
+   --  Line for -gnatT switch
+
+   Write_Switch_Char ("Tnnn");
+   Write_Line ("All compiler tables start at nnn times usual starting size");
+
+   --  Line for -gnatu switch
+
+   Write_Switch_Char ("u");
+   Write_Line ("List units for this compilation");
+
+   --  Line for -gnatU switch
+
+   Write_Switch_Char ("U");
+   Write_Line ("Enable unique tag for error messages");
+
+   --  Line for -gnatv switch
+
+   Write_Switch_Char ("v");
+   Write_Line ("Verbose mode. Full error output with source lines to stdout");
+
+   --  Line for -gnatV switch
+
+   Write_Switch_Char ("V?");
+   Write_Line
+     ("Validity checking (?=ndcte or 0-4 None/Default/Copy/Test/Exprs)");
+
+   --  Lines for -gnatw switch
+
+   Write_Switch_Char ("wxx");
+   Write_Line ("Enable selected warning modes, xx = list of parameters:");
+   Write_Line ("        a    turn on all optional warnings (except b,h)");
+   Write_Line ("        A    turn off all optional warnings");
+   Write_Line ("        b    turn on biased rounding warnings");
+   Write_Line ("        B    turn off biased rounding warnings");
+   Write_Line ("        c    turn on constant conditional warnings");
+   Write_Line ("        C*   turn off constant conditional warnings");
+   Write_Line ("        e    treat all warnings as errors");
+   Write_Line ("        h    turn on warnings for hiding variables");
+   Write_Line ("        H*   turn off warnings for hiding variables");
+   Write_Line ("        i*   turn on warnings for implementation units");
+   Write_Line ("        I    turn off warnings for implementation units");
+   Write_Line ("        l    turn on elaboration warnings");
+   Write_Line ("        L*   turn off elaboration warnings");
+   Write_Line ("        o*   turn on address clause overlay warnings");
+   Write_Line ("        O    turn off address clause overlay warnings");
+   Write_Line ("        p    turn on warnings for ineffective pragma inline");
+   Write_Line ("        P*   turn off warnings for ineffective pragma inline");
+   Write_Line ("        r    turn on redundant construct warnings");
+   Write_Line ("        R*   turn off redundant construct warnings");
+   Write_Line ("        s    suppress all warnings");
+   Write_Line ("        u    turn on warnings for unused entities");
+   Write_Line ("        U*   turn off warnings for unused entities");
+   Write_Line ("        *    indicates default in above list");
+
+   --  Line for -gnatW switch
+
+   Write_Switch_Char ("W");
+   Write_Str ("Wide character encoding method (");
+
+   for J in WC_Encoding_Method loop
+      Write_Char (WC_Encoding_Letters (J));
+
+      if J = WC_Encoding_Method'Last then
+         Write_Char (')');
+      else
+         Write_Char ('/');
+      end if;
+   end loop;
+
+   Write_Eol;
+
+   --  Line for -gnatx switch
+
+   Write_Switch_Char ("x");
+   Write_Line ("Suppress output of cross-reference information");
+
+   --  Line for -gnatX switch
+
+   Write_Switch_Char ("X");
+   Write_Line ("Language extensions permitted");
+
+   --  Lines for -gnaty switch
+
+   Write_Switch_Char ("y");
+   Write_Line ("Enable all style checks");
+
+   Write_Switch_Char ("yxx");
+   Write_Line ("Enable selected style checks xx = list of parameters:");
+   Write_Line ("        1-9  check indentation");
+   Write_Line ("        a    check attribute casing");
+   Write_Line ("        b    check no blanks at end of lines");
+   Write_Line ("        c    check comment format");
+   Write_Line ("        e    check end/exit labels present");
+   Write_Line ("        f    check no form feeds/vertical tabs in source");
+   Write_Line ("        h    check no horizontal tabs in source");
+   Write_Line ("        i    check if-then layout");
+   Write_Line ("        k    check casing rules for keywords, identifiers");
+   Write_Line ("        l    check reference manual layout");
+   Write_Line ("        m    check line length <= 79 characters");
+   Write_Line ("        n    check casing of package Standard identifiers");
+   Write_Line ("        Mnnn check line length <= nnn characters");
+   Write_Line ("        o    check subprogram bodies in alphabetical order");
+   Write_Line ("        p    check pragma casing");
+   Write_Line ("        r    check RM column layout");
+   Write_Line ("        s    check separate subprogram specs present");
+   Write_Line ("        t    check token separation rules");
+
+   --  Lines for -gnatz switch
+
+   Write_Switch_Char ("z");
+   Write_Line ("Distribution stub generation (r/s for receiver/sender stubs)");
+
+   --  Line for -gnatZ switch
+
+   Write_Switch_Char ("Z");
+   Write_Line ("Use zero cost exception handling");
+
+   --  Line for -gnat83 switch
+
+   Write_Switch_Char ("83");
+   Write_Line ("Enforce Ada 83 restrictions");
+
+end Usage;

gcc/ada/usage.ads

@@ -0,0 +1,31 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                U S A G E                                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.5 $                              --
+--                                                                          --
+--        Copyright (C) 1992,1993,1994 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Procedure to generate screen of usage information if no file name present
+
+procedure Usage;

gcc/ada/validsw.adb

@@ -0,0 +1,222 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              V A L I D S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 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.                                                      --
+--                                                                          --
+-- 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 Opt; use Opt;
+
+package body Validsw is
+
+   ----------------------------------
+   -- Reset_Validity_Check_Options --
+   ----------------------------------
+
+   procedure Reset_Validity_Check_Options is
+   begin
+      Validity_Check_Copies         := False;
+      Validity_Check_Default        := True;
+      Validity_Check_Floating_Point := False;
+      Validity_Check_In_Out_Params  := False;
+      Validity_Check_In_Params      := False;
+      Validity_Check_Operands       := False;
+      Validity_Check_Returns        := False;
+      Validity_Check_Subscripts     := False;
+      Validity_Check_Tests          := False;
+   end Reset_Validity_Check_Options;
+
+   ---------------------------------
+   -- Save_Validity_Check_Options --
+   ---------------------------------
+
+   procedure Save_Validity_Check_Options
+     (Options : out Validity_Check_Options)
+   is
+      P : Natural := 0;
+
+      procedure Add (C : Character; S : Boolean);
+      --  Add given character C to string if switch S is true
+
+      procedure Add (C : Character; S : Boolean) is
+      begin
+         if S then
+            P := P + 1;
+            Options (P) := C;
+         end if;
+      end Add;
+
+   --  Start of processing for Save_Validity_Check_Options
+
+   begin
+      for K in Options'Range loop
+         Options (K) := ' ';
+      end loop;
+
+      Add ('c', Validity_Check_Copies);
+      Add ('d', Validity_Check_Default);
+      Add ('f', Validity_Check_Floating_Point);
+      Add ('i', Validity_Check_In_Params);
+      Add ('m', Validity_Check_In_Out_Params);
+      Add ('o', Validity_Check_Operands);
+      Add ('r', Validity_Check_Returns);
+      Add ('s', Validity_Check_Subscripts);
+      Add ('t', Validity_Check_Tests);
+   end Save_Validity_Check_Options;
+
+   ----------------------------------------
+   -- Set_Default_Validity_Check_Options --
+   ----------------------------------------
+
+   procedure Set_Default_Validity_Check_Options is
+   begin
+      Reset_Validity_Check_Options;
+      Set_Validity_Check_Options ("d");
+   end Set_Default_Validity_Check_Options;
+
+   --------------------------------
+   -- Set_Validity_Check_Options --
+   --------------------------------
+
+   --  Version used when no error checking is required
+
+   procedure Set_Validity_Check_Options (Options : String) is
+      OK : Boolean;
+      EC : Natural;
+
+   begin
+      Set_Validity_Check_Options (Options, OK, EC);
+   end Set_Validity_Check_Options;
+
+   --  Normal version with error checking
+
+   procedure Set_Validity_Check_Options
+     (Options  : String;
+      OK       : out Boolean;
+      Err_Col  : out Natural)
+   is
+      J : Natural;
+      C : Character;
+
+   begin
+      Reset_Validity_Check_Options;
+
+      J := Options'First;
+      while J <= Options'Last loop
+         C := Options (J);
+         J := J + 1;
+
+         case C is
+            when 'c' =>
+               Validity_Check_Copies         := True;
+
+            when 'd' =>
+               Validity_Check_Default        := True;
+
+            when 'f' =>
+               Validity_Check_Floating_Point := True;
+
+            when 'i' =>
+               Validity_Check_In_Params      := True;
+
+            when 'm' =>
+               Validity_Check_In_Out_Params  := True;
+
+            when 'o' =>
+               Validity_Check_Operands       := True;
+
+            when 'r' =>
+               Validity_Check_Returns        := True;
+
+            when 's' =>
+               Validity_Check_Subscripts     := True;
+
+            when 't' =>
+               Validity_Check_Tests          := True;
+
+            when 'C' =>
+               Validity_Check_Copies         := False;
+
+            when 'D' =>
+               Validity_Check_Default        := False;
+
+            when 'I' =>
+               Validity_Check_In_Params      := False;
+
+            when 'F' =>
+               Validity_Check_Floating_Point := False;
+
+            when 'M' =>
+               Validity_Check_In_Out_Params  := False;
+
+            when 'O' =>
+               Validity_Check_Operands       := False;
+
+            when 'R' =>
+               Validity_Check_Returns        := False;
+
+            when 'S' =>
+               Validity_Check_Subscripts     := False;
+
+            when 'T' =>
+               Validity_Check_Tests          := False;
+
+            when 'a' =>
+               Validity_Check_Copies         := True;
+               Validity_Check_Default        := True;
+               Validity_Check_Floating_Point := True;
+               Validity_Check_In_Out_Params  := True;
+               Validity_Check_In_Params      := True;
+               Validity_Check_Operands       := True;
+               Validity_Check_Returns        := True;
+               Validity_Check_Subscripts     := True;
+               Validity_Check_Tests          := True;
+
+            when 'n' =>
+               Validity_Check_Copies         := False;
+               Validity_Check_Default        := False;
+               Validity_Check_Floating_Point := False;
+               Validity_Check_In_Out_Params  := False;
+               Validity_Check_In_Params      := False;
+               Validity_Check_Operands       := False;
+               Validity_Check_Returns        := False;
+               Validity_Check_Subscripts     := False;
+               Validity_Check_Tests          := False;
+
+            when ' ' =>
+               null;
+
+            when others =>
+               OK      := False;
+               Err_Col := J - 1;
+               return;
+         end case;
+      end loop;
+
+      Validity_Checks_On := True;
+      OK := True;
+      Err_Col := Options'Last + 1;
+   end Set_Validity_Check_Options;
+
+end Validsw;

gcc/ada/validsw.ads

@@ -0,0 +1,146 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              V A L I D S W                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This unit contains the routines used to handle setting of validity
+--  checking options.
+
+package Validsw is
+
+   -----------------------------
+   -- Validity Check Switches --
+   -----------------------------
+
+   --  The following flags determine the specific set of validity checks
+   --  to be made if validity checking is active (Validity_Checks_On = True)
+
+   --  See GNAT users guide for an exact description of each option. The letter
+   --  given in the comment is the letter used in the -gnatV compiler switch
+   --  or in the argument of a Validity_Checks pragma to activate the option.
+   --  The corresponding upper case letter deactivates the option.
+
+   Validity_Check_Copies : Boolean := False;
+   --  Controls the validity checking of copies. If this switch is set to
+   --  true using -gnatVc, or a 'c' in the argument of a Validity_Checks
+   --  pragma, then the right side of assignments and also initializing
+   --  expressions in object declarations are checked for validity.
+
+   Validity_Check_Default : Boolean := True;
+   --  Controls default (reference manual) validity checking. If this switch
+   --  is set to True using -gnatVd or a 'd' in the argument of a Validity_
+   --  Checks pragma then left side subscripts and case statement arguments
+   --  are checked for validity. This switch is also set by default if no
+   --  -gnatV switch is used and no Validity_Checks pragma is processed.
+
+   Validity_Check_Floating_Point : Boolean := False;
+   --  Normally validity checking applies only to discrete values (integer
+   --  and enumeration types). If this switch is set to True using -gnatVf
+   --  or an 'f' in the argument of a Validity_Checks pragma, then floating-
+   --  point values are also checked. The context in which such checks
+   --  occur depends on other flags, e.g. if Validity_Check_Copies is also
+   --  set then floating-point values on the right side of an assignment
+   --  will be validity checked.
+
+   Validity_Check_In_Out_Params : Boolean := False;
+   --  Controls the validity checking of IN OUT parameters. If this switch
+   --  is set to True using -gnatVm or a 'm' in the argument of a pragma
+   --  Validity_Checks, then the initial value of all IN OUT parameters
+   --  will be checked at the point of call of a procecure. Note that the
+   --  character 'm' here stands for modified (parameters).
+
+   Validity_Check_In_Params : Boolean := False;
+   --  Controls the validity checking of IN parameters. If this switch is
+   --  set to True using -gnatVm or an 'i' in the argument of a pragma
+   --  Validity_Checks, then the initial value of all IN parameters
+   --  will be checked at the point of call of a procecure or function.
+
+   Validity_Check_Operands : Boolean := False;
+   --  Controls validity checking of operands. If this switch is set to
+   --  True using -gnatVo or an 'o' in the argument of a Validity_Checks
+   --  pragma, then operands of all predefined operators and attributes
+   --  will be validity checked.
+
+   Validity_Check_Returns : Boolean := False;
+   --  Controls validity checking of returned values. If this switch is set
+   --  to True using -gnatVr, or an 'r' in the argument of a Validity_Checks
+   --  pragma, then the expression in a RETURN statement is validity checked.
+
+   Validity_Check_Subscripts : Boolean := False;
+   --  Controls validity checking of subscripts. If this switch is set to
+   --  True using -gnatVs, or an 's' in the argument of a Validity_Checks
+   --  pragma, then all subscripts are checked for validity. Note that left
+   --  side subscript checking is controlled also by Validity_Check_Default.
+   --  If Validity_Check_Subscripts is True, then all subscripts are checked,
+   --  otherwise if Validity_Check_Default is True, then left side subscripts
+   --  are checked, otherwise no subscripts are checked.
+
+   Validity_Check_Tests : Boolean := False;
+   --  Controls validity checking of tests that occur in conditions (i.e. the
+   --  tests in IF, WHILE, and EXIT statements, and in entry guards). If this
+   --  switch is set to True using -gnatVt, or a 't' in the argument of a
+   --  Validity_Checks pragma, then all such conditions are validity checked.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Set_Default_Validity_Check_Options;
+   --  This procedure is called to set the default validity checking options
+   --  that apply if no Validity_Check switches or pragma is given.
+
+   procedure Set_Validity_Check_Options
+     (Options  : String;
+      OK       : out Boolean;
+      Err_Col  : out Natural);
+   --  This procedure is called to set the validity check options that
+   --  correspond to the characters in the given Options string. If
+   --  all options are valid, then Set_Default_Validity_Check_Options
+   --  is first called to set the defaults, and then the options in the
+   --  given string are set in an additive manner. If any invalid character
+   --  is found, then OK is False on exit, and Err_Col is the index in
+   --  in options of the bad character. If all options are valid, then
+   --  OK is True on return, and Err_Col is set to options'Last + 1.
+
+   procedure Set_Validity_Check_Options (Options : String);
+   --  Like the above procedure, except that the call is simply ignored if
+   --  there are any error conditions, this is for example appopriate for
+   --  calls where the string is known to be valid, e.g. because it was
+   --  obtained by Save_Validity_Check_Options.
+
+   procedure Reset_Validity_Check_Options;
+   --  Sets all validity check options to off
+
+   subtype Validity_Check_Options is String (1 .. 16);
+   --  Long enough string to hold all options from Save call below
+
+   procedure Save_Validity_Check_Options
+     (Options : out Validity_Check_Options);
+   --  Sets Options to represent current selection of options. This
+   --  set can be restored by first calling Reset_Validity_Check_Options,
+   --  and then calling Set_Validity_Check_Options with the Options string.
+
+end Validsw;

gcc/ada/widechar.adb

@@ -0,0 +1,163 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             W I D E C H A R                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.15 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Note: this package uses the generic subprograms in System.Wch_Cnv, which
+--  completely encapsulate the set of wide character encoding methods, so no
+--  modifications are required when adding new encoding methods.
+
+with Opt; use Opt;
+
+with System.WCh_Cnv; use System.WCh_Cnv;
+with System.WCh_Con; use System.WCh_Con;
+
+package body Widechar is
+
+   ---------------------------
+   -- Is_Start_Of_Wide_Char --
+   ---------------------------
+
+   function Is_Start_Of_Wide_Char
+     (S    : Source_Buffer_Ptr;
+      P    : Source_Ptr)
+      return Boolean
+   is
+   begin
+      case Wide_Character_Encoding_Method is
+         when WCEM_Hex =>
+            return S (P) = ASCII.ESC;
+
+         when WCEM_Upper     |
+              WCEM_Shift_JIS |
+              WCEM_EUC       |
+              WCEM_UTF8      =>
+            return S (P) >= Character'Val (16#80#);
+
+         when WCEM_Brackets =>
+            return P <= S'Last - 2
+              and then S (P) = '['
+              and then S (P + 1) = '"'
+              and then S (P + 2) /= '"';
+      end case;
+   end Is_Start_Of_Wide_Char;
+
+   -----------------
+   -- Length_Wide --
+   -----------------
+
+   function Length_Wide return Nat is
+   begin
+      return WC_Longest_Sequence;
+   end Length_Wide;
+
+   ---------------
+   -- Scan_Wide --
+   ---------------
+
+   procedure Scan_Wide
+     (S   : Source_Buffer_Ptr;
+      P   : in out Source_Ptr;
+      C   : out Char_Code;
+      Err : out Boolean)
+   is
+      function In_Char return Character;
+      --  Function to obtain characters of wide character escape sequence
+
+      function In_Char return Character is
+      begin
+         P := P + 1;
+         return S (P - 1);
+      end In_Char;
+
+      function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
+
+   begin
+      C := Char_Code (Wide_Character'Pos
+                       (WC_In (In_Char, Wide_Character_Encoding_Method)));
+      Err := False;
+
+   exception
+      when Constraint_Error =>
+         C := Char_Code (0);
+         P := P - 1;
+         Err := True;
+   end Scan_Wide;
+
+   --------------
+   -- Set_Wide --
+   --------------
+
+   procedure Set_Wide
+     (C : Char_Code;
+      S : in out String;
+      P : in out Natural)
+   is
+      procedure Out_Char (C : Character);
+      --  Procedure to store one character of wide character sequence
+
+      procedure Out_Char (C : Character) is
+      begin
+         P := P + 1;
+         S (P) := C;
+      end Out_Char;
+
+      procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
+
+   begin
+      WC_Out (Wide_Character'Val (C), Wide_Character_Encoding_Method);
+   end Set_Wide;
+
+   ---------------
+   -- Skip_Wide --
+   ---------------
+
+   procedure Skip_Wide (S : String; P : in out Natural) is
+      function Skip_Char return Character;
+      --  Function to skip one character of wide character escape sequence
+
+      function Skip_Char return Character is
+      begin
+         P := P + 1;
+         return S (P - 1);
+      end Skip_Char;
+
+      function WC_Skip is new Char_Sequence_To_Wide_Char (Skip_Char);
+
+      Discard : Wide_Character;
+
+   begin
+      Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
+   end Skip_Wide;
+
+end Widechar;

gcc/ada/widechar.ads

@@ -0,0 +1,87 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             W I D E C H A R                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.10 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1998 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Subprograms for manipulation of wide character sequences
+
+with Types; use Types;
+
+package Widechar is
+
+   function Length_Wide return Nat;
+   --  Returns the maximum length in characters for the escape sequence that
+   --  is used to encode wide character literals outside the ASCII range. Used
+   --  only in the implementation of the attribute Width for Wide_Character.
+
+   procedure Scan_Wide
+     (S   : Source_Buffer_Ptr;
+      P   : in out Source_Ptr;
+      C   : out Char_Code;
+      Err : out Boolean);
+   --  On entry S (P) points to the first character in the source text for
+   --  a wide character (i.e. to an ESC character, a left bracket, or an
+   --  upper half character, depending on the representation method). A
+   --  single wide character is scanned. If no error is found, the value
+   --  stored in C is the code for this wide character, P is updated past
+   --  the sequence and Err is set to False. If an error is found, then
+   --  P points to the improper character, C is undefined, and Err is
+   --  set to True.
+
+   procedure Set_Wide
+     (C : Char_Code;
+      S : in out String;
+      P : in out Natural);
+   --  The escape sequence (including any leading ESC character) for the
+   --  given character code is stored starting at S (P + 1), and on return
+   --  P points to the last stored character (i.e. P is the count of stored
+   --  characters on entry and exit, and the escape sequence is appended to
+   --  the end of the stored string). The character code C represents a code
+   --  originally constructed by Scan_Wide, so it is known to be in a range
+   --  that is appropriate for the encoding method in use.
+
+   procedure Skip_Wide (S : String; P : in out Natural);
+   --  On entry, S (P) points to an ESC character for a wide character escape
+   --  sequence or to an upper half character if the encoding method uses the
+   --  upper bit, or to a left bracket if the brackets encoding method is in
+   --  use. On exit, P is bumped past the wide character sequence. No error
+   --  checking is done, since this is only used on escape sequences generated
+   --  by Set_Wide, which are known to be correct.
+
+   function Is_Start_Of_Wide_Char
+     (S    : Source_Buffer_Ptr;
+      P    : Source_Ptr)
+      return Boolean;
+   --  Determines if S (P) is the start of a wide character sequence
+
+end Widechar;

gcc/ada/xeinfo.adb

@@ -0,0 +1,539 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                               X E I N F O                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.29 $
+--                                                                          --
+--          Copyright (C) 1992-2000 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Program to construct C header file a-einfo.h (C version of einfo.ads spec)
+--  for use by Gigi. This header file contaInF all definitions and access
+--  functions, but does not contain set procedures, since Gigi is not allowed
+--  to modify the GNAT tree)
+
+--    Input files:
+
+--       einfo.ads     spec of Einfo package
+--       einfo.adb     body of Einfo package
+
+--    Output files:
+
+--       a-einfo.h     Corresponding c header file
+
+--  Note: It is assumed that the input files have been compiled without errors
+
+--  An optional argument allows the specification of an output file name to
+--  override the default a-einfo.h file name for the generated output file.
+
+--  Most, but not all of the functions in Einfo can be inlined in the C header.
+--  They are the functions identified by pragma Inline in the spec. Functions
+--  that cannot be inlined are simply defined in the header.
+
+with Ada.Command_Line;              use Ada.Command_Line;
+with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Strings.Maps;              use Ada.Strings.Maps;
+with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
+with Ada.Text_IO;                   use Ada.Text_IO;
+
+with GNAT.Spitbol;                  use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
+with GNAT.Spitbol.Table_Boolean;    use GNAT.Spitbol.Table_Boolean;
+
+procedure XEinfo is
+
+   package TB renames GNAT.Spitbol.Table_Boolean;
+
+   Err : exception;
+
+   A         : VString := Nul;
+   B         : VString := Nul;
+   C         : VString := Nul;
+   Einfobrev : VString := Nul;
+   Einfosrev : VString := Nul;
+   Expr      : VString := Nul;
+   Filler    : VString := Nul;
+   Fline     : VString := Nul;
+   Formal    : VString := Nul;
+   Formaltyp : VString := Nul;
+   FN        : VString := Nul;
+   Line      : VString := Nul;
+   N         : VString := Nul;
+   N1        : VString := Nul;
+   N2        : VString := Nul;
+   N3        : VString := Nul;
+   Nam       : VString := Nul;
+   Name      : VString := Nul;
+   NewS      : VString := Nul;
+   Nextlin   : VString := Nul;
+   OldS      : VString := Nul;
+   Rtn       : VString := Nul;
+   Term      : VString := Nul;
+   XEinforev : VString := Nul;
+
+   InB : File_Type;
+   --  Used to read initial header from body
+
+   InF   : File_Type;
+   --  Used to read full text of both spec and body
+
+   Ofile : File_Type;
+   --  Used to write output file
+
+   wsp      : Pattern := NSpan (' ' & ASCII.HT);
+   Get_BRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                           & Break (' ') * Einfobrev;
+   Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                           & Break (' ') * Einfosrev;
+   Comment  : Pattern := wsp & "--";
+   For_Rep  : Pattern := wsp & "for";
+   Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name;
+   Inline   : Pattern := wsp & "pragma Inline (" & Break (')') * Name;
+   Get_Pack : Pattern := wsp & "package ";
+   Get_Enam : Pattern := wsp & Break (',') * N & ',';
+   Find_Fun : Pattern := wsp & "function";
+   F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N;
+   G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
+                           & wsp & "is" & wsp & Break (" ;") * OldS
+                           & wsp & ';' & wsp & Rtab (0);
+   F_Typ    : Pattern := wsp * A & "type " & Break (' ') * N & " is (";
+   Get_Nam  : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term;
+   Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N;
+   Get_N1   : Pattern := wsp & Break (' ') * N1;
+   Get_N2   : Pattern := wsp & "-- " & Rest * N2;
+   Get_N3   : Pattern := wsp & Break (';') * N3;
+   Get_FN   : Pattern := wsp * C & "function" & wsp & Break (" (") * FN;
+   Is_Rturn : Pattern := BreakX ('r') & "return";
+   Is_Begin : Pattern := wsp & "begin";
+   Get_Asrt : Pattern := wsp & "pragma Assert";
+   Semicoln : Pattern := BreakX (';');
+   Get_Cmnt : Pattern := BreakX ('-') * A & "--";
+   Get_Expr : Pattern := wsp & "return " & Break (';') * Expr;
+   Chek_End : Pattern := wsp & "end" & BreakX (';') & ';';
+   Get_B1   : Pattern := BreakX (' ') * A & " in " & Rest * B;
+   Get_B2   : Pattern := BreakX (' ') * A & " = " & Rest * B;
+   Get_B3   : Pattern := BreakX (' ') * A & " /= " & Rest * B;
+   To_Paren : Pattern := wsp * Filler & '(';
+   Get_Fml  : Pattern := Break (" :") * Formal & wsp & ':' & wsp
+                           & BreakX (" );") * Formaltyp;
+   Nxt_Fml  : Pattern := wsp & "; ";
+   Get_Rtn  : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
+   Rem_Prn  : Pattern := wsp & ')';
+
+   M : Match_Result;
+
+   Lineno : Natural := 0;
+   --  Line number in spec
+
+   V   : Natural;
+   Ctr : Natural;
+
+   Inlined : TB.Table (200);
+   --  Inlined<N> = True for inlined function, False otherwise
+
+   Lastinlined : Boolean;
+
+   procedure Badfunc;
+   --  Signal bad function in body
+
+   function Getlin return VString;
+   --  Get non-comment line (comment lines skipped, also skips FOR rep clauses)
+   --  Fatal error (raises End_Error exception) if end of file encountered
+
+   procedure Must (B : Boolean);
+   --  Raises Err if the argument (a Match) call, returns False
+
+   procedure Sethead (Line : in out VString; Term : String);
+   --  Process function header into C
+
+   -------------
+   -- Badfunc --
+   -------------
+
+   procedure Badfunc is
+   begin
+      Put_Line
+        (Standard_Error,
+         "Body for function " & FN & " does not meet requirements");
+      raise Err;
+   end Badfunc;
+
+   -------------
+   -- Getlin --
+   -------------
+
+   function Getlin return VString is
+      Lin : VString;
+
+   begin
+      loop
+         Lin := Get_Line (InF);
+         Lineno := Lineno + 1;
+
+         if Lin /= ""
+           and then not Match (Lin, Comment)
+           and then not Match (Lin, For_Rep)
+         then
+            return Lin;
+         end if;
+      end loop;
+   end Getlin;
+
+   ----------
+   -- Must --
+   ----------
+
+   procedure Must (B : Boolean) is
+   begin
+      if not B then
+         raise Err;
+      end if;
+   end Must;
+
+   -------------
+   -- Sethead --
+   -------------
+
+   procedure Sethead (Line : in out VString; Term : String) is
+      Args : VString;
+
+   begin
+      Must (Match (Line, Get_Func, ""));
+      Args := Nul;
+
+      if Match (Line, To_Paren, "") then
+         Args := Filler & '(';
+
+         loop
+            Must (Match (Line, Get_Fml, ""));
+            Append (Args, Formaltyp & ' ' & Formal);
+            exit when not Match (Line, Nxt_Fml);
+            Append (Args, ",");
+         end loop;
+
+         Match (Line, Rem_Prn, "");
+         Append (Args, ')');
+      end if;
+
+      Must (Match (Line, Get_Rtn));
+
+      if Present (Inlined, Name) then
+         Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
+      else
+         Put_Line (Ofile, A &  Rtn & ' ' & Name & Args & Term);
+      end if;
+   end Sethead;
+
+--  Start of processing for XEinfo
+
+begin
+   Anchored_Mode := True;
+
+   Match ("$Revision: 1.29 $", "$Rev" & "ision: " & Break (' ') * XEinforev);
+
+   if Argument_Count > 0 then
+      Create (Ofile, Out_File, Argument (1));
+   else
+      Create (Ofile, Out_File, "a-einfo.h");
+   end if;
+
+   Open (InB, In_File, "einfo.adb");
+   Open (InF, In_File, "einfo.ads");
+
+   Lineno := 0;
+
+   --  Get einfo revs and write header to output file
+
+   loop
+      Line := Get_Line (InB);
+
+      if Line = "" then
+         raise Err;
+      end if;
+
+      exit when Match (Line, Get_BRev);
+   end loop;
+
+   loop
+      Line := Get_Line (InF);
+      Lineno := Lineno + 1;
+      exit when Line = "";
+
+      if Match (Line, Get_SRev) then
+         Put_Line
+           (Ofile,
+            "/*                 Generated by xeinfo revision " & XEinforev &
+            " using                  */");
+         Put_Line
+           (Ofile,
+            "/*                         einfo.ads revision " & Einfosrev &
+            "                         */");
+         Put_Line
+           (Ofile,
+            "/*                         einfo.adb revision " & Einfobrev &
+            "                         */");
+      else
+         Match (Line,
+                "--                                 S p e c       ",
+                "--                              C Header File    ");
+
+         Match (Line, "--", "/*");
+         Match (Line, Rtab (2) * A & "--", M);
+         Replace (M, A & "*/");
+         Put_Line (Ofile, Line);
+      end if;
+   end loop;
+
+   Put_Line (Ofile, "");
+
+   --  Find and record pragma Inlines
+
+   loop
+      Line := Get_Line (InF);
+      exit when Match (Line, "   --  END XEINFO INLINES");
+
+
+      if Match (Line, Inline) then
+         Set (Inlined, Name, True);
+      end if;
+   end loop;
+
+   --  Skip to package line
+
+   Reset (InF, In_File);
+   Lineno := 0;
+
+   loop
+      Line := Getlin;
+      exit when Match (Line, Get_Pack);
+   end loop;
+
+   V := 0;
+   Line := Getlin;
+   Must (Match (Line, wsp & "type Entity_Kind"));
+
+   --  Process entity kind code definitions
+
+   loop
+      Line := Getlin;
+      exit when not Match (Line, Get_Enam);
+      Put_Line (Ofile, "   #define " & Rpad (N, 32) & " " & V);
+      V := V + 1;
+   end loop;
+
+   Must (Match (Line, wsp & Rest * N));
+   Put_Line (Ofile, "   #define " & Rpad (N, 32) & ' ' & V);
+   Line := Getlin;
+
+   Must (Match (Line, wsp & ");"));
+   Put_Line (Ofile, "");
+
+   --  Loop through subtype and type declarations
+
+   loop
+      Line := Getlin;
+      exit when Match (Line, Find_Fun);
+
+      --  Case of a subtype declaration
+
+      if Match (Line, F_Subtyp) then
+
+         --  Case of a subtype declaration that is an abbreviation of the
+         --  form subtype x is y, and if so generate the appropriate typedef
+
+         if Match (Line, G_Subtyp) then
+            Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
+
+         --  Otherwise the subtype must be declaring a subrange of Entity_Id
+
+         else
+            Must (Match (Line, Get_Styp));
+            Line := Getlin;
+            Must (Match (Line, Get_N1));
+
+            loop
+               Line := Get_Line (InF);
+               Lineno := Lineno + 1;
+               exit when not Match (Line, Get_N2);
+            end loop;
+
+            Must (Match (Line, Get_N3));
+            Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
+            Put_Line (Ofile, A & "   " & N1 & ", " & N3 & ')');
+            Put_Line (Ofile, "");
+         end if;
+
+
+      --  Case of type declaration
+
+      elsif Match (Line, F_Typ) then
+         --  Process type declaration (must be enumeration type)
+
+         Ctr := 0;
+         Put_Line (Ofile, A & "typedef int " & N & ';');
+
+         loop
+            Line := Getlin;
+            Must (Match (Line, Get_Nam));
+            Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
+            Ctr := Ctr + 1;
+            exit when Term /= ",";
+         end loop;
+
+         Put_Line (Ofile, "");
+
+      --  Neither subtype nor type declaration
+
+      else
+         raise Err;
+      end if;
+   end loop;
+
+   --  Process function declarations
+   --  Note: Lastinlined used to control blank lines
+
+   Put_Line (Ofile, "");
+   Lastinlined := True;
+
+   --  Loop through function declarations
+
+   while Match (Line, Get_FN) loop
+
+      --  Non-inlined funcion
+
+      if not Present (Inlined, FN) then
+         Put_Line (Ofile, "");
+         Put_Line
+           (Ofile,
+            "   #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
+
+      --  Inlined function
+
+      else
+         if not Lastinlined then
+            Put_Line (Ofile, "");
+         end if;
+      end if;
+
+      --  Merge here to output spec
+
+      Sethead (Line, ";");
+      Lastinlined := Get (Inlined, FN);
+      Line := Getlin;
+   end loop;
+
+   Put_Line (Ofile, "");
+
+   --  Read body to find inlined functions
+
+   Close (InB);
+   Close (InF);
+   Open (InF, In_File, "einfo.adb");
+   Lineno := 0;
+
+   --  Loop through input lines to find bodies of inlined functions
+
+   while not End_Of_File (InF) loop
+      Fline := Get_Line (InF);
+
+      if Match (Fline, Get_FN)
+        and then Get (Inlined, FN)
+      then
+         --  Here we have an inlined function
+
+         if not Match (Fline, Is_Rturn) then
+            Line := Fline;
+            Badfunc;
+         end if;
+
+         Line := Getlin;
+
+         if not Match (Line, Is_Begin) then
+            Badfunc;
+         end if;
+
+         --  Skip past pragma Asserts
+
+         loop
+            Line := Getlin;
+            exit when not Match (Line, Get_Asrt);
+
+            --  Pragma asser found, get its continuation lines
+
+            loop
+               exit when Match (Line, Semicoln);
+               Line := Getlin;
+            end loop;
+         end loop;
+
+         --  Process return statement
+
+         Match (Line, Get_Cmnt, M);
+         Replace (M, A);
+
+         --  Get continuations of return statemnt
+
+         while not Match (Line, Semicoln) loop
+            Nextlin := Getlin;
+            Match (Nextlin, wsp, " ");
+            Append (Line, Nextlin);
+         end loop;
+
+         if not Match (Line, Get_Expr) then
+            Badfunc;
+         end if;
+
+         Line := Getlin;
+
+         if not Match (Line, Chek_End) then
+            Badfunc;
+         end if;
+
+         Match (Expr, Get_B1, M);
+         Replace (M, "IN (" & A & ", " & B & ')');
+         Match (Expr, Get_B2, M);
+         Replace (M, A & " == " & B);
+         Match (Expr, Get_B3, M);
+         Replace (M, A & " != " & B);
+         Put_Line (Ofile, "");
+         Sethead (Fline, "");
+         Put_Line (Ofile, C & "   { return " & Expr & "; }");
+      end if;
+   end loop;
+
+   Put_Line (Ofile, "");
+   Put_Line
+     (Ofile,
+      "/* End of einfo.h (C version of Einfo package specification) */");
+
+exception
+   when Err =>
+      Put_Line (Standard_Error, Lineno & ".  " & Line);
+      Put_Line (Standard_Error, "**** fatal error ****");
+      Set_Exit_Status (1);
+
+   when End_Error =>
+      Put_Line (Standard_Error, "unexpected end of file");
+      Put_Line (Standard_Error, "**** fatal error ****");
+
+end XEinfo;

gcc/ada/xnmake.adb

@@ -0,0 +1,485 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                               X N M A K E                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.27 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Program to construct the spec and body of the Nmake package
+
+--    Input files:
+
+--       sinfo.ads     Spec of Sinfo package
+--       nmake.adt     Template for Nmake package
+
+--    Output files:
+
+--       nmake.ads     Spec of Nmake package
+--       nmake.adb     Body of Nmake package
+
+--  Note: this program assumes that sinfo.ads has passed the error checks that
+--  are carried out by the csinfo utility, so it does not duplicate these
+--  checks and assumes that sinfo.ads has the correct form.
+
+--   In the absence of any switches, both the ads and adb files are output.
+--   The switch -s or /s indicates that only the ads file is to be output.
+--   The switch -b or /b indicates that only the adb file is to be output.
+
+--   If a file name argument is given, then the output is written to this file
+--   rather than to nmake.ads or nmake.adb. A file name can only be given if
+--   exactly one of the -s or -b options is present.
+
+with Ada.Command_Line;              use Ada.Command_Line;
+with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Strings.Maps;              use Ada.Strings.Maps;
+with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
+with Ada.Text_IO;                   use Ada.Text_IO;
+
+with GNAT.Spitbol;                  use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
+
+procedure XNmake is
+
+   Err : exception;
+   --  Raised to terminate execution
+
+   A          : VString := Nul;
+   Arg        : VString := Nul;
+   Arg_List   : VString := Nul;
+   Comment    : VString := Nul;
+   Default    : VString := Nul;
+   Field      : VString := Nul;
+   Line       : VString := Nul;
+   Node       : VString := Nul;
+   Op_Name    : VString := Nul;
+   Prevl      : VString := Nul;
+   Sinfo_Rev  : VString := Nul;
+   Synonym    : VString := Nul;
+   Temp_Rev   : VString := Nul;
+   X          : VString := Nul;
+   XNmake_Rev : VString := Nul;
+
+   Lineno : Natural;
+   NWidth : Natural;
+
+   FileS : VString := V ("nmake.ads");
+   FileB : VString := V ("nmake.adb");
+   --  Set to null if corresponding file not to be generated
+
+   Given_File : VString := Nul;
+   --  File name given by command line argument
+
+   InS,  InT  : File_Type;
+   OutS, OutB : File_Type;
+
+   wsp   : Pattern := Span (' ' & ASCII.HT);
+
+   --  Note: in following patterns, we break up the word revision to
+   --  avoid RCS getting enthusiastic about updating the reference!
+
+   Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " &
+                           Break (' ') * Sinfo_Rev;
+
+   GetT_Rev : Pattern := BreakX ('$') & "$Rev" & "ision: " &
+                           Break (' ') * Temp_Rev;
+
+
+   Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "--  body only";
+   Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "--  spec only";
+
+   Node_Hdr  : Pattern := wsp & "--  N_" & Rest * Node;
+   Punc      : Pattern := BreakX (" .,");
+
+   Binop     : Pattern := wsp & "--  plus fields for binary operator";
+   Unop      : Pattern := wsp & "--  plus fields for unary operator";
+   Syn       : Pattern := wsp & "--  " & Break (' ') * Synonym
+                            & " (" & Break (')') * Field & Rest * Comment;
+
+   Templ     : Pattern := BreakX ('T') * A & "T e m p l a t e";
+   Spec      : Pattern := BreakX ('S') * A & "S p e c";
+
+   Sem_Field : Pattern := BreakX ('-') & "-Sem";
+   Lib_Field : Pattern := BreakX ('-') & "-Lib";
+
+   Get_Field : Pattern := BreakX (Decimal_Digit_Set) * Field;
+
+   Get_Dflt  : Pattern := BreakX ('(') & "(set to "
+                            & Break (" ") * Default & " if";
+
+   Next_Arg  : Pattern := Break (',') * Arg & ',';
+
+   Op_Node   : Pattern := "Op_" & Rest * Op_Name;
+
+   Shft_Rot  : Pattern := "Shift_" or "Rotate_";
+
+   No_Ent    : Pattern := "Or_Else" or "And_Then" or "In" or "Not_In";
+
+   M : Match_Result;
+
+   V_String_Id : constant VString := V ("String_Id");
+   V_Node_Id   : constant VString := V ("Node_Id");
+   V_Name_Id   : constant VString := V ("Name_Id");
+   V_List_Id   : constant VString := V ("List_Id");
+   V_Elist_Id  : constant VString := V ("Elist_Id");
+   V_Boolean   : constant VString := V ("Boolean");
+
+   procedure WriteS  (S : String);
+   procedure WriteB  (S : String);
+   procedure WriteBS (S : String);
+   procedure WriteS  (S : VString);
+   procedure WriteB  (S : VString);
+   procedure WriteBS (S : VString);
+   --  Write given line to spec or body file or both if active
+
+   procedure WriteB (S : String) is
+   begin
+      if FileB /= Nul then
+         Put_Line (OutB, S);
+      end if;
+   end WriteB;
+
+   procedure WriteB (S : VString) is
+   begin
+      if FileB /= Nul then
+         Put_Line (OutB, S);
+      end if;
+   end WriteB;
+
+   procedure WriteBS (S : String) is
+   begin
+      if FileB /= Nul then
+         Put_Line (OutB, S);
+      end if;
+
+      if FileS /= Nul then
+         Put_Line (OutS, S);
+      end if;
+   end WriteBS;
+
+   procedure WriteBS (S : VString) is
+   begin
+      if FileB /= Nul then
+         Put_Line (OutB, S);
+      end if;
+
+      if FileS /= Nul then
+         Put_Line (OutS, S);
+      end if;
+   end WriteBS;
+
+   procedure WriteS (S : String) is
+   begin
+      if FileS /= Nul then
+         Put_Line (OutS, S);
+      end if;
+   end WriteS;
+
+   procedure WriteS (S : VString) is
+   begin
+      if FileS /= Nul then
+         Put_Line (OutS, S);
+      end if;
+   end WriteS;
+
+--  Start of processing for XNmake
+
+begin
+   --  Capture our revision (following line updated by RCS)
+
+   Match ("$Revision: 1.27 $", "$Rev" & "ision: " & Break (' ') * XNmake_Rev);
+
+   Lineno := 0;
+   NWidth := 28;
+   Anchored_Mode := True;
+
+   for ArgN in 1 .. Argument_Count loop
+      declare
+         Arg : constant String := Argument (ArgN);
+
+      begin
+         if Arg (1) = '/' or else Arg (1) = '-' then
+            if Arg'Length = 2
+              and then (Arg (2) = 'b' or else Arg (2) = 'B')
+            then
+               FileS := Nul;
+
+            elsif Arg'Length = 2
+              and then (Arg (2) = 's' or else Arg (2) = 'S')
+            then
+               FileB := Nul;
+
+            else
+               raise Err;
+            end if;
+
+         else
+            if Given_File /= Nul then
+               raise Err;
+            else
+               Given_File := V (Arg);
+            end if;
+         end if;
+      end;
+   end loop;
+
+   if FileS = Nul and then FileB = Nul then
+      raise Err;
+
+   elsif Given_File /= Nul then
+      if FileS = Nul then
+         FileS := Given_File;
+
+      elsif FileB = Nul then
+         FileB := Given_File;
+
+      else
+         raise Err;
+      end if;
+   end if;
+
+   Open (InS, In_File, "sinfo.ads");
+   Open (InT, In_File, "nmake.adt");
+
+   if FileS /= Nul then
+      Create (OutS, Out_File, S (FileS));
+   end if;
+
+   if FileB /= Nul then
+      Create (OutB, Out_File, S (FileB));
+   end if;
+
+   Anchored_Mode := True;
+
+   --  Get Sinfo revision number
+
+   loop
+      Line := Get_Line (InS);
+      exit when Match (Line, Get_SRev);
+   end loop;
+
+   --  Copy initial part of template to spec and body
+
+   loop
+      Line := Get_Line (InT);
+
+      if Match (Line, GetT_Rev) then
+         WriteBS
+           ("--                 Generated by xnmake revision " &
+            XNmake_Rev & " using" &
+            "                  --");
+
+         WriteBS
+           ("--                         sinfo.ads revision " &
+            Sinfo_Rev &
+            "                         --");
+
+         WriteBS
+           ("--                         nmake.adt revision " &
+            Temp_Rev &
+            "                          --");
+
+      else
+         --  Skip lines describing the template
+
+         if Match (Line, "--  This file is a template") then
+            loop
+               Line := Get_Line (InT);
+               exit when Line = "";
+            end loop;
+         end if;
+
+         exit when Match (Line, "package");
+
+         if Match (Line, Body_Only, M) then
+            Replace (M, X);
+            WriteB (Line);
+
+         elsif Match (Line, Spec_Only, M) then
+            Replace (M, X);
+            WriteS (Line);
+
+         else
+            if Match (Line, Templ, M) then
+               Replace (M, A &  "    S p e c    ");
+            end if;
+
+            WriteS (Line);
+
+            if Match (Line, Spec, M) then
+               Replace (M, A &  "B o d y");
+            end if;
+
+            WriteB (Line);
+         end if;
+      end if;
+   end loop;
+
+   --  Package line reached
+
+   WriteS ("package Nmake is");
+   WriteB ("package body Nmake is");
+   WriteB ("");
+
+   --  Copy rest of lines up to template insert point to spec only
+
+   loop
+      Line := Get_Line (InT);
+      exit when Match (Line, "!!TEMPLATE INSERTION POINT");
+      WriteS (Line);
+   end loop;
+
+   --  Here we are doing the actual insertions, loop through node types
+
+   loop
+      Line := Get_Line (InS);
+
+      if Match (Line, Node_Hdr)
+        and then not Match (Node, Punc)
+        and then Node /= "Unused"
+      then
+         exit when Node = "Empty";
+         Prevl := "   function Make_" & Node & " (Sloc : Source_Ptr";
+         Arg_List := Nul;
+
+         --  Loop through fields of one node
+
+         loop
+            Line := Get_Line (InS);
+            exit when Line = "";
+
+            if Match (Line, Binop) then
+               WriteBS (Prevl & ';');
+               Append (Arg_List, "Left_Opnd,Right_Opnd,");
+               WriteBS (
+                 "      " & Rpad ("Left_Opnd",  NWidth) & " : Node_Id;");
+               Prevl :=
+                 "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
+
+            elsif Match (Line, Unop) then
+               WriteBS (Prevl & ';');
+               Append (Arg_List, "Right_Opnd,");
+               Prevl := "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
+
+            elsif Match (Line, Syn) then
+               if         Synonym /= "Prev_Ids"
+                 and then Synonym /= "More_Ids"
+                 and then Synonym /= "Comes_From_Source"
+                 and then Synonym /= "Paren_Count"
+                 and then not Match (Field, Sem_Field)
+                 and then not Match (Field, Lib_Field)
+               then
+                  Match (Field, Get_Field);
+
+                  if    Field = "Str"   then Field := V_String_Id;
+                  elsif Field = "Node"  then Field := V_Node_Id;
+                  elsif Field = "Name"  then Field := V_Name_Id;
+                  elsif Field = "List"  then Field := V_List_Id;
+                  elsif Field = "Elist" then Field := V_Elist_Id;
+                  elsif Field = "Flag"  then Field := V_Boolean;
+                  end if;
+
+                  if Field = "Boolean" then
+                     Default := V ("False");
+                  else
+                     Default := Nul;
+                  end if;
+
+                  Match (Comment, Get_Dflt);
+
+                  WriteBS (Prevl & ';');
+                  Append (Arg_List, Synonym & ',');
+                  Rpad (Synonym, NWidth);
+
+                  if Default = "" then
+                     Prevl := "      " & Synonym & " : " & Field;
+                  else
+                     Prevl :=
+                       "      " & Synonym & " : " & Field & " := " & Default;
+                  end if;
+               end if;
+            end if;
+         end loop;
+
+         WriteBS (Prevl & ')');
+         WriteS ("      return Node_Id;");
+         WriteS ("   pragma Inline (Make_" & Node & ");");
+         WriteB ("      return Node_Id");
+         WriteB ("   is");
+         WriteB ("      N : constant Node_Id :=");
+
+         if Match (Node, "Defining_Identifier") or else
+            Match (Node, "Defining_Character")  or else
+            Match (Node, "Defining_Operator")
+         then
+            WriteB ("            New_Entity (N_" & Node & ", Sloc);");
+         else
+            WriteB ("            New_Node (N_" & Node & ", Sloc);");
+         end if;
+
+         WriteB ("   begin");
+
+         while Match (Arg_List, Next_Arg, "") loop
+            if Length (Arg) < NWidth then
+               WriteB ("      Set_" & Arg & " (N, " & Arg & ");");
+            else
+               WriteB ("      Set_" & Arg);
+               WriteB ("        (N, " & Arg & ");");
+            end if;
+         end loop;
+
+         if Match (Node, Op_Node) then
+            if Node = "Op_Plus" then
+               WriteB ("      Set_Chars (N, Name_Op_Add);");
+
+            elsif Node = "Op_Minus" then
+               WriteB ("      Set_Chars (N, Name_Op_Subtract);");
+
+            elsif Match (Op_Name, Shft_Rot) then
+               WriteB ("      Set_Chars (N, Name_" & Op_Name & ");");
+
+            else
+               WriteB ("      Set_Chars (N, Name_" & Node & ");");
+            end if;
+
+            if not Match (Op_Name, No_Ent) then
+               WriteB ("      Set_Entity (N, Standard_" & Node & ");");
+            end if;
+         end if;
+
+         WriteB ("      return N;");
+         WriteB ("   end Make_" & Node & ';');
+         WriteBS ("");
+      end if;
+   end loop;
+
+   WriteBS ("end Nmake;");
+
+exception
+
+   when Err =>
+      Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
+      Set_Exit_Status (1);
+
+end XNmake;

gcc/ada/xr_tabls.ads

@@ -0,0 +1,384 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             X R  _ T A B L S                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.18 $
+--                                                                          --
+--         Copyright (C) 1998-2000 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.                                                      --
+--                                                                          --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Unbounded;
+
+package Xr_Tabls is
+
+   -------------------
+   -- Project files --
+   -------------------
+
+   function ALI_File_Name (Ada_File_Name : String) return String;
+   --  Returns the ali file name corresponding to Ada_File_Name, using the
+   --  information provided in gnat.adc if it exists
+
+   procedure Create_Project_File
+     (Name           : String);
+   --  Open and parse a new project file
+   --  If the file Name could not be open or is not a valid project file
+   --  then a project file associated with the standard default directories
+   --  is returned
+
+   function Find_ALI_File (Short_Name  : String) return String;
+   --  Returns the directory name for the file Short_Name
+   --  takes into account the obj_dir lines in the project file,
+   --  and the default paths for Gnat
+
+   function Find_Source_File (Short_Name  : String) return String;
+   --  Returns the directory name for the file Short_Name
+   --  takes into account the src_dir lines in the project file,
+   --  and the default paths for Gnat
+
+   function Next_Src_Dir return String;
+   --  Returns the next directory to visit to find related source files
+   --  If there are no more such directory, Length = 0
+
+   function Next_Obj_Dir return String;
+   --  Returns the next directory to visit to find related ali files
+   --  If there are no more such directory, Length = 0
+
+   function Current_Obj_Dir return String;
+   --  Returns the obj_dir which was returned by the last Next_Obj_Dir call
+
+   procedure Parse_Gnatls
+     (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
+      Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String);
+   --  Parse the output of Gnatls, to find the standard
+   --  directories for source files
+
+   procedure Reset_Src_Dir;
+   --  Reset the iterator for Src_Dir
+
+   procedure Reset_Obj_Dir;
+   --  Reset the iterator for Obj_Dir
+
+   ------------
+   -- Tables --
+   ------------
+
+   type Declaration_Reference is private;
+   Empty_Declaration : constant Declaration_Reference;
+
+   type File_Reference is private;
+   Empty_File : constant File_Reference;
+
+   type Reference is private;
+   Empty_Reference : constant Reference;
+
+   type File_Table is limited private;
+   type Entity_Table is limited private;
+
+   function Add_Declaration
+     (File_Ref  : File_Reference;
+      Symbol    : String;
+      Line      : Natural;
+      Column    : Natural;
+      Decl_Type : Character)
+      return      Declaration_Reference;
+   --  Add a new declaration in the table and return the index to it.
+   --  Decl_Type is the type of the entity
+
+   procedure Add_Parent
+     (Declaration : in out Declaration_Reference;
+      Symbol      : String;
+      Line        : Natural;
+      Column      : Natural;
+      File_Ref    : File_Reference);
+   --  The parent declaration (Symbol in file File_Ref at position Line and
+   --  Column) information is added to Declaration.
+
+   procedure Add_File
+     (File_Name    : String;
+      File_Existed : out Boolean;
+      Ref          : out File_Reference;
+      Visited      : Boolean := True;
+      Emit_Warning : Boolean := False;
+      Gnatchop_File : String := "";
+      Gnatchop_Offset : Integer := 0);
+   --  Add a new reference to a file in the table. Ref is used to return
+   --  the index in the table where this file is stored On exit,
+   --  File_Existed is True if the file was already in the table Visited is
+   --  the value which will be used in the table (if True, the file will
+   --  not be returned by Next_Unvisited_File). If Emit_Warning is True and
+   --  the ali file does not exist or does not have cross-referencing
+   --  informations, then a warning will be emitted.
+   --  Gnatchop_File is the name of the file that File_Name was extracted from
+   --  through a call to "gnatchop -r" (with pragma Source_Reference).
+   --  Gnatchop_Offset should be the index of the first line of File_Name
+   --  withing Gnatchop_File.
+
+   procedure Add_Line
+     (File   : File_Reference;
+      Line   : Natural;
+      Column : Natural);
+   --  Add a new reference in a file, which the user has provided
+   --  on the command line. This is used for a optimized matching
+   --  algorithm.
+
+   procedure Add_Reference
+     (Declaration : Declaration_Reference;
+      File_Ref    : File_Reference;
+      Line        : Natural;
+      Column      : Natural;
+      Ref_Type    : Character);
+   --  Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or
+   --  modification (Ref_Type = 'm') to an entity
+
+   type Compare_Result is (LessThan, Equal, GreaterThan);
+   function Compare (Ref1, Ref2 : Reference) return Compare_Result;
+   function Compare
+     (Decl1 : Declaration_Reference;
+      File2 : File_Reference;
+      Line2 : Integer;
+      Col2  : Integer;
+      Symb2 : String)
+      return  Compare_Result;
+   --  Compare two references
+
+   function First_Body (Decl : Declaration_Reference) return Reference;
+   function First_Declaration return Declaration_Reference;
+   function First_Modif  (Decl : Declaration_Reference) return Reference;
+   function First_Reference (Decl : Declaration_Reference) return Reference;
+   --  Initialize the iterators
+
+   function Get_Column (Decl : Declaration_Reference) return String;
+   function Get_Column (Ref : Reference) return String;
+
+   function Get_Declaration
+     (File_Ref : File_Reference;
+      Line     : Natural;
+      Column   : Natural)
+      return     Declaration_Reference;
+   --  Returns reference to the declaration found in file File_Ref at the
+   --  given Line and Column
+
+   function Get_Parent
+     (Decl : Declaration_Reference)
+     return Declaration_Reference;
+   --  Returns reference to Decl's parent declaration
+
+   function Get_Emit_Warning (File : File_Reference) return Boolean;
+   --  Returns the Emit_Warning field of the structure
+
+   function Get_Gnatchop_File
+     (File : File_Reference; With_Dir : Boolean := False) return String;
+   function Get_Gnatchop_File
+     (Ref : Reference; With_Dir : Boolean := False) return String;
+   function Get_Gnatchop_File
+     (Decl : Declaration_Reference; With_Dir : Boolean := False) return String;
+   --  Return the name of the file that File was extracted from through a
+   --  call to "gnatchop -r".
+   --  The file name for File is returned if File wasn't extracted from such a
+   --  file. The directory will be given only if With_Dir is True.
+
+
+   function Get_File
+     (Decl     : Declaration_Reference;
+      With_Dir : Boolean := False)
+      return     String;
+   --  Extract column number or file name from reference
+
+   function Get_File
+     (Ref      : Reference;
+      With_Dir : Boolean := False)
+      return     String;
+   pragma Inline (Get_File);
+
+   function Get_File
+     (File     : File_Reference;
+      With_Dir : Boolean := False;
+      Strip    : Natural := 0)
+     return     String;
+   --  Returns the file name (and its directory if With_Dir is True or
+   --  the user as used the -f switch on the command line.
+   --  If Strip is not 0, then the last Strip-th "-..." substrings are
+   --  removed first. For instance, with Strip=2, a file name
+   --  "parent-child1-child2-child3.ali" would be returned as
+   --  "parent-child1.ali". This is used when looking for the ALI file to use
+   --  for a package, since for separates with have to use the parent's ALI.
+   --
+   --  "" is returned if there is no such parent unit
+
+   function Get_File_Ref (Ref : Reference) return File_Reference;
+   function Get_Line (Decl : Declaration_Reference) return String;
+   function Get_Line (Ref : Reference) return String;
+   function Get_Symbol (Decl : Declaration_Reference) return String;
+   function Get_Type (Decl : Declaration_Reference) return Character;
+   --  Functions that return the content of a declaration
+
+   function Get_Source_Line (Ref : Reference) return String;
+   function Get_Source_Line (Decl : Declaration_Reference) return String;
+   --  Return the source line associated with the reference
+
+   procedure Grep_Source_Files;
+   --  Parse all the source files which have at least one reference, and
+   --  grep the appropriate lines so that we'll be able to display them.
+   --  This function should be called once all the .ali files have been
+   --  parsed, and only if the appropriate user switch has been used.
+
+   function Longest_File_Name return Natural;
+   --  Returns the longest file name found
+
+   function Match (Decl : Declaration_Reference) return Boolean;
+   --  Return True if the declaration matches
+
+   function Match
+     (File   : File_Reference;
+      Line   : Natural;
+      Column : Natural)
+      return   Boolean;
+   --  Returns True if File:Line:Column was given on the command line
+   --  by the user
+
+   function Next (Decl : Declaration_Reference) return Declaration_Reference;
+   function Next (Ref : Reference) return Reference;
+   --  Returns the next declaration, or Empty_Declaration
+
+   function Next_Unvisited_File return File_Reference;
+   --  Returns the next unvisited library file in the list
+   --  If there is no more unvisited file, return Empty_File
+
+   procedure Set_Default_Match (Value : Boolean);
+   --  Set the default value for match in declarations.
+   --  This is used so that if no file was provided in the
+   --  command line, then every file match
+
+   procedure Set_Directory
+     (File : File_Reference;
+      Dir  : String);
+   --  Set the directory for a file
+
+   procedure Set_Unvisited (File_Ref : in File_Reference);
+   --  Set File_Ref as unvisited. So Next_Unvisited_File will return it.
+
+
+private
+   type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record
+      Src_Dir : String (1 .. Src_Dir_Length);
+      Src_Dir_Index : Integer;
+
+      Obj_Dir            : String (1 .. Obj_Dir_Length);
+      Obj_Dir_Index      : Integer;
+      Last_Obj_Dir_Start : Natural;
+   end record;
+
+   type Project_File_Ptr is access all Project_File;
+   --  This is actually a list of all the directories to be searched,
+   --  either for source files or for library files
+
+   type String_Access is access all String;
+
+   type Ref_In_File;
+   type Ref_In_File_Ptr is access all Ref_In_File;
+
+   type Ref_In_File is record
+      Line   : Natural;
+      Column : Natural;
+      Next   : Ref_In_File_Ptr := null;
+   end record;
+
+   type File_Record;
+   type File_Reference is access all File_Record;
+
+   Empty_File : constant File_Reference := null;
+
+   type File_Record (File_Length : Natural) is record
+      File         : String (1 .. File_Length);
+      Dir          : String_Access   := null;
+      Lines        : Ref_In_File_Ptr := null;
+      Visited      : Boolean         := False;
+      Emit_Warning : Boolean         := False;
+      Gnatchop_File : String_Access  := null;
+      Gnatchop_Offset : Integer      := 0;
+      Next         : File_Reference  := null;
+   end record;
+   --  Holds a reference to a source file, that was referenced in at least one
+   --  ALI file.
+   --  Gnatchop_File will contain the name of the file that File was extracted
+   --  From. Gnatchop_Offset contains the index of the first line of File
+   --  within Gnatchop_File. These two fields are used to properly support
+   --  gnatchop files and pragma Source_Reference.
+
+
+   type Reference_Record;
+   type Reference is access all Reference_Record;
+
+   Empty_Reference : constant Reference := null;
+
+   type Reference_Record is record
+      File        : File_Reference;
+      Line        : Natural;
+      Column      : Natural;
+      Source_Line : Ada.Strings.Unbounded.Unbounded_String;
+      Next        : Reference := null;
+   end record;
+   --  File is a reference to the Ada source file
+   --  Source_Line is the Line as it appears in the source file. This
+   --  field is only used when the switch is set on the command line
+
+   type Declaration_Record;
+   type Declaration_Reference is access all Declaration_Record;
+
+   Empty_Declaration : constant Declaration_Reference := null;
+
+   type Declaration_Record (Symbol_Length : Natural) is record
+      Symbol     : String (1 .. Symbol_Length);
+      Decl       : aliased Reference_Record;
+      Decl_Type  : Character;
+      Body_Ref   : Reference := null;
+      Ref_Ref    : Reference := null;
+      Modif_Ref  : Reference := null;
+      Match      : Boolean := False;
+      Par_Symbol : Declaration_Reference := null;
+      Next       : Declaration_Reference := null;
+   end record;
+
+   type File_Table is record
+      Table        : File_Reference := null;
+      Longest_Name : Natural := 0;
+   end record;
+
+   type Entity_Table is record
+      Table : Declaration_Reference := null;
+   end record;
+
+   pragma Inline (First_Body);
+   pragma Inline (First_Declaration);
+   pragma Inline (First_Modif);
+   pragma Inline (First_Reference);
+   pragma Inline (Get_Column);
+   pragma Inline (Get_Emit_Warning);
+   pragma Inline (Get_File);
+   pragma Inline (Get_File_Ref);
+   pragma Inline (Get_Line);
+   pragma Inline (Get_Symbol);
+   pragma Inline (Get_Type);
+   pragma Inline (Longest_File_Name);
+   pragma Inline (Next);
+
+end Xr_Tabls;

gcc/ada/xref_lib.ads

@@ -0,0 +1,205 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              X R E F _ L I B                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.20 $
+--                                                                          --
+--       Copyright (C) 1998-1999 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.                                                      --
+--                                                                          --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Hostparm;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib;               use GNAT.OS_Lib;
+with GNAT.Dynamic_Tables;
+
+with Xr_Tabls;                  use Xr_Tabls;
+with GNAT.Regexp;               use GNAT.Regexp;
+
+--  Misc. utilities for the cross-referencing tool
+
+package Xref_Lib is
+
+   subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
+   subtype Line_String      is String (1 .. Hostparm.Max_Line_Length);
+
+   type ALI_File is limited private;
+
+   ---------------------
+   -- Directory Input --
+   ---------------------
+   type Rec_DIR is limited private;
+   --  This one is used for recursive search of .ali files
+
+   procedure Find_ALI_Files;
+   --  Find all the ali files that we will have to parse, and have them to
+   --  the file list
+
+   ---------------------
+   -- Search patterns --
+   ---------------------
+
+   type Search_Pattern is private;
+   type Search_Pattern_Ptr is access all Search_Pattern;
+
+   procedure Add_Entity
+     (Pattern : in out Search_Pattern;
+      Entity  : String;
+      Glob    : Boolean := False);
+   --  Add a new entity to the search pattern (the entity should have the
+   --  form pattern[:file[:line[:column]]], and it is parsed entirely in
+   --  this procedure. Glob indicates if we should use the 'globbing
+   --  patterns' (True) or the full regular expressions (False)
+
+   procedure Add_File (File : String);
+   --  Add a new file in the list of files to search for references.
+   --  File is considered to be a globbing regular expression, which is thus
+   --  expanded
+
+   Invalid_Argument : exception;
+   --  Exception raised when there is a syntax error in the command line
+
+   function Match
+     (Pattern : Search_Pattern;
+      Symbol  : String)
+      return    Boolean;
+   --  Returns true if Symbol matches one of the entities in the command line
+
+   -----------------------
+   -- Output Algorithms --
+   -----------------------
+
+   procedure Print_Gnatfind
+     (References     : in Boolean;
+      Full_Path_Name : in Boolean);
+   procedure Print_Unused (Full_Path_Name : in Boolean);
+   procedure Print_Vi (Full_Path_Name : in Boolean);
+   procedure Print_Xref (Full_Path_Name : in Boolean);
+   --  The actual print procedures. These functions step through the symbol
+   --  table and print all the symbols if they match the files given on the
+   --  command line (they already match the entities if they are in the
+   --  symbol table)
+
+   ------------------------
+   -- General Algorithms --
+   ------------------------
+   function Default_Project_File (Dir_Name : in String) return String;
+   --  Returns the default Project file name
+
+   procedure Search
+     (Pattern       : Search_Pattern;
+      Local_Symbols : Boolean;
+      Wide_Search   : Boolean;
+      Read_Only     : Boolean;
+      Der_Info      : Boolean;
+      Type_Tree     : Boolean);
+   --  Search every ali file (following the Readdir rule above), for
+   --  each line matching Pattern, and executes Process on these
+   --  lines. If World is True, Search will look into every .ali file
+   --  in the object search path. If Read_Only is True, we parse the
+   --  read-only ali files too. If Der_Mode is true then the derived type
+   --  information will be processed. If Type_Tree is true then the type
+   --  hierarchy will be search going from pattern to the parent type
+
+   procedure Search_Xref
+     (Local_Symbols : Boolean;
+      Read_Only     : Boolean;
+      Der_Info      : Boolean);
+   --  Search every ali file given in the command line and all their
+   --  dependencies. If Read_Only is True, we parse the read-only ali
+   --  files too. If Der_Mode is true then the derived type information will
+   --  be processed
+
+   ---------------
+   -- ALI files --
+   ---------------
+
+   function Current_Xref_File
+     (File : ALI_File)
+      return Xr_Tabls.File_Reference;
+   --  Returns the name of the file in which the last identifier
+   --  is declared
+
+   function File_Name
+     (File : ALI_File;
+      Num  : Positive)
+      return Xr_Tabls.File_Reference;
+   --  Returns the dependency file name number Num
+
+   function Get_Full_Type (Abbrev : Character) return String;
+   --  Returns the full type corresponding to a type letter as found in
+   --  the .ali files.
+
+   procedure Open
+     (Name         : in  String;
+      File         : out ALI_File;
+      Dependencies : in  Boolean := False);
+   --  Open a new ALI file
+   --  if Dependencies is True, the insert every library file 'with'ed in
+   --  the files database (used for gnatxref)
+
+
+private
+   type Rec_DIR is limited record
+      Dir : GNAT.Directory_Operations.Dir_Type;
+   end record;
+
+   package Dependencies_Tables is new GNAT.Dynamic_Tables
+     (Table_Component_Type => Xr_Tabls.File_Reference,
+      Table_Index_Type     => Positive,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 400,
+      Table_Increment      => 100);
+   use Dependencies_Tables;
+
+   type Dependencies is new Dependencies_Tables.Instance;
+
+   type ALI_File is limited record
+      Buffer         : String_Access := null;
+      --  Buffer used to read the whole file at once
+
+      Current_Line   : Positive;
+      --  Start of the current line in Buffer
+
+      Xref_Line      : Positive;
+      --  Start of the xref lines in Buffer
+
+      X_File         : Xr_Tabls.File_Reference;
+      --  Stores the cross-referencing file-name ("X..." lines), as an
+      --  index into the dependencies table
+
+      Dep : Dependencies;
+      --  Store file name associated with each number ("D..." lines)
+   end record;
+
+   --  The following record type stores all the patterns that are searched for
+
+   type Search_Pattern is record
+      Entity : GNAT.Regexp.Regexp;
+      --  A regular expression matching the entities we are looking for.
+      --  File is a list of the places where the declaration of the entities
+      --  has to be. When the user enters a file:line:column on the command
+      --  line, it is stored as "Entity_Name Declaration_File:line:column"
+
+      Initialized : Boolean := False;
+      --  Set to True when Entity has been initialized.
+   end record;
+   --  Stores all the pattern that are search for.
+end Xref_Lib;

gcc/ada/xsinfo.adb

@@ -0,0 +1,261 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                               X S I N F O                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-2000 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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Program to construct C header file a-sinfo.h (C version of sinfo.ads spec,
+--  for use by Gigi, contains all definitions and access functions, but does
+--  not contain set procedures, since Gigi never modifies the GNAT tree)
+
+--    Input files:
+
+--       sinfo.ads     Spec of Sinfo package
+
+--    Output files:
+
+--       a-sinfo.h     Corresponding c header file
+
+--  Note: this program assumes that sinfo.ads has passed the error checks
+--  which are carried out by the CSinfo utility, so it does not duplicate
+--  these checks and assumes the soruce is correct.
+
+--  An optional argument allows the specification of an output file name to
+--  override the default a-sinfo.h file name for the generated output file.
+
+with Ada.Command_Line;              use Ada.Command_Line;
+with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Text_IO;                   use Ada.Text_IO;
+
+with GNAT.Spitbol;                  use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
+
+procedure XSinfo is
+
+   Done : exception;
+   Err  : exception;
+
+   A         : VString := Nul;
+   Arg       : VString := Nul;
+   Comment   : VString := Nul;
+   Line      : VString := Nul;
+   N         : VString := Nul;
+   N1, N2    : VString := Nul;
+   Nam       : VString := Nul;
+   Rtn       : VString := Nul;
+   Sinforev  : VString := Nul;
+   Term      : VString := Nul;
+   XSinforev : VString := Nul;
+
+   InS       : File_Type;
+   Ofile     : File_Type;
+
+   wsp     : Pattern := Span (' ' & ASCII.HT);
+   Get_Vsn : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                          & Break (' ') * Sinforev;
+   Wsp_For : Pattern := wsp & "for";
+   Is_Cmnt : Pattern := wsp & "--";
+   Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
+   Get_Nam : Pattern := wsp * A & "N_" &  Break (",)") * Nam
+                          & Len (1) * Term;
+   Sub_Typ : Pattern := wsp * A & "subtype " &  Break (' ') * N;
+   No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
+   Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
+   Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
+   Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
+   Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
+                          & ") return " & Break (';') * Rtn
+                          & ';' & wsp & "--" & wsp & Rest * Comment;
+
+   NKV : Natural;
+
+   M : Match_Result;
+
+
+   procedure Getline;
+   --  Get non-comment, non-blank line. Also skips "for " rep clauses.
+
+   procedure Getline is
+   begin
+      loop
+         Line := Get_Line (InS);
+
+         if Line /= ""
+           and then not Match (Line, Wsp_For)
+           and then not Match (Line, Is_Cmnt)
+         then
+            return;
+
+         elsif Match (Line, "   --  End functions (note") then
+            raise Done;
+         end if;
+      end loop;
+   end Getline;
+
+--  Start of processing for XSinfo
+
+begin
+   Set_Exit_Status (1);
+   Anchored_Mode := True;
+   Match ("$Revision: 1.19 $", "$Rev" & "ision: "  & Break (' ') * XSinforev);
+
+   if Argument_Count > 0 then
+      Create (Ofile, Out_File, Argument (1));
+   else
+      Create (Ofile, Out_File, "a-sinfo.h");
+   end if;
+
+   Open (InS, In_File, "sinfo.ads");
+
+   --  Get Sinfo rev and write header to output file
+
+   loop
+      Line := Get_Line (InS);
+      exit when Line = "";
+
+      if Match (Line, Get_Vsn) then
+         Put_Line
+           (Ofile, "/*                 Generated by xsinfo revision "
+            & XSinforev & " using                  */");
+         Put_Line
+           (Ofile, "/*                         sinfo.ads revision "
+            & Sinforev & "                         */");
+
+      else
+         Match
+           (Line,
+            "--                                 S p e c       ",
+            "--                              C Header File    ");
+
+         Match (Line, "--", "/*");
+         Match (Line, Rtab (2) * A & "--", M);
+         Replace (M, A & "*/");
+         Put_Line (Ofile, Line);
+      end if;
+   end loop;
+
+   --  Skip to package line
+
+   loop
+      Getline;
+      exit when Match (Line, "package");
+   end loop;
+
+   --  Skip to first node kind line
+
+   loop
+      Getline;
+      exit when Match (Line, Typ_Nod);
+      Put_Line (Ofile, Line);
+   end loop;
+
+   Put_Line (Ofile, "");
+   NKV := 0;
+
+   --  Loop through node kind codes
+
+   loop
+      Getline;
+
+      if Match (Line, Get_Nam) then
+         Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
+         NKV := NKV + 1;
+         exit when not Match (Term, ",");
+
+      else
+         Put_Line (Ofile, Line);
+      end if;
+   end loop;
+
+   Put_Line (Ofile, "");
+   Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
+
+   --  Loop through subtype declarations
+
+   loop
+      Getline;
+
+      if not Match (Line, Sub_Typ) then
+         exit when Match (Line, "   function");
+         Put_Line (Ofile, Line);
+
+      else
+         Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
+         Getline;
+
+         --  Normal case
+
+         if Match (Line, No_Cont) then
+            Put_Line (Ofile, A & "   " & N1 & ", " & N2 & ')');
+
+         --  Continuation case
+
+         else
+            if not Match (Line, Cont_N1) then
+               raise Err;
+            end if;
+
+            Getline;
+
+            if not Match (Line, Cont_N2) then
+               raise Err;
+            end if;
+
+            Put_Line (Ofile,  A & "   " & N1 & ',');
+            Put_Line (Ofile,  A & "   " & N2 & ')');
+         end if;
+      end if;
+   end loop;
+
+   --  Loop through functions. Note that this loop is terminated by
+   --  the call to Getfile encountering the end of functions sentinel
+
+   loop
+      if Match (Line, Is_Func) then
+         Getline;
+            if not Match (Line, Get_Arg) then
+               raise Err;
+            end if;
+         Put_Line
+           (Ofile,
+            A &  "INLINE " & Rpad (Rtn, 9)
+            & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
+
+         Put_Line (Ofile,  A & "   { return " & Comment & " (N); }");
+
+      else
+         Put_Line (Ofile, Line);
+      end if;
+
+      Getline;
+   end loop;
+
+exception
+   when Done =>
+      Put_Line (Ofile, "");
+      Set_Exit_Status (0);
+
+end XSinfo;

gcc/ada/xtreeprs.adb

@@ -0,0 +1,383 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                             X T R E E P R S                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.33 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Program to construct the spec of the Treeprs package
+
+--    Input files:
+
+--       sinfo.ads     Spec of Sinfo package
+--       treeprs.adt   Template for Treeprs package
+
+--    Output files:
+
+--       treeprs.ads   Spec of Treeprs package
+
+--  Note: this program assumes that sinfo.ads has passed the error checks which
+--  are carried out by the CSinfo utility so it does not duplicate these checks
+
+--  An optional argument allows the specification of an output file name to
+--  override the default treeprs.ads file name for the generated output file.
+
+with Ada.Command_Line;              use Ada.Command_Line;
+with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Text_IO;                   use Ada.Text_IO;
+
+with GNAT.Spitbol;                  use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
+with GNAT.Spitbol.Table_Boolean;    use GNAT.Spitbol.Table_Boolean;
+with GNAT.Spitbol.Table_VString;    use GNAT.Spitbol.Table_VString;
+
+procedure XTreeprs is
+
+   package TB renames GNAT.Spitbol.Table_Boolean;
+   package TV renames GNAT.Spitbol.Table_VString;
+
+   Err : exception;
+   --  Raised on fatal error
+
+   A          : VString := Nul;
+   Ffield     : VString := Nul;
+   Field      : VString := Nul;
+   Fieldno    : VString := Nul;
+   Flagno     : VString := Nul;
+   Line       : VString := Nul;
+   Name       : VString := Nul;
+   Node       : VString := Nul;
+   Outstring  : VString := Nul;
+   Prefix     : VString := Nul;
+   S          : VString := Nul;
+   S1         : VString := Nul;
+   Sinforev   : VString := Nul;
+   Syn        : VString := Nul;
+   Synonym    : VString := Nul;
+   Temprev    : VString := Nul;
+   Term       : VString := Nul;
+   Treeprsrev : VString := Nul;
+
+   OutS : File_Type;
+   --  Output file
+
+   InS : File_Type;
+   --  Read sinfo.ads
+
+   InT : File_Type;
+   --  Read treeprs.adt
+
+   Special : TB.Table (20);
+   --  Table of special fields. These fields are not included in the table
+   --  constructed by Xtreeprs, since they are specially handled in treeprs.
+   --  This means these field definitions are completely ignored.
+
+   Names : array (1 .. 500) of VString;
+   --  Table of names of synonyms
+
+   Positions : array (1 .. 500) of Natural;
+   --  Table of starting positions in Pchars string for synonyms
+
+   Strings : TV.Table (300);
+   --  Contribution of each synonym to Pchars string, indexed by name
+
+   Count  : Natural := 0;
+   --  Number of synonyms processed so far
+
+   Curpos : Natural := 1;
+   --  Number of characters generated in Pchars string so far
+
+   Lineno : Natural := 0;
+   --  Line number in sinfo.ads
+
+   Field_Base : constant := Character'Pos ('#');
+   --  Fields 1-5 are represented by the characters #$%&' (i.e. by five
+   --  contiguous characters starting at # (16#23#)).
+
+   Flag_Base : constant := Character'Pos ('(');
+   --  Flags 1-18 are represented by the characters ()*+,-./0123456789
+   --  (i.e. by 18 contiguous characters starting at (16#28#)).
+
+   Fieldch : Character;
+   --  Field character, as per above tables
+
+   Sp : aliased Natural;
+   --  Space left on line for Pchars output
+
+   wsp : Pattern := Span (' ' & ASCII.HT);
+
+   Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                           & Break (' ') * Sinforev;
+   Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                           & Break (' ') * Temprev;
+   Is_Temp  : Pattern := BreakX ('T') * A & "T e m p l a t e";
+   Get_Node : Pattern := wsp & "--  N_" & Rest * Node;
+   Tst_Punc : Pattern := Break (" ,.");
+   Get_Syn  : Pattern := Span (' ') & "--  " & Break (' ') * Synonym
+                & " (" & Break (')') * Field;
+   Brk_Min  : Pattern := Break ('-') * Ffield;
+   Is_Flag  : Pattern := "Flag" & Rest * Flagno;
+   Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
+   Is_Syn   : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
+   Brk_Node : Pattern := Break (' ') * Node & ' ';
+   Chop_SP  : Pattern := Len (Sp'Unrestricted_Access) * S1;
+
+   M : Match_Result;
+
+begin
+   Anchored_Mode := True;
+
+   Match ("$Revision: 1.33 $", "$Rev" & "ision: " & Break (' ') * Treeprsrev);
+
+   if Argument_Count > 0 then
+      Create (OutS, Out_File, Argument (1));
+   else
+      Create (OutS, Out_File, "treeprs.ads");
+   end if;
+
+   Open (InS, In_File, "sinfo.ads");
+   Open (InT, In_File, "treeprs.adt");
+
+   --  Initialize special fields table
+
+   Set (Special, "Analyzed",                True);
+   Set (Special, "Cannot_Be_Constant",      True);
+   Set (Special, "Chars",                   True);
+   Set (Special, "Comes_From_Source",       True);
+   Set (Special, "Error_Posted",            True);
+   Set (Special, "Etype",                   True);
+   Set (Special, "Has_No_Side_Effects",     True);
+   Set (Special, "Is_Controlling_Actual",   True);
+   Set (Special, "Is_Overloaded",           True);
+   Set (Special, "Is_Static_Expression",    True);
+   Set (Special, "Left_Opnd",               True);
+   Set (Special, "Must_Check_Expr",         True);
+   Set (Special, "No_Overflow_Expr",        True);
+   Set (Special, "Paren_Count",             True);
+   Set (Special, "Raises_Constraint_Error", True);
+   Set (Special, "Right_Opnd",              True);
+
+   --  Get sinfo revs and write header to output file
+
+   loop
+      Line := Get_Line (InS);
+      Lineno := Lineno + 1;
+
+      if Line = "" then
+         raise Err;
+      end if;
+
+      exit when Match (Line, Get_SRev);
+   end loop;
+
+   --  Read template header and generate new header
+
+   loop
+      Line := Get_Line (InT);
+
+      if Match (Line, Get_TRev) then
+         Put_Line
+           (OutS,
+            "--                Generated by xtreeprs revision " &
+            Treeprsrev & " using                 --");
+
+         Put_Line
+           (OutS,
+            "--                         sinfo.ads revision " &
+            Sinforev & "                          --");
+
+         Put_Line
+           (OutS,
+            "--                        treeprs.adt revision "
+            & Temprev & "                          --");
+
+      else
+         --  Skip lines describing the template
+
+         if Match (Line, "--  This file is a template") then
+            loop
+               Line := Get_Line (InT);
+               exit when Line = "";
+            end loop;
+         end if;
+
+         exit when Match (Line, "package");
+
+         if Match (Line, Is_Temp, M) then
+            Replace (M, A & "    S p e c    ");
+         end if;
+
+         Put_Line (OutS, Line);
+      end if;
+   end loop;
+
+   Put_Line (OutS, Line);
+
+   --  Copy rest of comments up to template insert point to spec
+
+   loop
+      Line := Get_Line (InT);
+      exit when Match (Line, "!!TEMPLATE INSERTION POINT");
+      Put_Line (OutS, Line);
+   end loop;
+
+   --  Here we are doing the actual insertions
+
+   Put_Line (OutS, "   Pchars : constant String :=");
+
+   --  Loop through comments describing nodes, picking up fields
+
+   loop
+      Line := Get_Line (InS);
+      Lineno := Lineno + 1;
+      exit when Match (Line, "   type Node_Kind");
+
+      if Match (Line, Get_Node)
+        and then not Match (Node, Tst_Punc)
+      then
+         Outstring := Node & ' ';
+
+         loop
+            Line := Get_Line (InS);
+            exit when Line = "";
+
+            if Match (Line, Get_Syn)
+              and then not Match (Synonym, "plus")
+              and then not Present (Special, Synonym)
+            then
+               --  Convert this field into the character used to
+               --  represent the field according to the table:
+
+               --    Field1       '#'
+               --    Field2       '$'
+               --    Field3       '%'
+               --    Field4       '&'
+               --    Field5       "'"
+               --    Flag1        "("
+               --    Flag2        ")"
+               --    Flag3        '*'
+               --    Flag4        '+'
+               --    Flag5        ','
+               --    Flag6        '-'
+               --    Flag7        '.'
+               --    Flag8        '/'
+               --    Flag9        '0'
+               --    Flag10       '1'
+               --    Flag11       '2'
+               --    Flag12       '3'
+               --    Flag13       '4'
+               --    Flag14       '5'
+               --    Flag15       '6'
+               --    Flag16       '7'
+               --    Flag17       '8'
+               --    Flag18       '9'
+
+               if Match (Field, Brk_Min) then
+                  Field := Ffield;
+               end if;
+
+               if Match (Field, Is_Flag) then
+                  Fieldch := Char (Flag_Base - 1 + N (Flagno));
+
+               elsif Match (Field, Is_Field) then
+                  Fieldch := Char (Field_Base - 1 + N (Fieldno));
+
+               else
+                  Put_Line
+                    (Standard_Error,
+                     "*** Line " &
+                      Lineno &
+                      " has unrecognized field name " &
+                      Field);
+                  raise Err;
+               end if;
+
+               Append (Outstring, Fieldch & Synonym);
+            end if;
+         end loop;
+
+         Set (Strings, Node, Outstring);
+      end if;
+   end loop;
+
+   --  Loop through actual definitions of node kind enumeration literals
+
+   loop
+      loop
+         Line := Get_Line (InS);
+         Lineno := Lineno + 1;
+         exit when Match (Line, Is_Syn);
+      end loop;
+
+      S := Get (Strings, Syn);
+      Match (S, Brk_Node, "");
+      Count := Count + 1;
+      Names (Count) := Syn;
+      Positions (Count) := Curpos;
+      Curpos := Curpos + Length (S);
+      Put_Line (OutS, "      --  " & Node);
+      Prefix := V ("      ");
+      exit when Term = ")";
+
+      --  Loop to output the string literal for Pchars
+
+      loop
+         Sp := 79 - 4 - Length (Prefix);
+         exit when (Size (S) <= Sp);
+         Match (S, Chop_SP, "");
+         Put_Line (OutS, Prefix & '"' & S1 & """ &");
+         Prefix := V ("         ");
+      end loop;
+
+      Put_Line (OutS, Prefix & '"' & S & """ &");
+   end loop;
+
+   Put_Line (OutS, "      """";");
+   Put_Line (OutS, "");
+   Put_Line
+     (OutS, "   type Pchar_Pos_Array is array (Node_Kind) of Positive;");
+   Put_Line
+     (OutS,
+      "   Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
+
+   --  Output lines for Pchar_Pos_Array values
+
+   for M in 1 .. Count - 1 loop
+      Name := Rpad ("N_" & Names (M), 40);
+      Put_Line (OutS, "      " & Name & " => " & Positions (M) & ',');
+   end loop;
+
+   Name := Rpad ("N_" & Names (Count), 40);
+   Put_Line (OutS, "      " & Name & " => " & Positions (Count) & ");");
+
+   Put_Line (OutS, "");
+   Put_Line (OutS, "end Treeprs;");
+
+exception
+   when Err =>
+      Put_Line (Standard_Error, "*** fatal error");
+      Set_Exit_Status (1);
+
+end XTreeprs;