1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . A U X _ D E C --
9 -- Copyright (C) 1992-2009, 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 pragma Style_Checks (All_Checks);
33 -- Turn off alpha ordering check on subprograms, this unit is laid
34 -- out to correspond to the declarations in the DEC 83 System unit.
36 with System.Soft_Links;
38 package body System.Aux_DEC is
40 package SSL renames System.Soft_Links;
42 -----------------------------------
43 -- Operations on Largest_Integer --
44 -----------------------------------
46 -- It would be nice to replace these with intrinsics, but that does
47 -- not work yet (the back end would be ok, but GNAT itself objects)
49 type LIU is mod 2 ** Largest_Integer'Size;
50 -- Unsigned type of same length as Largest_Integer
52 function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer);
53 function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU);
55 function "not" (Left : Largest_Integer) return Largest_Integer is
57 return To_LI (not From_LI (Left));
60 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
62 return To_LI (From_LI (Left) and From_LI (Right));
65 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
67 return To_LI (From_LI (Left) or From_LI (Right));
70 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
72 return To_LI (From_LI (Left) xor From_LI (Right));
75 --------------------------------------
76 -- Arithmetic Operations on Address --
77 --------------------------------------
79 -- It would be nice to replace these with intrinsics, but that does
80 -- not work yet (the back end would be ok, but GNAT itself objects)
82 Asiz : constant Integer := Integer (Address'Size) - 1;
84 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
85 -- Signed type of same size as Address
87 function To_A is new Ada.Unchecked_Conversion (SA, Address);
88 function From_A is new Ada.Unchecked_Conversion (Address, SA);
90 function "+" (Left : Address; Right : Integer) return Address is
92 return To_A (From_A (Left) + SA (Right));
95 function "+" (Left : Integer; Right : Address) return Address is
97 return To_A (SA (Left) + From_A (Right));
100 function "-" (Left : Address; Right : Address) return Integer is
101 pragma Unsuppress (All_Checks);
102 -- Because this can raise Constraint_Error for 64-bit addresses
104 return Integer (From_A (Left) - From_A (Right));
107 function "-" (Left : Address; Right : Integer) return Address is
109 return To_A (From_A (Left) - SA (Right));
112 ------------------------
113 -- Fetch_From_Address --
114 ------------------------
116 function Fetch_From_Address (A : Address) return Target is
117 type T_Ptr is access all Target;
118 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
119 Ptr : constant T_Ptr := To_T_Ptr (A);
122 end Fetch_From_Address;
124 -----------------------
125 -- Assign_To_Address --
126 -----------------------
128 procedure Assign_To_Address (A : Address; T : Target) is
129 type T_Ptr is access all Target;
130 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
131 Ptr : constant T_Ptr := To_T_Ptr (A);
134 end Assign_To_Address;
136 ---------------------------------
137 -- Operations on Unsigned_Byte --
138 ---------------------------------
140 -- It would be nice to replace these with intrinsics, but that does
141 -- not work yet (the back end would be ok, but GNAT itself objects)
143 type BU is mod 2 ** Unsigned_Byte'Size;
144 -- Unsigned type of same length as Unsigned_Byte
146 function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte);
147 function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU);
149 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
151 return To_B (not From_B (Left));
154 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
156 return To_B (From_B (Left) and From_B (Right));
159 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
161 return To_B (From_B (Left) or From_B (Right));
164 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
166 return To_B (From_B (Left) xor From_B (Right));
169 ---------------------------------
170 -- Operations on Unsigned_Word --
171 ---------------------------------
173 -- It would be nice to replace these with intrinsics, but that does
174 -- not work yet (the back end would be ok, but GNAT itself objects)
176 type WU is mod 2 ** Unsigned_Word'Size;
177 -- Unsigned type of same length as Unsigned_Word
179 function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word);
180 function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU);
182 function "not" (Left : Unsigned_Word) return Unsigned_Word is
184 return To_W (not From_W (Left));
187 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
189 return To_W (From_W (Left) and From_W (Right));
192 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
194 return To_W (From_W (Left) or From_W (Right));
197 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
199 return To_W (From_W (Left) xor From_W (Right));
202 -------------------------------------
203 -- Operations on Unsigned_Longword --
204 -------------------------------------
206 -- It would be nice to replace these with intrinsics, but that does
207 -- not work yet (the back end would be ok, but GNAT itself objects)
209 type LWU is mod 2 ** Unsigned_Longword'Size;
210 -- Unsigned type of same length as Unsigned_Longword
212 function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword);
213 function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU);
215 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
217 return To_LW (not From_LW (Left));
220 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
222 return To_LW (From_LW (Left) and From_LW (Right));
225 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
227 return To_LW (From_LW (Left) or From_LW (Right));
230 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
232 return To_LW (From_LW (Left) xor From_LW (Right));
235 -------------------------------
236 -- Operations on Unsigned_32 --
237 -------------------------------
239 -- It would be nice to replace these with intrinsics, but that does
240 -- not work yet (the back end would be ok, but GNAT itself objects)
242 type U32 is mod 2 ** Unsigned_32'Size;
243 -- Unsigned type of same length as Unsigned_32
245 function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32);
246 function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32);
248 function "not" (Left : Unsigned_32) return Unsigned_32 is
250 return To_U32 (not From_U32 (Left));
253 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
255 return To_U32 (From_U32 (Left) and From_U32 (Right));
258 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
260 return To_U32 (From_U32 (Left) or From_U32 (Right));
263 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
265 return To_U32 (From_U32 (Left) xor From_U32 (Right));
268 -------------------------------------
269 -- Operations on Unsigned_Quadword --
270 -------------------------------------
272 -- It would be nice to replace these with intrinsics, but that does
273 -- not work yet (the back end would be ok, but GNAT itself objects)
275 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
276 -- Unsigned type of same length as Unsigned_Quadword
278 function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword);
279 function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU);
281 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
283 return To_QW (not From_QW (Left));
286 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
288 return To_QW (From_QW (Left) and From_QW (Right));
291 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
293 return To_QW (From_QW (Left) or From_QW (Right));
296 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
298 return To_QW (From_QW (Left) xor From_QW (Right));
301 -----------------------
302 -- Clear_Interlocked --
303 -----------------------
305 procedure Clear_Interlocked
306 (Bit : in out Boolean;
307 Old_Value : out Boolean)
314 end Clear_Interlocked;
316 procedure Clear_Interlocked
317 (Bit : in out Boolean;
318 Old_Value : out Boolean;
319 Retry_Count : Natural;
320 Success_Flag : out Boolean)
322 pragma Warnings (Off, Retry_Count);
328 Success_Flag := True;
330 end Clear_Interlocked;
332 ---------------------
333 -- Set_Interlocked --
334 ---------------------
336 procedure Set_Interlocked
337 (Bit : in out Boolean;
338 Old_Value : out Boolean)
347 procedure Set_Interlocked
348 (Bit : in out Boolean;
349 Old_Value : out Boolean;
350 Retry_Count : Natural;
351 Success_Flag : out Boolean)
353 pragma Warnings (Off, Retry_Count);
359 Success_Flag := True;
363 ---------------------
364 -- Add_Interlocked --
365 ---------------------
367 procedure Add_Interlocked
368 (Addend : Short_Integer;
369 Augend : in out Aligned_Word;
374 Augend.Value := Augend.Value + Addend;
376 if Augend.Value < 0 then
378 elsif Augend.Value > 0 then
392 (To : in out Aligned_Integer;
397 To.Value := To.Value + Amount;
402 (To : in out Aligned_Integer;
404 Retry_Count : Natural;
405 Old_Value : out Integer;
406 Success_Flag : out Boolean)
408 pragma Warnings (Off, Retry_Count);
412 Old_Value := To.Value;
413 To.Value := To.Value + Amount;
414 Success_Flag := True;
419 (To : in out Aligned_Long_Integer;
420 Amount : Long_Integer)
424 To.Value := To.Value + Amount;
429 (To : in out Aligned_Long_Integer;
430 Amount : Long_Integer;
431 Retry_Count : Natural;
432 Old_Value : out Long_Integer;
433 Success_Flag : out Boolean)
435 pragma Warnings (Off, Retry_Count);
439 Old_Value := To.Value;
440 To.Value := To.Value + Amount;
441 Success_Flag := True;
449 type IU is mod 2 ** Integer'Size;
450 type LU is mod 2 ** Long_Integer'Size;
452 function To_IU is new Ada.Unchecked_Conversion (Integer, IU);
453 function From_IU is new Ada.Unchecked_Conversion (IU, Integer);
455 function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU);
456 function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer);
459 (To : in out Aligned_Integer;
464 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
469 (To : in out Aligned_Integer;
471 Retry_Count : Natural;
472 Old_Value : out Integer;
473 Success_Flag : out Boolean)
475 pragma Warnings (Off, Retry_Count);
479 Old_Value := To.Value;
480 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
481 Success_Flag := True;
486 (To : in out Aligned_Long_Integer;
491 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
496 (To : in out Aligned_Long_Integer;
498 Retry_Count : Natural;
499 Old_Value : out Long_Integer;
500 Success_Flag : out Boolean)
502 pragma Warnings (Off, Retry_Count);
506 Old_Value := To.Value;
507 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
508 Success_Flag := True;
517 (To : in out Aligned_Integer;
522 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
527 (To : in out Aligned_Integer;
529 Retry_Count : Natural;
530 Old_Value : out Integer;
531 Success_Flag : out Boolean)
533 pragma Warnings (Off, Retry_Count);
537 Old_Value := To.Value;
538 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
539 Success_Flag := True;
544 (To : in out Aligned_Long_Integer;
549 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
554 (To : in out Aligned_Long_Integer;
556 Retry_Count : Natural;
557 Old_Value : out Long_Integer;
558 Success_Flag : out Boolean)
560 pragma Warnings (Off, Retry_Count);
564 Old_Value := To.Value;
565 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
566 Success_Flag := True;
570 ------------------------------------
571 -- Declarations for Queue Objects --
572 ------------------------------------
576 type QR_Ptr is access QR;
583 function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr);
584 function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address);
593 Status : out Insq_Status)
595 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
596 Next : constant QR_Ptr := Hedr.Forward;
597 Itm : constant QR_Ptr := To_QR_Ptr (Item);
603 Itm.Backward := Hedr;
610 Next.Backward := Itm;
611 Status := OK_Not_First;
624 Status : out Remq_Status)
626 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
627 Next : constant QR_Ptr := Hedr.Forward;
632 Item := From_QR_Ptr (Next);
635 Status := Fail_Was_Empty;
638 Hedr.Forward := To_QR_Ptr (Item).Forward;
640 if Hedr.Forward = null then
644 Hedr.Forward.Backward := Hedr;
645 Status := OK_Not_Empty;
659 Status : out Insq_Status)
661 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
662 Prev : constant QR_Ptr := Hedr.Backward;
663 Itm : constant QR_Ptr := To_QR_Ptr (Item);
668 Itm.Backward := Prev;
670 Hedr.Backward := Itm;
677 Status := OK_Not_First;
690 Status : out Remq_Status)
692 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
693 Prev : constant QR_Ptr := Hedr.Backward;
698 Item := From_QR_Ptr (Prev);
701 Status := Fail_Was_Empty;
704 Hedr.Backward := To_QR_Ptr (Item).Backward;
706 if Hedr.Backward = null then
710 Hedr.Backward.Forward := Hedr;
711 Status := OK_Not_Empty;