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