aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb')
-rw-r--r--gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb576
1 files changed, 576 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb b/gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb
new file mode 100644
index 000000000..b8ca67e85
--- /dev/null
+++ b/gcc-4.9/gcc/ada/s-auxdec-vms-ia64.adb
@@ -0,0 +1,576 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;