path: root/gcc/ada/s-auxdec.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . A U X _ D E C                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          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. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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
      pragma Warnings (Off, Retry_Count);

   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;