1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . A U X _ D E C --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/Or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, Or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- Or FITNESS FOr A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- fOr mOre details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, Or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was Originally developed by the GNAT team at New YOrk University. --
32 -- It is now maintained by Ada COre Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 pragma Style_Checks (All_Checks);
37 -- Turn off alpha ordering check on subprograms, this unit is laid
38 -- out to correspond to the declarations in the DEC 83 System unit.
40 with System.Soft_Links;
42 package body System.Aux_DEC is
44 package SSL renames System.Soft_Links;
46 -----------------------------------
47 -- Operations on Largest_Integer --
48 -----------------------------------
50 -- It would be nice to replace these with intrinsics, but that does
51 -- not work yet (the back end would be ok, but GNAT itself objects)
53 type LIU is mod 2 ** Largest_Integer'Size;
54 -- Unsigned type of same length as Largest_Integer
56 function To_LI is new Unchecked_Conversion (LIU, Largest_Integer);
57 function From_LI is new Unchecked_Conversion (Largest_Integer, LIU);
59 function "not" (Left : Largest_Integer) return Largest_Integer is
61 return To_LI (not From_LI (Left));
64 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
66 return To_LI (From_LI (Left) and From_LI (Right));
69 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
71 return To_LI (From_LI (Left) or From_LI (Right));
74 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
76 return To_LI (From_LI (Left) xor From_LI (Right));
79 --------------------------------------
80 -- Arithmetic Operations on Address --
81 --------------------------------------
83 -- It would be nice to replace these with intrinsics, but that does
84 -- not work yet (the back end would be ok, but GNAT itself objects)
86 Asiz : constant Integer := Integer (Address'Size) - 1;
88 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
89 -- Signed type of same size as Address
91 function To_A is new Unchecked_Conversion (SA, Address);
92 function From_A is new Unchecked_Conversion (Address, SA);
94 function "+" (Left : Address; Right : Integer) return Address is
96 return To_A (From_A (Left) + SA (Right));
99 function "+" (Left : Integer; Right : Address) return Address is
101 return To_A (SA (Left) + From_A (Right));
104 function "-" (Left : Address; Right : Address) return Integer is
105 pragma Unsuppress (All_Checks);
106 -- Because this can raise Constraint_Error for 64-bit addresses
109 return Integer (From_A (Left - Right));
112 function "-" (Left : Address; Right : Integer) return Address is
114 return To_A (From_A (Left) - SA (Right));
117 ------------------------
118 -- Fetch_From_Address --
119 ------------------------
121 function Fetch_From_Address (A : Address) return Target is
122 type T_Ptr is access all Target;
123 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
124 Ptr : constant T_Ptr := To_T_Ptr (A);
128 end Fetch_From_Address;
130 -----------------------
131 -- Assign_To_Address --
132 -----------------------
134 procedure Assign_To_Address (A : Address; T : Target) is
135 type T_Ptr is access all Target;
136 function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
137 Ptr : constant T_Ptr := To_T_Ptr (A);
141 end Assign_To_Address;
143 ---------------------------------
144 -- Operations on Unsigned_Byte --
145 ---------------------------------
147 -- It would be nice to replace these with intrinsics, but that does
148 -- not work yet (the back end would be ok, but GNAT itself objects)
150 type BU is mod 2 ** Unsigned_Byte'Size;
151 -- Unsigned type of same length as Unsigned_Byte
153 function To_B is new Unchecked_Conversion (BU, Unsigned_Byte);
154 function From_B is new Unchecked_Conversion (Unsigned_Byte, BU);
156 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
158 return To_B (not From_B (Left));
161 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
163 return To_B (From_B (Left) and From_B (Right));
166 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
168 return To_B (From_B (Left) or From_B (Right));
171 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
173 return To_B (From_B (Left) xor From_B (Right));
176 ---------------------------------
177 -- Operations on Unsigned_Word --
178 ---------------------------------
180 -- It would be nice to replace these with intrinsics, but that does
181 -- not work yet (the back end would be ok, but GNAT itself objects)
183 type WU is mod 2 ** Unsigned_Word'Size;
184 -- Unsigned type of same length as Unsigned_Word
186 function To_W is new Unchecked_Conversion (WU, Unsigned_Word);
187 function From_W is new Unchecked_Conversion (Unsigned_Word, WU);
189 function "not" (Left : Unsigned_Word) return Unsigned_Word is
191 return To_W (not From_W (Left));
194 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
196 return To_W (From_W (Left) and From_W (Right));
199 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
201 return To_W (From_W (Left) or From_W (Right));
204 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
206 return To_W (From_W (Left) xor From_W (Right));
209 -------------------------------------
210 -- Operations on Unsigned_Longword --
211 -------------------------------------
213 -- It would be nice to replace these with intrinsics, but that does
214 -- not work yet (the back end would be ok, but GNAT itself objects)
216 type LWU is mod 2 ** Unsigned_Longword'Size;
217 -- Unsigned type of same length as Unsigned_Longword
219 function To_LW is new Unchecked_Conversion (LWU, Unsigned_Longword);
220 function From_LW is new Unchecked_Conversion (Unsigned_Longword, LWU);
222 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
224 return To_LW (not From_LW (Left));
227 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
229 return To_LW (From_LW (Left) and From_LW (Right));
232 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
234 return To_LW (From_LW (Left) or From_LW (Right));
237 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
239 return To_LW (From_LW (Left) xor From_LW (Right));
242 -------------------------------
243 -- Operations on Unsigned_32 --
244 -------------------------------
246 -- It would be nice to replace these with intrinsics, but that does
247 -- not work yet (the back end would be ok, but GNAT itself objects)
249 type U32 is mod 2 ** Unsigned_32'Size;
250 -- Unsigned type of same length as Unsigned_32
252 function To_U32 is new Unchecked_Conversion (U32, Unsigned_32);
253 function From_U32 is new Unchecked_Conversion (Unsigned_32, U32);
255 function "not" (Left : Unsigned_32) return Unsigned_32 is
257 return To_U32 (not From_U32 (Left));
260 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
262 return To_U32 (From_U32 (Left) and From_U32 (Right));
265 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
267 return To_U32 (From_U32 (Left) or From_U32 (Right));
270 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
272 return To_U32 (From_U32 (Left) xor From_U32 (Right));
275 -------------------------------------
276 -- Operations on Unsigned_Quadword --
277 -------------------------------------
279 -- It would be nice to replace these with intrinsics, but that does
280 -- not work yet (the back end would be ok, but GNAT itself objects)
282 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
283 -- Unsigned type of same length as Unsigned_Quadword
285 function To_QW is new Unchecked_Conversion (QWU, Unsigned_Quadword);
286 function From_QW is new Unchecked_Conversion (Unsigned_Quadword, QWU);
288 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
290 return To_QW (not From_QW (Left));
293 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
295 return To_QW (From_QW (Left) and From_QW (Right));
298 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
300 return To_QW (From_QW (Left) or From_QW (Right));
303 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
305 return To_QW (From_QW (Left) xor From_QW (Right));
308 -----------------------
309 -- Clear_Interlocked --
310 -----------------------
312 procedure Clear_Interlocked
313 (Bit : in out Boolean;
314 Old_Value : out Boolean)
321 end Clear_Interlocked;
323 procedure Clear_Interlocked
324 (Bit : in out Boolean;
325 Old_Value : out Boolean;
326 Retry_Count : in Natural;
327 Success_Flag : out Boolean)
333 Success_Flag := True;
335 end Clear_Interlocked;
337 ---------------------
338 -- Set_Interlocked --
339 ---------------------
341 procedure Set_Interlocked
342 (Bit : in out Boolean;
343 Old_Value : out Boolean)
352 procedure Set_Interlocked
353 (Bit : in out Boolean;
354 Old_Value : out Boolean;
355 Retry_Count : in Natural;
356 Success_Flag : out Boolean)
362 Success_Flag := True;
366 ---------------------
367 -- Add_Interlocked --
368 ---------------------
370 procedure Add_Interlocked
371 (Addend : in Short_Integer;
372 Augend : in out Aligned_Word;
377 Augend.Value := Augend.Value + Addend;
379 if Augend.Value < 0 then
381 elsif Augend.Value > 0 then
395 (To : in out Aligned_Integer;
400 To.Value := To.Value + Amount;
405 (To : in out Aligned_Integer;
407 Retry_Count : in Natural;
408 Old_Value : out Integer;
409 Success_Flag : out Boolean)
413 Old_Value := To.Value;
414 To.Value := To.Value + Amount;
415 Success_Flag := True;
420 (To : in out Aligned_Long_Integer;
421 Amount : in Long_Integer)
425 To.Value := To.Value + Amount;
430 (To : in out Aligned_Long_Integer;
431 Amount : in Long_Integer;
432 Retry_Count : in Natural;
433 Old_Value : out Long_Integer;
434 Success_Flag : out Boolean)
438 Old_Value := To.Value;
439 To.Value := To.Value + Amount;
440 Success_Flag := True;
448 type IU is mod 2 ** Integer'Size;
449 type LU is mod 2 ** Long_Integer'Size;
451 function To_IU is new Unchecked_Conversion (Integer, IU);
452 function From_IU is new Unchecked_Conversion (IU, Integer);
454 function To_LU is new Unchecked_Conversion (Long_Integer, LU);
455 function From_LU is new Unchecked_Conversion (LU, Long_Integer);
458 (To : in out Aligned_Integer;
463 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
468 (To : in out Aligned_Integer;
470 Retry_Count : in Natural;
471 Old_Value : out Integer;
472 Success_Flag : out Boolean)
476 Old_Value := To.Value;
477 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
478 Success_Flag := True;
483 (To : in out Aligned_Long_Integer;
484 From : in Long_Integer)
488 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
493 (To : in out Aligned_Long_Integer;
494 From : in Long_Integer;
495 Retry_Count : in Natural;
496 Old_Value : out Long_Integer;
497 Success_Flag : out Boolean)
501 Old_Value := To.Value;
502 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
503 Success_Flag := True;
512 (To : in out Aligned_Integer;
517 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
522 (To : in out Aligned_Integer;
524 Retry_Count : in Natural;
525 Old_Value : out Integer;
526 Success_Flag : out Boolean)
530 Old_Value := To.Value;
531 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
532 Success_Flag := True;
537 (To : in out Aligned_Long_Integer;
538 From : in Long_Integer)
542 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
547 (To : in out Aligned_Long_Integer;
548 From : in Long_Integer;
549 Retry_Count : in Natural;
550 Old_Value : out Long_Integer;
551 Success_Flag : out Boolean)
555 Old_Value := To.Value;
556 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
557 Success_Flag := True;
561 ------------------------------------
562 -- Declarations for Queue Objects --
563 ------------------------------------
567 type QR_Ptr is access QR;
574 function To_QR_Ptr is new Unchecked_Conversion (Address, QR_Ptr);
575 function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
584 Status : out Insq_Status)
586 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
587 Next : constant QR_Ptr := Hedr.Forward;
588 Itm : constant QR_Ptr := To_QR_Ptr (Item);
594 Itm.Backward := Hedr;
601 Next.Backward := Itm;
602 Status := OK_Not_First;
613 (Header : in Address;
615 Status : out Remq_Status)
617 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
618 Next : constant QR_Ptr := Hedr.Forward;
623 Item := From_QR_Ptr (Next);
626 Status := Fail_Was_Empty;
629 Hedr.Forward := To_QR_Ptr (Item).Forward;
631 if Hedr.Forward = null then
635 Hedr.Forward.Backward := Hedr;
636 Status := OK_Not_Empty;
650 Status : out Insq_Status)
652 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
653 Prev : constant QR_Ptr := Hedr.Backward;
654 Itm : constant QR_Ptr := To_QR_Ptr (Item);
659 Itm.Backward := Prev;
661 Hedr.Backward := Itm;
668 Status := OK_Not_First;
679 (Header : in Address;
681 Status : out Remq_Status)
683 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
684 Prev : constant QR_Ptr := Hedr.Backward;
689 Item := From_QR_Ptr (Prev);
692 Status := Fail_Was_Empty;
695 Hedr.Backward := To_QR_Ptr (Item).Backward;
697 if Hedr.Backward = null then
701 Hedr.Backward.Forward := Hedr;
702 Status := OK_Not_Empty;