Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                       S Y S T E M . A U X _ D E C                        --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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 3,  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.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- 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 Ada.Unchecked_Conversion (LIU, Largest_Integer);

   function From_LI is new Ada.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 Ada.Unchecked_Conversion (SA, Address);

   function From_A is new Ada.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) - From_A (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 Ada.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 Ada.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 Ada.Unchecked_Conversion (BU, Unsigned_Byte);

   function From_B is new Ada.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 Ada.Unchecked_Conversion (WU, Unsigned_Word);

   function From_W is new Ada.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 Ada.Unchecked_Conversion (LWU, Unsigned_Longword);

   function From_LW is new Ada.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 Ada.Unchecked_Conversion (U32, Unsigned_32);

   function From_U32 is new Ada.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 Ada.Unchecked_Conversion (QWU, Unsigned_Quadword);

   function From_QW is new Ada.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  : 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  : 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 : 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 : 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       : Integer;

      Retry_Count  : 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 : 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       : Long_Integer;

      Retry_Count  : 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 Ada.Unchecked_Conversion (Integer, IU);

   function From_IU is new Ada.Unchecked_Conversion (IU, Integer);

   function To_LU   is new Ada.Unchecked_Conversion (Long_Integer, LU);

   function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer);

   procedure And_Atomic

     (To   : in out Aligned_Integer;

      From : 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         : Integer;

      Retry_Count  : 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 : 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         : Long_Integer;

      Retry_Count  : 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 : 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         : Integer;

      Retry_Count  : 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 : 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         : Long_Integer;

      Retry_Count  : 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 Ada.Unchecked_Conversion (Address, QR_Ptr);

   function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address);

   ------------

   -- Insqhi --

   ------------

   procedure Insqhi

     (Item   : Address;

      Header : 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 : 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   : Address;

      Header : 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 : 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;