New Language: Ada

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

1 files changed, 709 insertions, 0 deletions

diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb
new file mode 100644
index 00000000000..e16cf6acbb0
--- /dev/null
+++ b/gcc/ada/s-auxdec.adb
@@ -0,0 +1,709 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                       S Y S T E M . A U X _ D E C                        --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.11 $
+--                                                                          --
+--          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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off alpha ordering check on subprograms, this unit is laid
+--  out to correspond to the declarations in the DEC 83 System unit.
+
+with System.Soft_Links;
+
+package body System.Aux_DEC is
+
+   package SSL renames System.Soft_Links;
+
+   -----------------------------------
+   -- Operations on Largest_Integer --
+   -----------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type LIU is mod 2 ** Largest_Integer'Size;
+   --  Unsigned type of same length as Largest_Integer
+
+   function To_LI   is new Unchecked_Conversion (LIU, Largest_Integer);
+   function From_LI is new Unchecked_Conversion (Largest_Integer, LIU);
+
+   function "not" (Left : Largest_Integer) return Largest_Integer is
+   begin
+      return To_LI (not From_LI (Left));
+   end "not";
+
+   function "and" (Left, Right : Largest_Integer) return Largest_Integer is
+   begin
+      return To_LI (From_LI (Left) and From_LI (Right));
+   end "and";
+
+   function "or"  (Left, Right : Largest_Integer) return Largest_Integer is
+   begin
+      return To_LI (From_LI (Left) or From_LI (Right));
+   end "or";
+
+   function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
+   begin
+      return To_LI (From_LI (Left) xor From_LI (Right));
+   end "xor";
+
+   --------------------------------------
+   -- Arithmetic Operations on Address --
+   --------------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   Asiz : constant Integer := Integer (Address'Size) - 1;
+
+   type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
+   --  Signed type of same size as Address
+
+   function To_A   is new Unchecked_Conversion (SA, Address);
+   function From_A is new Unchecked_Conversion (Address, SA);
+
+   function "+" (Left : Address; Right : Integer) return Address is
+   begin
+      return To_A (From_A (Left) + SA (Right));
+   end "+";
+
+   function "+" (Left : Integer; Right : Address) return Address is
+   begin
+      return To_A (SA (Left) + From_A (Right));
+   end "+";
+
+   function "-" (Left : Address; Right : Address) return Integer is
+      pragma Unsuppress (All_Checks);
+      --  Because this can raise Constraint_Error for 64-bit addresses
+
+   begin
+      return Integer (From_A (Left - Right));
+   end "-";
+
+   function "-" (Left : Address; Right : Integer) return Address is
+   begin
+      return To_A (From_A (Left) - SA (Right));
+   end "-";
+
+   ------------------------
+   -- Fetch_From_Address --
+   ------------------------
+
+   function Fetch_From_Address (A : Address) return Target is
+      type T_Ptr is access all Target;
+      function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
+      Ptr : constant T_Ptr := To_T_Ptr (A);
+
+   begin
+      return Ptr.all;
+   end Fetch_From_Address;
+
+   -----------------------
+   -- Assign_To_Address --
+   -----------------------
+
+   procedure Assign_To_Address (A : Address; T : Target) is
+      type T_Ptr is access all Target;
+      function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
+      Ptr : constant T_Ptr := To_T_Ptr (A);
+
+   begin
+      Ptr.all := T;
+   end Assign_To_Address;
+
+   ---------------------------------
+   -- Operations on Unsigned_Byte --
+   ---------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type BU is mod 2 ** Unsigned_Byte'Size;
+   --  Unsigned type of same length as Unsigned_Byte
+
+   function To_B   is new Unchecked_Conversion (BU, Unsigned_Byte);
+   function From_B is new Unchecked_Conversion (Unsigned_Byte, BU);
+
+   function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
+   begin
+      return To_B (not From_B (Left));
+   end "not";
+
+   function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
+   begin
+      return To_B (From_B (Left) and From_B (Right));
+   end "and";
+
+   function "or"  (Left, Right : Unsigned_Byte) return Unsigned_Byte is
+   begin
+      return To_B (From_B (Left) or From_B (Right));
+   end "or";
+
+   function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
+   begin
+      return To_B (From_B (Left) xor From_B (Right));
+   end "xor";
+
+   ---------------------------------
+   -- Operations on Unsigned_Word --
+   ---------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type WU is mod 2 ** Unsigned_Word'Size;
+   --  Unsigned type of same length as Unsigned_Word
+
+   function To_W   is new Unchecked_Conversion (WU, Unsigned_Word);
+   function From_W is new Unchecked_Conversion (Unsigned_Word, WU);
+
+   function "not" (Left : Unsigned_Word) return Unsigned_Word is
+   begin
+      return To_W (not From_W (Left));
+   end "not";
+
+   function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
+   begin
+      return To_W (From_W (Left) and From_W (Right));
+   end "and";
+
+   function "or"  (Left, Right : Unsigned_Word) return Unsigned_Word is
+   begin
+      return To_W (From_W (Left) or From_W (Right));
+   end "or";
+
+   function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
+   begin
+      return To_W (From_W (Left) xor From_W (Right));
+   end "xor";
+
+   -------------------------------------
+   -- Operations on Unsigned_Longword --
+   -------------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type LWU is mod 2 ** Unsigned_Longword'Size;
+   --  Unsigned type of same length as Unsigned_Longword
+
+   function To_LW   is new Unchecked_Conversion (LWU, Unsigned_Longword);
+   function From_LW is new Unchecked_Conversion (Unsigned_Longword, LWU);
+
+   function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
+   begin
+      return To_LW (not From_LW (Left));
+   end "not";
+
+   function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
+   begin
+      return To_LW (From_LW (Left) and From_LW (Right));
+   end "and";
+
+   function "or"  (Left, Right : Unsigned_Longword) return Unsigned_Longword is
+   begin
+      return To_LW (From_LW (Left) or From_LW (Right));
+   end "or";
+
+   function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
+   begin
+      return To_LW (From_LW (Left) xor From_LW (Right));
+   end "xor";
+
+   -------------------------------
+   -- Operations on Unsigned_32 --
+   -------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type U32 is mod 2 ** Unsigned_32'Size;
+   --  Unsigned type of same length as Unsigned_32
+
+   function To_U32   is new Unchecked_Conversion (U32, Unsigned_32);
+   function From_U32 is new Unchecked_Conversion (Unsigned_32, U32);
+
+   function "not" (Left : Unsigned_32) return Unsigned_32 is
+   begin
+      return To_U32 (not From_U32 (Left));
+   end "not";
+
+   function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
+   begin
+      return To_U32 (From_U32 (Left) and From_U32 (Right));
+   end "and";
+
+   function "or"  (Left, Right : Unsigned_32) return Unsigned_32 is
+   begin
+      return To_U32 (From_U32 (Left) or From_U32 (Right));
+   end "or";
+
+   function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
+   begin
+      return To_U32 (From_U32 (Left) xor From_U32 (Right));
+   end "xor";
+
+   -------------------------------------
+   -- Operations on Unsigned_Quadword --
+   -------------------------------------
+
+   --  It would be nice to replace these with intrinsics, but that does
+   --  not work yet (the back end would be ok, but GNAT itself objects)
+
+   type QWU is mod 2 ** 64;  -- 64 = Unsigned_Quadword'Size
+   --  Unsigned type of same length as Unsigned_Quadword
+
+   function To_QW   is new Unchecked_Conversion (QWU, Unsigned_Quadword);
+   function From_QW is new Unchecked_Conversion (Unsigned_Quadword, QWU);
+
+   function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
+   begin
+      return To_QW (not From_QW (Left));
+   end "not";
+
+   function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
+   begin
+      return To_QW (From_QW (Left) and From_QW (Right));
+   end "and";
+
+   function "or"  (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
+   begin
+      return To_QW (From_QW (Left) or From_QW (Right));
+   end "or";
+
+   function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
+   begin
+      return To_QW (From_QW (Left) xor From_QW (Right));
+   end "xor";
+
+   -----------------------
+   -- Clear_Interlocked --
+   -----------------------
+
+   procedure Clear_Interlocked
+     (Bit       : in out Boolean;
+      Old_Value : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := Bit;
+      Bit := False;
+      SSL.Unlock_Task.all;
+   end Clear_Interlocked;
+
+   procedure Clear_Interlocked
+     (Bit          : in out Boolean;
+      Old_Value    : out Boolean;
+      Retry_Count  : in Natural;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := Bit;
+      Bit := False;
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Clear_Interlocked;
+
+   ---------------------
+   -- Set_Interlocked --
+   ---------------------
+
+   procedure Set_Interlocked
+     (Bit       : in out Boolean;
+      Old_Value : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := Bit;
+      Bit := True;
+      SSL.Unlock_Task.all;
+   end Set_Interlocked;
+
+   procedure Set_Interlocked
+     (Bit          : in out Boolean;
+      Old_Value    : out Boolean;
+      Retry_Count  : in Natural;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := Bit;
+      Bit := True;
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Set_Interlocked;
+
+   ---------------------
+   -- Add_Interlocked --
+   ---------------------
+
+   procedure Add_Interlocked
+     (Addend       : in Short_Integer;
+      Augend       : in out Aligned_Word;
+      Sign         : out Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Augend.Value := Augend.Value + Addend;
+
+      if Augend.Value < 0 then
+         Sign := -1;
+      elsif Augend.Value > 0 then
+         Sign := +1;
+      else
+         Sign := 0;
+      end if;
+
+      SSL.Unlock_Task.all;
+   end Add_Interlocked;
+
+   ----------------
+   -- Add_Atomic --
+   ----------------
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Integer;
+      Amount       : in Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value := To.Value + Amount;
+      SSL.Unlock_Task.all;
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Integer;
+      Amount       : in Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := To.Value + Amount;
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Long_Integer;
+      Amount       : in Long_Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value := To.Value + Amount;
+      SSL.Unlock_Task.all;
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Long_Integer;
+      Amount       : in Long_Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := To.Value + Amount;
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Add_Atomic;
+
+   ----------------
+   -- And_Atomic --
+   ----------------
+
+   type IU is mod 2 ** Integer'Size;
+   type LU is mod 2 ** Long_Integer'Size;
+
+   function To_IU   is new Unchecked_Conversion (Integer, IU);
+   function From_IU is new Unchecked_Conversion (IU, Integer);
+
+   function To_LU   is new Unchecked_Conversion (Long_Integer, LU);
+   function From_LU is new Unchecked_Conversion (LU, Long_Integer);
+
+   procedure And_Atomic
+     (To           : in out Aligned_Integer;
+      From         : in Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value  := From_IU (To_IU (To.Value) and To_IU (From));
+      SSL.Unlock_Task.all;
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To           : in out Aligned_Integer;
+      From         : in Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := From_IU (To_IU (To.Value) and To_IU (From));
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : in Long_Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value  := From_LU (To_LU (To.Value) and To_LU (From));
+      SSL.Unlock_Task.all;
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : in Long_Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := From_LU (To_LU (To.Value) and To_LU (From));
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end And_Atomic;
+
+   ---------------
+   -- Or_Atomic --
+   ---------------
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Integer;
+      From         : in Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value  := From_IU (To_IU (To.Value) or To_IU (From));
+      SSL.Unlock_Task.all;
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Integer;
+      From         : in Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := From_IU (To_IU (To.Value) or To_IU (From));
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : in Long_Integer)
+   is
+   begin
+      SSL.Lock_Task.all;
+      To.Value  := From_LU (To_LU (To.Value) or To_LU (From));
+      SSL.Unlock_Task.all;
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : in Long_Integer;
+      Retry_Count  : in Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+   begin
+      SSL.Lock_Task.all;
+      Old_Value := To.Value;
+      To.Value  := From_LU (To_LU (To.Value) or To_LU (From));
+      Success_Flag := True;
+      SSL.Unlock_Task.all;
+   end Or_Atomic;
+
+   ------------------------------------
+   -- Declarations for Queue Objects --
+   ------------------------------------
+
+   type QR;
+
+   type QR_Ptr is access QR;
+
+   type QR is record
+      Forward  : QR_Ptr;
+      Backward : QR_Ptr;
+   end record;
+
+   function To_QR_Ptr   is new Unchecked_Conversion (Address, QR_Ptr);
+   function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
+
+   ------------
+   -- Insqhi --
+   ------------
+
+   procedure Insqhi
+     (Item   : in  Address;
+      Header : in  Address;
+      Status : out Insq_Status)
+   is
+      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
+      Next : constant QR_Ptr := Hedr.Forward;
+      Itm  : constant QR_Ptr := To_QR_Ptr (Item);
+
+   begin
+      SSL.Lock_Task.all;
+
+      Itm.Forward  := Next;
+      Itm.Backward := Hedr;
+      Hedr.Forward := Itm;
+
+      if Next = null then
+         Status := OK_First;
+
+      else
+         Next.Backward := Itm;
+         Status := OK_Not_First;
+      end if;
+
+      SSL.Unlock_Task.all;
+   end Insqhi;
+
+   ------------
+   -- Remqhi --
+   ------------
+
+   procedure Remqhi
+     (Header : in  Address;
+      Item   : out Address;
+      Status : out Remq_Status)
+   is
+      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
+      Next : constant QR_Ptr := Hedr.Forward;
+
+   begin
+      SSL.Lock_Task.all;
+
+      Item := From_QR_Ptr (Next);
+
+      if Next = null then
+         Status := Fail_Was_Empty;
+
+      else
+         Hedr.Forward := To_QR_Ptr (Item).Forward;
+
+         if Hedr.Forward = null then
+            Status := OK_Empty;
+
+         else
+            Hedr.Forward.Backward := Hedr;
+            Status := OK_Not_Empty;
+         end if;
+      end if;
+
+      SSL.Unlock_Task.all;
+   end Remqhi;
+
+   ------------
+   -- Insqti --
+   ------------
+
+   procedure Insqti
+     (Item   : in  Address;
+      Header : in  Address;
+      Status : out Insq_Status)
+   is
+      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
+      Prev : constant QR_Ptr := Hedr.Backward;
+      Itm  : constant QR_Ptr := To_QR_Ptr (Item);
+
+   begin
+      SSL.Lock_Task.all;
+
+      Itm.Backward  := Prev;
+      Itm.Forward   := Hedr;
+      Hedr.Backward := Itm;
+
+      if Prev = null then
+         Status := OK_First;
+
+      else
+         Prev.Forward := Itm;
+         Status := OK_Not_First;
+      end if;
+
+      SSL.Unlock_Task.all;
+   end Insqti;
+
+   ------------
+   -- Remqti --
+   ------------
+
+   procedure Remqti
+     (Header : in  Address;
+      Item   : out Address;
+      Status : out Remq_Status)
+   is
+      Hedr : constant QR_Ptr := To_QR_Ptr (Header);
+      Prev : constant QR_Ptr := Hedr.Backward;
+
+   begin
+      SSL.Lock_Task.all;
+
+      Item := From_QR_Ptr (Prev);
+
+      if Prev = null then
+         Status := Fail_Was_Empty;
+
+      else
+         Hedr.Backward := To_QR_Ptr (Item).Backward;
+
+         if Hedr.Backward = null then
+            Status := OK_Empty;
+
+         else
+            Hedr.Backward.Forward := Hedr;
+            Status := OK_Not_Empty;
+         end if;
+      end if;
+
+      SSL.Unlock_Task.all;
+   end Remqti;
+
+end System.Aux_DEC;