diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/s-auxdec-vms-ia64.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/s-auxdec-vms-ia64.adb | 576 |
1 files changed, 0 insertions, 576 deletions
diff --git a/gcc-4.7/gcc/ada/s-auxdec-vms-ia64.adb b/gcc-4.7/gcc/ada/s-auxdec-vms-ia64.adb deleted file mode 100644 index 86bec06f2..000000000 --- a/gcc-4.7/gcc/ada/s-auxdec-vms-ia64.adb +++ /dev/null @@ -1,576 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |