1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . A U X _ D E C --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/Or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, Or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- Or FITNESS FOr A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- fOr mOre details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, Or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was Originally developed by the GNAT team at New YOrk University. --
31 -- It is now maintained by Ada COre Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 pragma Style_Checks (All_Checks);
36 -- Turn off alpha ordering check on subprograms, this unit is laid
37 -- out to correspond to the declarations in the DEC 83 System unit.
39 with System.Soft_Links;
41 package body System.Aux_DEC is
43 package SSL renames System.Soft_Links;
45 -----------------------------------
46 -- Operations on Largest_Integer --
47 -----------------------------------
49 -- It would be nice to replace these with intrinsics, but that does
50 -- not work yet (the back end would be ok, but GNAT itself objects)
52 type LIU is mod 2 ** Largest_Integer'Size;
53 -- Unsigned type of same length as Largest_Integer
55 function To_LI is new Unchecked_Conversion (LIU, Largest_Integer);
56 function From_LI is new Unchecked_Conversion (Largest_Integer, LIU);
58 function "not" (Left : Largest_Integer) return Largest_Integer is
60 return To_LI (not From_LI (Left));
63 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
65 return To_LI (From_LI (Left) and From_LI (Right));
68 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
70 return To_LI (From_LI (Left) or From_LI (Right));
73 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
75 return To_LI (From_LI (Left) xor From_LI (Right));
78 --------------------------------------
79 -- Arithmetic Operations on Address --
80 --------------------------------------
82 -- It would be nice to replace these with intrinsics, but that does
83 -- not work yet (the back end would be ok, but GNAT itself objects)
85 Asiz : constant Integer := Integer (Address'Size) - 1;
87 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
88 -- Signed type of same size as Address
90 function To_A is new Unchecked_Conversion (SA, Address);
91 function From_A is new Unchecked_Conversion (Address, SA);
93 function "+" (Left : Address; Right : Integer) return Address is
95 return To_A (From_A (Left) + SA (Right));
98 function "+" (Left : Integer; Right : Address) return Address is
100 return To_A (SA (Left) + From_A (Right));
103 function "-" (Left : Address; Right : Address) return Integer is
104 pragma Unsuppress (All_Checks);
105 -- Because this can raise Constraint_Error for 64-bit addresses
108 return Integer (From_A (Left - Right));
111 function "-" (Left : Address; Right : Integer) return Address is
113 return To_A (From_A (Left) - SA (Right));
116 ------------------------
117 -- Fetch_From_Address --
118 ------------------------
120 function Fetch_From_Address (A : Address) return Target is
121 type T_Ptr is access all Target;
122 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
123 Ptr : constant T_Ptr := To_T_Ptr (A);
127 end Fetch_From_Address;
129 -----------------------
130 -- Assign_To_Address --
131 -----------------------
133 procedure Assign_To_Address (A : Address; T : Target) is
134 type T_Ptr is access all Target;
135 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
136 Ptr : constant T_Ptr := To_T_Ptr (A);
140 end Assign_To_Address;
142 ---------------------------------
143 -- Operations on Unsigned_Byte --
144 ---------------------------------
146 -- It would be nice to replace these with intrinsics, but that does
147 -- not work yet (the back end would be ok, but GNAT itself objects)
149 type BU is mod 2 ** Unsigned_Byte'Size;
150 -- Unsigned type of same length as Unsigned_Byte
152 function To_B is new Unchecked_Conversion (BU, Unsigned_Byte);
153 function From_B is new Unchecked_Conversion (Unsigned_Byte, BU);
155 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
157 return To_B (not From_B (Left));
160 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
162 return To_B (From_B (Left) and From_B (Right));
165 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
167 return To_B (From_B (Left) or From_B (Right));
170 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
172 return To_B (From_B (Left) xor From_B (Right));
175 ---------------------------------
176 -- Operations on Unsigned_Word --
177 ---------------------------------
179 -- It would be nice to replace these with intrinsics, but that does
180 -- not work yet (the back end would be ok, but GNAT itself objects)
182 type WU is mod 2 ** Unsigned_Word'Size;
183 -- Unsigned type of same length as Unsigned_Word
185 function To_W is new Unchecked_Conversion (WU, Unsigned_Word);
186 function From_W is new Unchecked_Conversion (Unsigned_Word, WU);
188 function "not" (Left : Unsigned_Word) return Unsigned_Word is
190 return To_W (not From_W (Left));
193 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
195 return To_W (From_W (Left) and From_W (Right));
198 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
200 return To_W (From_W (Left) or From_W (Right));
203 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
205 return To_W (From_W (Left) xor From_W (Right));
208 -------------------------------------
209 -- Operations on Unsigned_Longword --
210 -------------------------------------
212 -- It would be nice to replace these with intrinsics, but that does
213 -- not work yet (the back end would be ok, but GNAT itself objects)
215 type LWU is mod 2 ** Unsigned_Longword'Size;
216 -- Unsigned type of same length as Unsigned_Longword
218 function To_LW is new Unchecked_Conversion (LWU, Unsigned_Longword);
219 function From_LW is new Unchecked_Conversion (Unsigned_Longword, LWU);
221 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
223 return To_LW (not From_LW (Left));
226 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
228 return To_LW (From_LW (Left) and From_LW (Right));
231 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
233 return To_LW (From_LW (Left) or From_LW (Right));
236 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
238 return To_LW (From_LW (Left) xor From_LW (Right));
241 -------------------------------
242 -- Operations on Unsigned_32 --
243 -------------------------------
245 -- It would be nice to replace these with intrinsics, but that does
246 -- not work yet (the back end would be ok, but GNAT itself objects)
248 type U32 is mod 2 ** Unsigned_32'Size;
249 -- Unsigned type of same length as Unsigned_32
251 function To_U32 is new Unchecked_Conversion (U32, Unsigned_32);
252 function From_U32 is new Unchecked_Conversion (Unsigned_32, U32);
254 function "not" (Left : Unsigned_32) return Unsigned_32 is
256 return To_U32 (not From_U32 (Left));
259 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
261 return To_U32 (From_U32 (Left) and From_U32 (Right));
264 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
266 return To_U32 (From_U32 (Left) or From_U32 (Right));
269 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
271 return To_U32 (From_U32 (Left) xor From_U32 (Right));
274 -------------------------------------
275 -- Operations on Unsigned_Quadword --
276 -------------------------------------
278 -- It would be nice to replace these with intrinsics, but that does
279 -- not work yet (the back end would be ok, but GNAT itself objects)
281 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
282 -- Unsigned type of same length as Unsigned_Quadword
284 function To_QW is new Unchecked_Conversion (QWU, Unsigned_Quadword);
285 function From_QW is new Unchecked_Conversion (Unsigned_Quadword, QWU);
287 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
289 return To_QW (not From_QW (Left));
292 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
294 return To_QW (From_QW (Left) and From_QW (Right));
297 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
299 return To_QW (From_QW (Left) or From_QW (Right));
302 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
304 return To_QW (From_QW (Left) xor From_QW (Right));
307 -----------------------
308 -- Clear_Interlocked --
309 -----------------------
311 procedure Clear_Interlocked
312 (Bit : in out Boolean;
313 Old_Value : out Boolean)
320 end Clear_Interlocked;
322 procedure Clear_Interlocked
323 (Bit : in out Boolean;
324 Old_Value : out Boolean;
325 Retry_Count : in Natural;
326 Success_Flag : out Boolean)
328 pragma Warnings (Off, Retry_Count);
334 Success_Flag := True;
336 end Clear_Interlocked;
338 ---------------------
339 -- Set_Interlocked --
340 ---------------------
342 procedure Set_Interlocked
343 (Bit : in out Boolean;
344 Old_Value : out Boolean)
353 procedure Set_Interlocked
354 (Bit : in out Boolean;
355 Old_Value : out Boolean;
356 Retry_Count : in Natural;
357 Success_Flag : out Boolean)
359 pragma Warnings (Off, Retry_Count);
365 Success_Flag := True;
369 ---------------------
370 -- Add_Interlocked --
371 ---------------------
373 procedure Add_Interlocked
374 (Addend : in Short_Integer;
375 Augend : in out Aligned_Word;
380 Augend.Value := Augend.Value + Addend;
382 if Augend.Value < 0 then
384 elsif Augend.Value > 0 then
398 (To : in out Aligned_Integer;
403 To.Value := To.Value + Amount;
408 (To : in out Aligned_Integer;
410 Retry_Count : in Natural;
411 Old_Value : out Integer;
412 Success_Flag : out Boolean)
414 pragma Warnings (Off, Retry_Count);
418 Old_Value := To.Value;
419 To.Value := To.Value + Amount;
420 Success_Flag := True;
425 (To : in out Aligned_Long_Integer;
426 Amount : in Long_Integer)
430 To.Value := To.Value + Amount;
435 (To : in out Aligned_Long_Integer;
436 Amount : in Long_Integer;
437 Retry_Count : in Natural;
438 Old_Value : out Long_Integer;
439 Success_Flag : out Boolean)
441 pragma Warnings (Off, Retry_Count);
445 Old_Value := To.Value;
446 To.Value := To.Value + Amount;
447 Success_Flag := True;
455 type IU is mod 2 ** Integer'Size;
456 type LU is mod 2 ** Long_Integer'Size;
458 function To_IU is new Unchecked_Conversion (Integer, IU);
459 function From_IU is new Unchecked_Conversion (IU, Integer);
461 function To_LU is new Unchecked_Conversion (Long_Integer, LU);
462 function From_LU is new Unchecked_Conversion (LU, Long_Integer);
465 (To : in out Aligned_Integer;
470 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
475 (To : in out Aligned_Integer;
477 Retry_Count : in Natural;
478 Old_Value : out Integer;
479 Success_Flag : out Boolean)
481 pragma Warnings (Off, Retry_Count);
485 Old_Value := To.Value;
486 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
487 Success_Flag := True;
492 (To : in out Aligned_Long_Integer;
493 From : in Long_Integer)
497 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
502 (To : in out Aligned_Long_Integer;
503 From : in Long_Integer;
504 Retry_Count : in Natural;
505 Old_Value : out Long_Integer;
506 Success_Flag : out Boolean)
508 pragma Warnings (Off, Retry_Count);
512 Old_Value := To.Value;
513 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
514 Success_Flag := True;
523 (To : in out Aligned_Integer;
528 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
533 (To : in out Aligned_Integer;
535 Retry_Count : in Natural;
536 Old_Value : out Integer;
537 Success_Flag : out Boolean)
539 pragma Warnings (Off, Retry_Count);
543 Old_Value := To.Value;
544 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
545 Success_Flag := True;
550 (To : in out Aligned_Long_Integer;
551 From : in Long_Integer)
555 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
560 (To : in out Aligned_Long_Integer;
561 From : in Long_Integer;
562 Retry_Count : in Natural;
563 Old_Value : out Long_Integer;
564 Success_Flag : out Boolean)
566 pragma Warnings (Off, Retry_Count);
570 Old_Value := To.Value;
571 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
572 Success_Flag := True;
576 ------------------------------------
577 -- Declarations for Queue Objects --
578 ------------------------------------
582 type QR_Ptr is access QR;
589 function To_QR_Ptr is new Unchecked_Conversion (Address, QR_Ptr);
590 function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
599 Status : out Insq_Status)
601 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
602 Next : constant QR_Ptr := Hedr.Forward;
603 Itm : constant QR_Ptr := To_QR_Ptr (Item);
609 Itm.Backward := Hedr;
616 Next.Backward := Itm;
617 Status := OK_Not_First;
628 (Header : in Address;
630 Status : out Remq_Status)
632 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
633 Next : constant QR_Ptr := Hedr.Forward;
638 Item := From_QR_Ptr (Next);
641 Status := Fail_Was_Empty;
644 Hedr.Forward := To_QR_Ptr (Item).Forward;
646 if Hedr.Forward = null then
650 Hedr.Forward.Backward := Hedr;
651 Status := OK_Not_Empty;
665 Status : out Insq_Status)
667 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
668 Prev : constant QR_Ptr := Hedr.Backward;
669 Itm : constant QR_Ptr := To_QR_Ptr (Item);
674 Itm.Backward := Prev;
676 Hedr.Backward := Itm;
683 Status := OK_Not_First;
694 (Header : in Address;
696 Status : out Remq_Status)
698 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
699 Prev : constant QR_Ptr := Hedr.Backward;
704 Item := From_QR_Ptr (Prev);
707 Status := Fail_Was_Empty;
710 Hedr.Backward := To_QR_Ptr (Item).Backward;
712 if Hedr.Backward = null then
716 Hedr.Backward.Forward := Hedr;
717 Status := OK_Not_Empty;