[thirdparty/gcc.git] / gcc / ada / s-auxdec-vms-ia64.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . A U X _ D E C                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2011, 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;
Commit	Line	Data
23d9fef2	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT COMPILER COMPONENTS --
	4	-- --
	5	-- S Y S T E M . A U X _ D E C --
	6	-- --
	7	-- B o d y --
	8	-- --
71e45bc2	9	-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
23d9fef2	10	-- --
	11	-- GNAT is free software; you can redistribute it and/or modify it under --
	12	-- terms of the GNU General Public License as published by the Free Soft- --
	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
	16	-- or FITNESS FOR A PARTICULAR PURPOSE. --
	17	-- --
	18	-- As a special exception under Section 7 of GPL version 3, you are granted --
	19	-- additional permissions described in the GCC Runtime Library Exception, --
	20	-- version 3.1, as published by the Free Software Foundation. --
	21	-- --
	22	-- You should have received a copy of the GNU General Public License and --
	23	-- a copy of the GCC Runtime Library Exception along with this program; --
	24	-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
	25	-- <http://www.gnu.org/licenses/>. --
	26	-- --
	27	-- GNAT was originally developed by the GNAT team at New York University. --
	28	-- Extensive contributions were provided by Ada Core Technologies Inc. --
	29	-- --
	30	------------------------------------------------------------------------------
	31
	32	-- This is the Itanium/VMS version.
	33
	34	-- The Add,Clear_Interlocked subprograms are dubiously implmented due to
	35	-- the lack of a single bit sync_lock_test_and_set builtin.
	36
	37	-- The "Retry" parameter is ignored due to the lack of retry builtins making
	38	-- the subprograms identical to the non-retry versions.
	39
	40	pragma Style_Checks (All_Checks);
	41	-- Turn off alpha ordering check on subprograms, this unit is laid
	42	-- out to correspond to the declarations in the DEC 83 System unit.
	43
	44	with Interfaces;
	45	package body System.Aux_DEC is
	46
	47	use type Interfaces.Unsigned_8;
	48
	49	------------------------
	50	-- Fetch_From_Address --
	51	------------------------
	52
	53	function Fetch_From_Address (A : Address) return Target is
	54	type T_Ptr is access all Target;
	55	function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
	56	Ptr : constant T_Ptr := To_T_Ptr (A);
	57	begin
	58	return Ptr.all;
	59	end Fetch_From_Address;
	60
	61	-----------------------
	62	-- Assign_To_Address --
	63	-----------------------
	64
	65	procedure Assign_To_Address (A : Address; T : Target) is
	66	type T_Ptr is access all Target;
	67	function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
	68	Ptr : constant T_Ptr := To_T_Ptr (A);
	69	begin
	70	Ptr.all := T;
	71	end Assign_To_Address;
	72
	73	-----------------------
74	-- Clear_Interlocked --
75	-----------------------
76
77	procedure Clear_Interlocked
78	(Bit : in out Boolean;
79	Old_Value : out Boolean)
80	is
81	Clr_Bit : Boolean := Bit;
82	Old_Uns : Interfaces.Unsigned_8;
83
84	function Sync_Lock_Test_And_Set
85	(Ptr : Address;
86	Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
87	pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
88	"__sync_lock_test_and_set_1");
89
90	begin
91	Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
92	Bit := Clr_Bit;
93	Old_Value := Old_Uns /= 0;
94	end Clear_Interlocked;
95
96	procedure Clear_Interlocked
97	(Bit : in out Boolean;
98	Old_Value : out Boolean;
99	Retry_Count : Natural;
100	Success_Flag : out Boolean)
101	is
102	pragma Unreferenced (Retry_Count);
103
104	Clr_Bit : Boolean := Bit;
105	Old_Uns : Interfaces.Unsigned_8;
106
107	function Sync_Lock_Test_And_Set
108	(Ptr : Address;
109	Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
110	pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
111	"__sync_lock_test_and_set_1");
112
113	begin
114	Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
115	Bit := Clr_Bit;
116	Old_Value := Old_Uns /= 0;
117	Success_Flag := True;
118	end Clear_Interlocked;
119
120	---------------------
121	-- Set_Interlocked --
122	---------------------
123
124	procedure Set_Interlocked
125	(Bit : in out Boolean;
126	Old_Value : out Boolean)
127	is
128	Set_Bit : Boolean := Bit;
129	Old_Uns : Interfaces.Unsigned_8;
130
131	function Sync_Lock_Test_And_Set
132	(Ptr : Address;
133	Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
134	pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
135	"__sync_lock_test_and_set_1");
136
137	begin
138	Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
139	Bit := Set_Bit;
140	Old_Value := Old_Uns /= 0;
141	end Set_Interlocked;
142
143	procedure Set_Interlocked
144	(Bit : in out Boolean;
145	Old_Value : out Boolean;
146	Retry_Count : Natural;
147	Success_Flag : out Boolean)
148	is
149	pragma Unreferenced (Retry_Count);
150
151	Set_Bit : Boolean := Bit;
152	Old_Uns : Interfaces.Unsigned_8;
153
154	function Sync_Lock_Test_And_Set
155	(Ptr : Address;
156	Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
157	pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
158	"__sync_lock_test_and_set_1");
159	begin
160	Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
161	Bit := Set_Bit;
162	Old_Value := Old_Uns /= 0;
163	Success_Flag := True;
164	end Set_Interlocked;
165
166	---------------------
167	-- Add_Interlocked --
168	---------------------
169
170	procedure Add_Interlocked
171	(Addend : Short_Integer;
172	Augend : in out Aligned_Word;
173	Sign : out Integer)
174	is
175	Overflowed : Boolean := False;
176	Former : Aligned_Word;
177
178	function Sync_Fetch_And_Add
179	(Ptr : Address;
180	Value : Short_Integer) return Short_Integer;
181	pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
182
183	begin
184	Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
185
186	if Augend.Value < 0 then
187	Sign := -1;
188	elsif Augend.Value > 0 then
189	Sign := 1;
190	else
191	Sign := 0;
192	end if;
193
194	if Former.Value > 0 and then Augend.Value <= 0 then
195	Overflowed := True;
196	end if;
197
198	if Overflowed then
199	raise Constraint_Error;
200	end if;
201	end Add_Interlocked;
202
203	----------------
204	-- Add_Atomic --
205	----------------
206
207	procedure Add_Atomic
208	(To : in out Aligned_Integer;
209	Amount : Integer)
210	is
211	procedure Sync_Add_And_Fetch
212	(Ptr : Address;
213	Value : Integer);
214	pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
215	begin
216	Sync_Add_And_Fetch (To.Value'Address, Amount);
217	end Add_Atomic;
218
219	procedure Add_Atomic
220	(To : in out Aligned_Integer;
221	Amount : Integer;
222	Retry_Count : Natural;
223	Old_Value : out Integer;
224	Success_Flag : out Boolean)
225	is
226	pragma Unreferenced (Retry_Count);
227
228	function Sync_Fetch_And_Add
229	(Ptr : Address;
230	Value : Integer) return Integer;
231	pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
232
233	begin
234	Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
235	Success_Flag := True;
236	end Add_Atomic;
237
238	procedure Add_Atomic
239	(To : in out Aligned_Long_Integer;
240	Amount : Long_Integer)
241	is
242	procedure Sync_Add_And_Fetch
243	(Ptr : Address;
244	Value : Long_Integer);
245	pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
246	begin
247	Sync_Add_And_Fetch (To.Value'Address, Amount);
248	end Add_Atomic;
249
250	procedure Add_Atomic
251	(To : in out Aligned_Long_Integer;
252	Amount : Long_Integer;
253	Retry_Count : Natural;
254	Old_Value : out Long_Integer;
255	Success_Flag : out Boolean)
256	is
257	pragma Unreferenced (Retry_Count);
258
259	function Sync_Fetch_And_Add
260	(Ptr : Address;
261	Value : Long_Integer) return Long_Integer;
262	pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
263	-- Why do we keep importing this over and over again???
264
265	begin
266	Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
267	Success_Flag := True;
268	end Add_Atomic;
269
270	----------------
271	-- And_Atomic --
272	----------------
273
274	procedure And_Atomic
275	(To : in out Aligned_Integer;
276	From : Integer)
277	is
278	procedure Sync_And_And_Fetch
279	(Ptr : Address;
280	Value : Integer);
281	pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
282	begin
283	Sync_And_And_Fetch (To.Value'Address, From);
284	end And_Atomic;
285
286	procedure And_Atomic
287	(To : in out Aligned_Integer;
288	From : Integer;
289	Retry_Count : Natural;
290	Old_Value : out Integer;
291	Success_Flag : out Boolean)
292	is
293	pragma Unreferenced (Retry_Count);
294
295	function Sync_Fetch_And_And
296	(Ptr : Address;
297	Value : Integer) return Integer;
298	pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
299
300	begin
301	Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
302	Success_Flag := True;
303	end And_Atomic;
304
305	procedure And_Atomic
306	(To : in out Aligned_Long_Integer;
307	From : Long_Integer)
308	is
309	procedure Sync_And_And_Fetch
310	(Ptr : Address;
311	Value : Long_Integer);
312	pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
313	begin
314	Sync_And_And_Fetch (To.Value'Address, From);
315	end And_Atomic;
316
317	procedure And_Atomic
318	(To : in out Aligned_Long_Integer;
319	From : Long_Integer;
320	Retry_Count : Natural;
321	Old_Value : out Long_Integer;
322	Success_Flag : out Boolean)
323	is
324	pragma Unreferenced (Retry_Count);
325
326	function Sync_Fetch_And_And
327	(Ptr : Address;
328	Value : Long_Integer) return Long_Integer;
329	pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
330
331	begin
332	Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
333	Success_Flag := True;
334	end And_Atomic;
335
336	---------------
337	-- Or_Atomic --
338	---------------
339
340	procedure Or_Atomic
341	(To : in out Aligned_Integer;
342	From : Integer)
343	is
344	procedure Sync_Or_And_Fetch
345	(Ptr : Address;
346	Value : Integer);
347	pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
348
349	begin
350	Sync_Or_And_Fetch (To.Value'Address, From);
351	end Or_Atomic;
352
353	procedure Or_Atomic
354	(To : in out Aligned_Integer;
355	From : Integer;
356	Retry_Count : Natural;
357	Old_Value : out Integer;
358	Success_Flag : out Boolean)
359	is
360	pragma Unreferenced (Retry_Count);
361
362	function Sync_Fetch_And_Or
363	(Ptr : Address;
364	Value : Integer) return Integer;
365	pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
366
367	begin
368	Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
369	Success_Flag := True;
370	end Or_Atomic;
371
372	procedure Or_Atomic
373	(To : in out Aligned_Long_Integer;
374	From : Long_Integer)
375	is
376	procedure Sync_Or_And_Fetch
377	(Ptr : Address;
378	Value : Long_Integer);
379	pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
380	begin
381	Sync_Or_And_Fetch (To.Value'Address, From);
382	end Or_Atomic;
383
384	procedure Or_Atomic
385	(To : in out Aligned_Long_Integer;
386	From : Long_Integer;
387	Retry_Count : Natural;
388	Old_Value : out Long_Integer;
389	Success_Flag : out Boolean)
390	is
391	pragma Unreferenced (Retry_Count);
392
393	function Sync_Fetch_And_Or
394	(Ptr : Address;
395	Value : Long_Integer) return Long_Integer;
396	pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
397
398	begin
399	Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
400	Success_Flag := True;
401	end Or_Atomic;
402
403	------------
404	-- Insqhi --
405	------------
406
407	procedure Insqhi
408	(Item : Address;
409	Header : Address;
410	Status : out Insq_Status) is
411
412	procedure SYS_PAL_INSQHIL
413	(STATUS : out Integer; Header : Address; ITEM : Address);
414	pragma Interface (External, SYS_PAL_INSQHIL);
415	pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
416	(Integer, Address, Address),
417	(Value, Value, Value));
418
419	Istat : Integer;
420
421	begin
422	SYS_PAL_INSQHIL (Istat, Header, Item);
423
424	if Istat = 0 then
425	Status := OK_Not_First;
426	elsif Istat = 1 then
427	Status := OK_First;
428
429	else
430	-- This status is never returned on IVMS
431
432	Status := Fail_No_Lock;
433	end if;
434	end Insqhi;
435
436	------------
437	-- Remqhi --
438	------------
439
440	procedure Remqhi
441	(Header : Address;
442	Item : out Address;
443	Status : out Remq_Status)
444	is
445	-- The removed item is returned in the second function return register,
446	-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
447	-- these registers, so inventing this odd looking record type makes that
448	-- all work.
449
450	type Remq is record
451	Status : Long_Integer;
452	Item : Address;
453	end record;
454
455	procedure SYS_PAL_REMQHIL
456	(Remret : out Remq; Header : Address);
457	pragma Interface (External, SYS_PAL_REMQHIL);
458	pragma Import_Valued_Procedure
459	(SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
460	(Remq, Address),
461	(Value, Value));
462
463	-- Following variables need documentation???
464
465	Rstat : Long_Integer;
466	Remret : Remq;
467
468	begin
469	SYS_PAL_REMQHIL (Remret, Header);
470
471	Rstat := Remret.Status;
472	Item := Remret.Item;
473
474	if Rstat = 0 then
475	Status := Fail_Was_Empty;
476
477	elsif Rstat = 1 then
478	Status := OK_Not_Empty;
479
480	elsif Rstat = 2 then
481	Status := OK_Empty;
482
483	else
484	-- This status is never returned on IVMS
485
486	Status := Fail_No_Lock;
487	end if;
488
489	end Remqhi;
490
491	------------
492	-- Insqti --
493	------------
494
495	procedure Insqti
496	(Item : Address;
497	Header : Address;
498	Status : out Insq_Status) is
499
500	procedure SYS_PAL_INSQTIL
501	(STATUS : out Integer; Header : Address; ITEM : Address);
502	pragma Interface (External, SYS_PAL_INSQTIL);
503	pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
504	(Integer, Address, Address),
505	(Value, Value, Value));
506
507	Istat : Integer;
508
509	begin
510	SYS_PAL_INSQTIL (Istat, Header, Item);
511
512	if Istat = 0 then
513	Status := OK_Not_First;
514
515	elsif Istat = 1 then
516	Status := OK_First;
517
518	else
519	-- This status is never returned on IVMS
520
521	Status := Fail_No_Lock;
522	end if;
523	end Insqti;
524
525	------------
526	-- Remqti --
527	------------
528
529	procedure Remqti
530	(Header : Address;
531	Item : out Address;
532	Status : out Remq_Status)
533	is
534	-- The removed item is returned in the second function return register,
535	-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
536	-- these registers, so inventing (where is rest of this comment???)
537
538	type Remq is record
539	Status : Long_Integer;
540	Item : Address;
541	end record;
542
543	procedure SYS_PAL_REMQTIL
544	(Remret : out Remq; Header : Address);
545	pragma Interface (External, SYS_PAL_REMQTIL);
546	pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
547	(Remq, Address),
548	(Value, Value));
549
550	Rstat : Long_Integer;
551	Remret : Remq;
552
553	begin
554	SYS_PAL_REMQTIL (Remret, Header);
555
556	Rstat := Remret.Status;
557	Item := Remret.Item;
558
559	-- Wouldn't case be nicer here, and in previous similar cases ???
560
561	if Rstat = 0 then
562	Status := Fail_Was_Empty;
563
564	elsif Rstat = 1 then
565	Status := OK_Not_Empty;
566
567	elsif Rstat = 2 then
568	Status := OK_Empty;
569	else
570	-- This status is never returned on IVMS
571
572	Status := Fail_No_Lock;
573	end if;
574	end Remqti;
575
576	end System.Aux_DEC;