1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . A U X _ D E C --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the Itanium/VMS version.
34 -- The Add,Clear_Interlocked subprograms are dubiously implmented due to
35 -- the lack of a single bit sync_lock_test_and_set builtin.
37 -- The "Retry" parameter is ignored due to the lack of retry builtins making
38 -- the subprograms identical to the non-retry versions.
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.
45 package body System.Aux_DEC is
47 use type Interfaces.Unsigned_8;
49 ------------------------
50 -- Fetch_From_Address --
51 ------------------------
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);
59 end Fetch_From_Address;
61 -----------------------
62 -- Assign_To_Address --
63 -----------------------
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);
71 end Assign_To_Address;
73 -----------------------
74 -- Clear_Interlocked --
75 -----------------------
77 procedure Clear_Interlocked
78 (Bit : in out Boolean;
79 Old_Value : out Boolean)
81 Clr_Bit : Boolean := Bit;
82 Old_Uns : Interfaces.Unsigned_8;
84 function Sync_Lock_Test_And_Set
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");
91 Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
93 Old_Value := Old_Uns /= 0;
94 end Clear_Interlocked;
96 procedure Clear_Interlocked
97 (Bit : in out Boolean;
98 Old_Value : out Boolean;
99 Retry_Count : Natural;
100 Success_Flag : out Boolean)
102 pragma Unreferenced (Retry_Count);
104 Clr_Bit : Boolean := Bit;
105 Old_Uns : Interfaces.Unsigned_8;
107 function Sync_Lock_Test_And_Set
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");
114 Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
116 Old_Value := Old_Uns /= 0;
117 Success_Flag := True;
118 end Clear_Interlocked;
120 ---------------------
121 -- Set_Interlocked --
122 ---------------------
124 procedure Set_Interlocked
125 (Bit : in out Boolean;
126 Old_Value : out Boolean)
128 Set_Bit : Boolean := Bit;
129 Old_Uns : Interfaces.Unsigned_8;
131 function Sync_Lock_Test_And_Set
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");
138 Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
140 Old_Value := Old_Uns /= 0;
143 procedure Set_Interlocked
144 (Bit : in out Boolean;
145 Old_Value : out Boolean;
146 Retry_Count : Natural;
147 Success_Flag : out Boolean)
149 pragma Unreferenced (Retry_Count);
151 Set_Bit : Boolean := Bit;
152 Old_Uns : Interfaces.Unsigned_8;
154 function Sync_Lock_Test_And_Set
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");
160 Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
162 Old_Value := Old_Uns /= 0;
163 Success_Flag := True;
166 ---------------------
167 -- Add_Interlocked --
168 ---------------------
170 procedure Add_Interlocked
171 (Addend : Short_Integer;
172 Augend : in out Aligned_Word;
175 Overflowed : Boolean := False;
176 Former : Aligned_Word;
178 function Sync_Fetch_And_Add
180 Value : Short_Integer) return Short_Integer;
181 pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
184 Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
186 if Augend.Value < 0 then
188 elsif Augend.Value > 0 then
194 if Former.Value > 0 and then Augend.Value <= 0 then
199 raise Constraint_Error;
208 (To : in out Aligned_Integer;
211 procedure Sync_Add_And_Fetch
214 pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
216 Sync_Add_And_Fetch (To.Value'Address, Amount);
220 (To : in out Aligned_Integer;
222 Retry_Count : Natural;
223 Old_Value : out Integer;
224 Success_Flag : out Boolean)
226 pragma Unreferenced (Retry_Count);
228 function Sync_Fetch_And_Add
230 Value : Integer) return Integer;
231 pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
234 Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
235 Success_Flag := True;
239 (To : in out Aligned_Long_Integer;
240 Amount : Long_Integer)
242 procedure Sync_Add_And_Fetch
244 Value : Long_Integer);
245 pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
247 Sync_Add_And_Fetch (To.Value'Address, Amount);
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)
257 pragma Unreferenced (Retry_Count);
259 function Sync_Fetch_And_Add
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???
266 Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
267 Success_Flag := True;
275 (To : in out Aligned_Integer;
278 procedure Sync_And_And_Fetch
281 pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
283 Sync_And_And_Fetch (To.Value'Address, From);
287 (To : in out Aligned_Integer;
289 Retry_Count : Natural;
290 Old_Value : out Integer;
291 Success_Flag : out Boolean)
293 pragma Unreferenced (Retry_Count);
295 function Sync_Fetch_And_And
297 Value : Integer) return Integer;
298 pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
301 Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
302 Success_Flag := True;
306 (To : in out Aligned_Long_Integer;
309 procedure Sync_And_And_Fetch
311 Value : Long_Integer);
312 pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
314 Sync_And_And_Fetch (To.Value'Address, From);
318 (To : in out Aligned_Long_Integer;
320 Retry_Count : Natural;
321 Old_Value : out Long_Integer;
322 Success_Flag : out Boolean)
324 pragma Unreferenced (Retry_Count);
326 function Sync_Fetch_And_And
328 Value : Long_Integer) return Long_Integer;
329 pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
332 Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
333 Success_Flag := True;
341 (To : in out Aligned_Integer;
344 procedure Sync_Or_And_Fetch
347 pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
350 Sync_Or_And_Fetch (To.Value'Address, From);
354 (To : in out Aligned_Integer;
356 Retry_Count : Natural;
357 Old_Value : out Integer;
358 Success_Flag : out Boolean)
360 pragma Unreferenced (Retry_Count);
362 function Sync_Fetch_And_Or
364 Value : Integer) return Integer;
365 pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
368 Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
369 Success_Flag := True;
373 (To : in out Aligned_Long_Integer;
376 procedure Sync_Or_And_Fetch
378 Value : Long_Integer);
379 pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
381 Sync_Or_And_Fetch (To.Value'Address, From);
385 (To : in out Aligned_Long_Integer;
387 Retry_Count : Natural;
388 Old_Value : out Long_Integer;
389 Success_Flag : out Boolean)
391 pragma Unreferenced (Retry_Count);
393 function Sync_Fetch_And_Or
395 Value : Long_Integer) return Long_Integer;
396 pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
399 Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
400 Success_Flag := True;
410 Status : out Insq_Status) is
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));
422 SYS_PAL_INSQHIL (Istat, Header, Item);
425 Status := OK_Not_First;
430 -- This status is never returned on IVMS
432 Status := Fail_No_Lock;
443 Status : out Remq_Status)
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
451 Status : Long_Integer;
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",
463 -- Following variables need documentation???
465 Rstat : Long_Integer;
469 SYS_PAL_REMQHIL (Remret, Header);
471 Rstat := Remret.Status;
475 Status := Fail_Was_Empty;
478 Status := OK_Not_Empty;
484 -- This status is never returned on IVMS
486 Status := Fail_No_Lock;
498 Status : out Insq_Status) is
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));
510 SYS_PAL_INSQTIL (Istat, Header, Item);
513 Status := OK_Not_First;
519 -- This status is never returned on IVMS
521 Status := Fail_No_Lock;
532 Status : out Remq_Status)
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???)
539 Status : Long_Integer;
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",
550 Rstat : Long_Integer;
554 SYS_PAL_REMQTIL (Remret, Header);
556 Rstat := Remret.Status;
559 -- Wouldn't case be nicer here, and in previous similar cases ???
562 Status := Fail_Was_Empty;
565 Status := OK_Not_Empty;
570 -- This status is never returned on IVMS
572 Status := Fail_No_Lock;