1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . A U X _ D E C --
9 -- Copyright (C) 1992-2004 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 2, 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. See the GNU General Public License --
17 -- fOr mOre details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, Or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 pragma Style_Checks (All_Checks);
35 -- Turn off alpha ordering check on subprograms, this unit is laid
36 -- out to correspond to the declarations in the DEC 83 System unit.
38 with System.Soft_Links;
40 package body System.Aux_DEC is
42 package SSL renames System.Soft_Links;
44 -----------------------------------
45 -- Operations on Largest_Integer --
46 -----------------------------------
48 -- It would be nice to replace these with intrinsics, but that does
49 -- not work yet (the back end would be ok, but GNAT itself objects)
51 type LIU is mod 2 ** Largest_Integer'Size;
52 -- Unsigned type of same length as Largest_Integer
54 function To_LI is new Unchecked_Conversion (LIU, Largest_Integer);
55 function From_LI is new Unchecked_Conversion (Largest_Integer, LIU);
57 function "not" (Left : Largest_Integer) return Largest_Integer is
59 return To_LI (not From_LI (Left));
62 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
64 return To_LI (From_LI (Left) and From_LI (Right));
67 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
69 return To_LI (From_LI (Left) or From_LI (Right));
72 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
74 return To_LI (From_LI (Left) xor From_LI (Right));
77 --------------------------------------
78 -- Arithmetic Operations on Address --
79 --------------------------------------
81 -- It would be nice to replace these with intrinsics, but that does
82 -- not work yet (the back end would be ok, but GNAT itself objects)
84 Asiz : constant Integer := Integer (Address'Size) - 1;
86 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
87 -- Signed type of same size as Address
89 function To_A is new Unchecked_Conversion (SA, Address);
90 function From_A is new Unchecked_Conversion (Address, SA);
92 function "+" (Left : Address; Right : Integer) return Address is
94 return To_A (From_A (Left) + SA (Right));
97 function "+" (Left : Integer; Right : Address) return Address is
99 return To_A (SA (Left) + From_A (Right));
102 function "-" (Left : Address; Right : Address) return Integer is
103 pragma Unsuppress (All_Checks);
104 -- Because this can raise Constraint_Error for 64-bit addresses
106 return Integer (From_A (Left) - From_A (Right));
109 function "-" (Left : Address; Right : Integer) return Address is
111 return To_A (From_A (Left) - SA (Right));
114 ------------------------
115 -- Fetch_From_Address --
116 ------------------------
118 function Fetch_From_Address (A : Address) return Target is
119 type T_Ptr is access all Target;
120 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
121 Ptr : constant T_Ptr := To_T_Ptr (A);
124 end Fetch_From_Address;
126 -----------------------
127 -- Assign_To_Address --
128 -----------------------
130 procedure Assign_To_Address (A : Address; T : Target) is
131 type T_Ptr is access all Target;
132 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
133 Ptr : constant T_Ptr := To_T_Ptr (A);
136 end Assign_To_Address;
138 ---------------------------------
139 -- Operations on Unsigned_Byte --
140 ---------------------------------
142 -- It would be nice to replace these with intrinsics, but that does
143 -- not work yet (the back end would be ok, but GNAT itself objects)
145 type BU is mod 2 ** Unsigned_Byte'Size;
146 -- Unsigned type of same length as Unsigned_Byte
148 function To_B is new Unchecked_Conversion (BU, Unsigned_Byte);
149 function From_B is new Unchecked_Conversion (Unsigned_Byte, BU);
151 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
153 return To_B (not From_B (Left));
156 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
158 return To_B (From_B (Left) and From_B (Right));
161 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
163 return To_B (From_B (Left) or From_B (Right));
166 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
168 return To_B (From_B (Left) xor From_B (Right));
171 ---------------------------------
172 -- Operations on Unsigned_Word --
173 ---------------------------------
175 -- It would be nice to replace these with intrinsics, but that does
176 -- not work yet (the back end would be ok, but GNAT itself objects)
178 type WU is mod 2 ** Unsigned_Word'Size;
179 -- Unsigned type of same length as Unsigned_Word
181 function To_W is new Unchecked_Conversion (WU, Unsigned_Word);
182 function From_W is new Unchecked_Conversion (Unsigned_Word, WU);
184 function "not" (Left : Unsigned_Word) return Unsigned_Word is
186 return To_W (not From_W (Left));
189 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
191 return To_W (From_W (Left) and From_W (Right));
194 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
196 return To_W (From_W (Left) or From_W (Right));
199 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
201 return To_W (From_W (Left) xor From_W (Right));
204 -------------------------------------
205 -- Operations on Unsigned_Longword --
206 -------------------------------------
208 -- It would be nice to replace these with intrinsics, but that does
209 -- not work yet (the back end would be ok, but GNAT itself objects)
211 type LWU is mod 2 ** Unsigned_Longword'Size;
212 -- Unsigned type of same length as Unsigned_Longword
214 function To_LW is new Unchecked_Conversion (LWU, Unsigned_Longword);
215 function From_LW is new Unchecked_Conversion (Unsigned_Longword, LWU);
217 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
219 return To_LW (not From_LW (Left));
222 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
224 return To_LW (From_LW (Left) and From_LW (Right));
227 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
229 return To_LW (From_LW (Left) or From_LW (Right));
232 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
234 return To_LW (From_LW (Left) xor From_LW (Right));
237 -------------------------------
238 -- Operations on Unsigned_32 --
239 -------------------------------
241 -- It would be nice to replace these with intrinsics, but that does
242 -- not work yet (the back end would be ok, but GNAT itself objects)
244 type U32 is mod 2 ** Unsigned_32'Size;
245 -- Unsigned type of same length as Unsigned_32
247 function To_U32 is new Unchecked_Conversion (U32, Unsigned_32);
248 function From_U32 is new Unchecked_Conversion (Unsigned_32, U32);
250 function "not" (Left : Unsigned_32) return Unsigned_32 is
252 return To_U32 (not From_U32 (Left));
255 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
257 return To_U32 (From_U32 (Left) and From_U32 (Right));
260 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
262 return To_U32 (From_U32 (Left) or From_U32 (Right));
265 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
267 return To_U32 (From_U32 (Left) xor From_U32 (Right));
270 -------------------------------------
271 -- Operations on Unsigned_Quadword --
272 -------------------------------------
274 -- It would be nice to replace these with intrinsics, but that does
275 -- not work yet (the back end would be ok, but GNAT itself objects)
277 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
278 -- Unsigned type of same length as Unsigned_Quadword
280 function To_QW is new Unchecked_Conversion (QWU, Unsigned_Quadword);
281 function From_QW is new Unchecked_Conversion (Unsigned_Quadword, QWU);
283 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
285 return To_QW (not From_QW (Left));
288 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
290 return To_QW (From_QW (Left) and From_QW (Right));
293 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
295 return To_QW (From_QW (Left) or From_QW (Right));
298 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
300 return To_QW (From_QW (Left) xor From_QW (Right));
303 -----------------------
304 -- Clear_Interlocked --
305 -----------------------
307 procedure Clear_Interlocked
308 (Bit : in out Boolean;
309 Old_Value : out Boolean)
316 end Clear_Interlocked;
318 procedure Clear_Interlocked
319 (Bit : in out Boolean;
320 Old_Value : out Boolean;
321 Retry_Count : in Natural;
322 Success_Flag : out Boolean)
324 pragma Warnings (Off, Retry_Count);
330 Success_Flag := True;
332 end Clear_Interlocked;
334 ---------------------
335 -- Set_Interlocked --
336 ---------------------
338 procedure Set_Interlocked
339 (Bit : in out Boolean;
340 Old_Value : out Boolean)
349 procedure Set_Interlocked
350 (Bit : in out Boolean;
351 Old_Value : out Boolean;
352 Retry_Count : in Natural;
353 Success_Flag : out Boolean)
355 pragma Warnings (Off, Retry_Count);
361 Success_Flag := True;
365 ---------------------
366 -- Add_Interlocked --
367 ---------------------
369 procedure Add_Interlocked
370 (Addend : in Short_Integer;
371 Augend : in out Aligned_Word;
376 Augend.Value := Augend.Value + Addend;
378 if Augend.Value < 0 then
380 elsif Augend.Value > 0 then
394 (To : in out Aligned_Integer;
399 To.Value := To.Value + Amount;
404 (To : in out Aligned_Integer;
406 Retry_Count : in Natural;
407 Old_Value : out Integer;
408 Success_Flag : out Boolean)
410 pragma Warnings (Off, Retry_Count);
414 Old_Value := To.Value;
415 To.Value := To.Value + Amount;
416 Success_Flag := True;
421 (To : in out Aligned_Long_Integer;
422 Amount : in Long_Integer)
426 To.Value := To.Value + Amount;
431 (To : in out Aligned_Long_Integer;
432 Amount : in Long_Integer;
433 Retry_Count : in Natural;
434 Old_Value : out Long_Integer;
435 Success_Flag : out Boolean)
437 pragma Warnings (Off, Retry_Count);
441 Old_Value := To.Value;
442 To.Value := To.Value + Amount;
443 Success_Flag := True;
451 type IU is mod 2 ** Integer'Size;
452 type LU is mod 2 ** Long_Integer'Size;
454 function To_IU is new Unchecked_Conversion (Integer, IU);
455 function From_IU is new Unchecked_Conversion (IU, Integer);
457 function To_LU is new Unchecked_Conversion (Long_Integer, LU);
458 function From_LU is new Unchecked_Conversion (LU, Long_Integer);
461 (To : in out Aligned_Integer;
466 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
471 (To : in out Aligned_Integer;
473 Retry_Count : in Natural;
474 Old_Value : out Integer;
475 Success_Flag : out Boolean)
477 pragma Warnings (Off, Retry_Count);
481 Old_Value := To.Value;
482 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
483 Success_Flag := True;
488 (To : in out Aligned_Long_Integer;
489 From : in Long_Integer)
493 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
498 (To : in out Aligned_Long_Integer;
499 From : in Long_Integer;
500 Retry_Count : in Natural;
501 Old_Value : out Long_Integer;
502 Success_Flag : out Boolean)
504 pragma Warnings (Off, Retry_Count);
508 Old_Value := To.Value;
509 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
510 Success_Flag := True;
519 (To : in out Aligned_Integer;
524 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
529 (To : in out Aligned_Integer;
531 Retry_Count : in Natural;
532 Old_Value : out Integer;
533 Success_Flag : out Boolean)
535 pragma Warnings (Off, Retry_Count);
539 Old_Value := To.Value;
540 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
541 Success_Flag := True;
546 (To : in out Aligned_Long_Integer;
547 From : in Long_Integer)
551 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
556 (To : in out Aligned_Long_Integer;
557 From : in Long_Integer;
558 Retry_Count : in Natural;
559 Old_Value : out Long_Integer;
560 Success_Flag : out Boolean)
562 pragma Warnings (Off, Retry_Count);
566 Old_Value := To.Value;
567 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
568 Success_Flag := True;
572 ------------------------------------
573 -- Declarations for Queue Objects --
574 ------------------------------------
578 type QR_Ptr is access QR;
585 function To_QR_Ptr is new Unchecked_Conversion (Address, QR_Ptr);
586 function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
595 Status : out Insq_Status)
597 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
598 Next : constant QR_Ptr := Hedr.Forward;
599 Itm : constant QR_Ptr := To_QR_Ptr (Item);
605 Itm.Backward := Hedr;
612 Next.Backward := Itm;
613 Status := OK_Not_First;
624 (Header : in Address;
626 Status : out Remq_Status)
628 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
629 Next : constant QR_Ptr := Hedr.Forward;
634 Item := From_QR_Ptr (Next);
637 Status := Fail_Was_Empty;
640 Hedr.Forward := To_QR_Ptr (Item).Forward;
642 if Hedr.Forward = null then
646 Hedr.Forward.Backward := Hedr;
647 Status := OK_Not_Empty;
661 Status : out Insq_Status)
663 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
664 Prev : constant QR_Ptr := Hedr.Backward;
665 Itm : constant QR_Ptr := To_QR_Ptr (Item);
670 Itm.Backward := Prev;
672 Hedr.Backward := Itm;
679 Status := OK_Not_First;
690 (Header : in Address;
692 Status : out Remq_Status)
694 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
695 Prev : constant QR_Ptr := Hedr.Backward;
700 Item := From_QR_Ptr (Prev);
703 Status := Fail_Was_Empty;
706 Hedr.Backward := To_QR_Ptr (Item).Backward;
708 if Hedr.Backward = null then
712 Hedr.Backward.Forward := Hedr;
713 Status := OK_Not_Empty;