------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . A U X _ D E C                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2012, 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 Import (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 Import (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 Import (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 Import (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;