URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-auxdec-vms-ia64.adb] - Rev 718
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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;
Go to most recent revision | Compare with Previous | Blame | View Log