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-2010, 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.      --
--                                                                          --
------------------------------------------------------------------------------
 
--  This is the Itanium/VMS version.
 
--  The Add,Clear_Interlocked subprograms are dubiously implmented due to
--  the lack of a single bit sync_lock_test_and_set builtin.
 
--  The "Retry" parameter is ignored due to the lack of retry builtins making
--  the subprograms identical to the non-retry versions.
 
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 Interfaces;
package body System.Aux_DEC is
 
   use type Interfaces.Unsigned_8;
 
   ------------------------
   -- 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;
 
   -----------------------
   -- Clear_Interlocked --
   -----------------------
 
   procedure Clear_Interlocked
     (Bit       : in out Boolean;
      Old_Value : out Boolean)
   is
      Clr_Bit : Boolean := Bit;
      Old_Uns : Interfaces.Unsigned_8;
 
      function Sync_Lock_Test_And_Set
        (Ptr   : Address;
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
                     "__sync_lock_test_and_set_1");
 
   begin
      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
      Bit := Clr_Bit;
      Old_Value := Old_Uns /= 0;
   end Clear_Interlocked;
 
   procedure Clear_Interlocked
     (Bit          : in out Boolean;
      Old_Value    : out Boolean;
      Retry_Count  : Natural;
      Success_Flag : out Boolean)
   is
      pragma Unreferenced (Retry_Count);
 
      Clr_Bit : Boolean := Bit;
      Old_Uns : Interfaces.Unsigned_8;
 
      function Sync_Lock_Test_And_Set
        (Ptr   : Address;
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
                     "__sync_lock_test_and_set_1");
 
   begin
      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
      Bit := Clr_Bit;
      Old_Value := Old_Uns /= 0;
      Success_Flag := True;
   end Clear_Interlocked;
 
   ---------------------
   -- Set_Interlocked --
   ---------------------
 
   procedure Set_Interlocked
     (Bit       : in out Boolean;
      Old_Value : out Boolean)
   is
      Set_Bit : Boolean := Bit;
      Old_Uns : Interfaces.Unsigned_8;
 
      function Sync_Lock_Test_And_Set
        (Ptr   : Address;
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
                     "__sync_lock_test_and_set_1");
 
   begin
      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
      Bit := Set_Bit;
      Old_Value := Old_Uns /= 0;
   end Set_Interlocked;
 
   procedure Set_Interlocked
     (Bit          : in out Boolean;
      Old_Value    : out Boolean;
      Retry_Count  : Natural;
      Success_Flag : out Boolean)
   is
      pragma Unreferenced (Retry_Count);
 
      Set_Bit : Boolean := Bit;
      Old_Uns : Interfaces.Unsigned_8;
 
      function Sync_Lock_Test_And_Set
        (Ptr   : Address;
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
                     "__sync_lock_test_and_set_1");
   begin
      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
      Bit := Set_Bit;
      Old_Value := Old_Uns /= 0;
      Success_Flag := True;
   end Set_Interlocked;
 
   ---------------------
   -- Add_Interlocked --
   ---------------------
 
   procedure Add_Interlocked
     (Addend : Short_Integer;
      Augend : in out Aligned_Word;
      Sign   : out Integer)
   is
      Overflowed : Boolean := False;
      Former     : Aligned_Word;
 
      function Sync_Fetch_And_Add
        (Ptr   : Address;
         Value : Short_Integer) return Short_Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
 
   begin
      Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
 
      if Augend.Value < 0 then
         Sign := -1;
      elsif Augend.Value > 0 then
         Sign := 1;
      else
         Sign := 0;
      end if;
 
      if Former.Value > 0 and then Augend.Value <= 0 then
         Overflowed := True;
      end if;
 
      if Overflowed then
         raise Constraint_Error;
      end if;
   end Add_Interlocked;
 
   ----------------
   -- Add_Atomic --
   ----------------
 
   procedure Add_Atomic
     (To     : in out Aligned_Integer;
      Amount : Integer)
   is
      procedure Sync_Add_And_Fetch
        (Ptr   : Address;
         Value : Integer);
      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
   begin
      Sync_Add_And_Fetch (To.Value'Address, Amount);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_Add
        (Ptr   : Address;
         Value : Integer) return Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
 
   begin
      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
      Success_Flag := True;
   end Add_Atomic;
 
   procedure Add_Atomic
     (To     : in out Aligned_Long_Integer;
      Amount : Long_Integer)
   is
      procedure Sync_Add_And_Fetch
        (Ptr   : Address;
         Value : Long_Integer);
      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
   begin
      Sync_Add_And_Fetch (To.Value'Address, Amount);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_Add
        (Ptr   : Address;
         Value : Long_Integer) return Long_Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
      --  Why do we keep importing this over and over again???
 
   begin
      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
      Success_Flag := True;
   end Add_Atomic;
 
   ----------------
   -- And_Atomic --
   ----------------
 
   procedure And_Atomic
     (To   : in out Aligned_Integer;
      From : Integer)
   is
      procedure Sync_And_And_Fetch
        (Ptr   : Address;
         Value : Integer);
      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
   begin
      Sync_And_And_Fetch (To.Value'Address, From);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_And
        (Ptr   : Address;
         Value : Integer) return Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
 
   begin
      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
      Success_Flag := True;
   end And_Atomic;
 
   procedure And_Atomic
     (To   : in out Aligned_Long_Integer;
      From : Long_Integer)
   is
      procedure Sync_And_And_Fetch
        (Ptr   : Address;
         Value : Long_Integer);
      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
   begin
      Sync_And_And_Fetch (To.Value'Address, From);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_And
        (Ptr   : Address;
         Value : Long_Integer) return Long_Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
 
   begin
      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
      Success_Flag := True;
   end And_Atomic;
 
   ---------------
   -- Or_Atomic --
   ---------------
 
   procedure Or_Atomic
     (To   : in out Aligned_Integer;
      From : Integer)
   is
      procedure Sync_Or_And_Fetch
        (Ptr   : Address;
         Value : Integer);
      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
 
   begin
      Sync_Or_And_Fetch (To.Value'Address, From);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_Or
        (Ptr   : Address;
         Value : Integer) return Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
 
   begin
      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
      Success_Flag := True;
   end Or_Atomic;
 
   procedure Or_Atomic
     (To   : in out Aligned_Long_Integer;
      From : Long_Integer)
   is
      procedure Sync_Or_And_Fetch
        (Ptr   : Address;
         Value : Long_Integer);
      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
   begin
      Sync_Or_And_Fetch (To.Value'Address, From);
   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 Unreferenced (Retry_Count);
 
      function Sync_Fetch_And_Or
        (Ptr   : Address;
         Value : Long_Integer) return Long_Integer;
      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
 
   begin
      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
      Success_Flag := True;
   end Or_Atomic;
 
   ------------
   -- Insqhi --
   ------------
 
   procedure Insqhi
     (Item   : Address;
      Header : Address;
      Status : out Insq_Status) is
 
      procedure SYS_PAL_INSQHIL
        (STATUS : out Integer; Header : Address; ITEM : Address);
      pragma Interface (External, SYS_PAL_INSQHIL);
      pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
         (Integer, Address, Address),
         (Value, Value, Value));
 
      Istat : Integer;
 
   begin
      SYS_PAL_INSQHIL (Istat, Header, Item);
 
      if Istat = 0 then
         Status := OK_Not_First;
      elsif Istat = 1 then
         Status := OK_First;
 
      else
         --  This status is never returned on IVMS
 
         Status := Fail_No_Lock;
      end if;
   end Insqhi;
 
   ------------
   -- Remqhi --
   ------------
 
   procedure Remqhi
     (Header : Address;
      Item   : out Address;
      Status : out Remq_Status)
   is
      --  The removed item is returned in the second function return register,
      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
      --  these registers, so inventing this odd looking record type makes that
      --  all work.
 
      type Remq is record
         Status : Long_Integer;
         Item   : Address;
      end record;
 
      procedure SYS_PAL_REMQHIL
        (Remret : out Remq; Header : Address);
      pragma Interface (External, SYS_PAL_REMQHIL);
      pragma Import_Valued_Procedure
        (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
         (Remq, Address),
         (Value, Value));
 
      --  Following variables need documentation???
 
      Rstat  : Long_Integer;
      Remret : Remq;
 
   begin
      SYS_PAL_REMQHIL (Remret, Header);
 
      Rstat := Remret.Status;
      Item := Remret.Item;
 
      if Rstat = 0 then
         Status := Fail_Was_Empty;
 
      elsif Rstat = 1 then
         Status := OK_Not_Empty;
 
      elsif Rstat = 2 then
         Status := OK_Empty;
 
      else
         --  This status is never returned on IVMS
 
         Status := Fail_No_Lock;
      end if;
 
   end Remqhi;
 
   ------------
   -- Insqti --
   ------------
 
   procedure Insqti
     (Item   : Address;
      Header : Address;
      Status : out Insq_Status) is
 
      procedure SYS_PAL_INSQTIL
        (STATUS : out Integer; Header : Address; ITEM : Address);
      pragma Interface (External, SYS_PAL_INSQTIL);
      pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
         (Integer, Address, Address),
         (Value, Value, Value));
 
      Istat : Integer;
 
   begin
      SYS_PAL_INSQTIL (Istat, Header, Item);
 
      if Istat = 0 then
         Status := OK_Not_First;
 
      elsif Istat = 1 then
         Status := OK_First;
 
      else
         --  This status is never returned on IVMS
 
         Status := Fail_No_Lock;
      end if;
   end Insqti;
 
   ------------
   -- Remqti --
   ------------
 
   procedure Remqti
     (Header : Address;
      Item   : out Address;
      Status : out Remq_Status)
   is
      --  The removed item is returned in the second function return register,
      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
      --  these registers, so inventing (where is rest of this comment???)
 
      type Remq is record
         Status : Long_Integer;
         Item   : Address;
      end record;
 
      procedure SYS_PAL_REMQTIL
        (Remret : out Remq; Header : Address);
      pragma Interface (External, SYS_PAL_REMQTIL);
      pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
         (Remq, Address),
         (Value, Value));
 
      Rstat  : Long_Integer;
      Remret : Remq;
 
   begin
      SYS_PAL_REMQTIL (Remret, Header);
 
      Rstat := Remret.Status;
      Item := Remret.Item;
 
      --  Wouldn't case be nicer here, and in previous similar cases ???
 
      if Rstat = 0 then
         Status := Fail_Was_Empty;
 
      elsif Rstat = 1 then
         Status := OK_Not_Empty;
 
      elsif Rstat = 2 then
         Status := OK_Empty;
      else
         --  This status is never returned on IVMS
 
         Status := Fail_No_Lock;
      end if;
   end Remqti;
 
end System.Aux_DEC;