|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . A U X _ D E C --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
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.
|
|
|
35
|
|
|
36 with System.Soft_Links;
|
|
|
37
|
|
|
38 package body System.Aux_DEC is
|
|
|
39
|
|
|
40 package SSL renames System.Soft_Links;
|
|
|
41
|
|
|
42 -----------------------------------
|
|
|
43 -- Operations on Largest_Integer --
|
|
|
44 -----------------------------------
|
|
|
45
|
|
|
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)
|
|
|
48
|
|
|
49 type LIU is mod 2 ** Largest_Integer'Size;
|
|
|
50 -- Unsigned type of same length as Largest_Integer
|
|
|
51
|
|
|
52 function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer);
|
|
|
53 function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU);
|
|
|
54
|
|
|
55 function "not" (Left : Largest_Integer) return Largest_Integer is
|
|
|
56 begin
|
|
|
57 return To_LI (not From_LI (Left));
|
|
|
58 end "not";
|
|
|
59
|
|
|
60 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
|
|
|
61 begin
|
|
|
62 return To_LI (From_LI (Left) and From_LI (Right));
|
|
|
63 end "and";
|
|
|
64
|
|
|
65 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
|
|
|
66 begin
|
|
|
67 return To_LI (From_LI (Left) or From_LI (Right));
|
|
|
68 end "or";
|
|
|
69
|
|
|
70 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
|
|
|
71 begin
|
|
|
72 return To_LI (From_LI (Left) xor From_LI (Right));
|
|
|
73 end "xor";
|
|
|
74
|
|
|
75 --------------------------------------
|
|
|
76 -- Arithmetic Operations on Address --
|
|
|
77 --------------------------------------
|
|
|
78
|
|
|
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)
|
|
|
81
|
|
|
82 Asiz : constant Integer := Integer (Address'Size) - 1;
|
|
|
83
|
|
|
84 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
|
|
|
85 -- Signed type of same size as Address
|
|
|
86
|
|
|
87 function To_A is new Ada.Unchecked_Conversion (SA, Address);
|
|
|
88 function From_A is new Ada.Unchecked_Conversion (Address, SA);
|
|
|
89
|
|
|
90 function "+" (Left : Address; Right : Integer) return Address is
|
|
|
91 begin
|
|
|
92 return To_A (From_A (Left) + SA (Right));
|
|
|
93 end "+";
|
|
|
94
|
|
|
95 function "+" (Left : Integer; Right : Address) return Address is
|
|
|
96 begin
|
|
|
97 return To_A (SA (Left) + From_A (Right));
|
|
|
98 end "+";
|
|
|
99
|
|
|
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
|
|
|
103 begin
|
|
|
104 return Integer (From_A (Left) - From_A (Right));
|
|
|
105 end "-";
|
|
|
106
|
|
|
107 function "-" (Left : Address; Right : Integer) return Address is
|
|
|
108 begin
|
|
|
109 return To_A (From_A (Left) - SA (Right));
|
|
|
110 end "-";
|
|
|
111
|
|
|
112 ------------------------
|
|
|
113 -- Fetch_From_Address --
|
|
|
114 ------------------------
|
|
|
115
|
|
|
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);
|
|
|
120 begin
|
|
|
121 return Ptr.all;
|
|
|
122 end Fetch_From_Address;
|
|
|
123
|
|
|
124 -----------------------
|
|
|
125 -- Assign_To_Address --
|
|
|
126 -----------------------
|
|
|
127
|
|
|
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);
|
|
|
132 begin
|
|
|
133 Ptr.all := T;
|
|
|
134 end Assign_To_Address;
|
|
|
135
|
|
|
136 ---------------------------------
|
|
|
137 -- Operations on Unsigned_Byte --
|
|
|
138 ---------------------------------
|
|
|
139
|
|
|
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)
|
|
|
142
|
|
|
143 type BU is mod 2 ** Unsigned_Byte'Size;
|
|
|
144 -- Unsigned type of same length as Unsigned_Byte
|
|
|
145
|
|
|
146 function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte);
|
|
|
147 function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU);
|
|
|
148
|
|
|
149 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
|
|
|
150 begin
|
|
|
151 return To_B (not From_B (Left));
|
|
|
152 end "not";
|
|
|
153
|
|
|
154 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
|
|
|
155 begin
|
|
|
156 return To_B (From_B (Left) and From_B (Right));
|
|
|
157 end "and";
|
|
|
158
|
|
|
159 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
|
|
|
160 begin
|
|
|
161 return To_B (From_B (Left) or From_B (Right));
|
|
|
162 end "or";
|
|
|
163
|
|
|
164 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
|
|
|
165 begin
|
|
|
166 return To_B (From_B (Left) xor From_B (Right));
|
|
|
167 end "xor";
|
|
|
168
|
|
|
169 ---------------------------------
|
|
|
170 -- Operations on Unsigned_Word --
|
|
|
171 ---------------------------------
|
|
|
172
|
|
|
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)
|
|
|
175
|
|
|
176 type WU is mod 2 ** Unsigned_Word'Size;
|
|
|
177 -- Unsigned type of same length as Unsigned_Word
|
|
|
178
|
|
|
179 function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word);
|
|
|
180 function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU);
|
|
|
181
|
|
|
182 function "not" (Left : Unsigned_Word) return Unsigned_Word is
|
|
|
183 begin
|
|
|
184 return To_W (not From_W (Left));
|
|
|
185 end "not";
|
|
|
186
|
|
|
187 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
|
|
|
188 begin
|
|
|
189 return To_W (From_W (Left) and From_W (Right));
|
|
|
190 end "and";
|
|
|
191
|
|
|
192 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
|
|
|
193 begin
|
|
|
194 return To_W (From_W (Left) or From_W (Right));
|
|
|
195 end "or";
|
|
|
196
|
|
|
197 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
|
|
|
198 begin
|
|
|
199 return To_W (From_W (Left) xor From_W (Right));
|
|
|
200 end "xor";
|
|
|
201
|
|
|
202 -------------------------------------
|
|
|
203 -- Operations on Unsigned_Longword --
|
|
|
204 -------------------------------------
|
|
|
205
|
|
|
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)
|
|
|
208
|
|
|
209 type LWU is mod 2 ** Unsigned_Longword'Size;
|
|
|
210 -- Unsigned type of same length as Unsigned_Longword
|
|
|
211
|
|
|
212 function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword);
|
|
|
213 function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU);
|
|
|
214
|
|
|
215 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
|
|
|
216 begin
|
|
|
217 return To_LW (not From_LW (Left));
|
|
|
218 end "not";
|
|
|
219
|
|
|
220 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
|
|
|
221 begin
|
|
|
222 return To_LW (From_LW (Left) and From_LW (Right));
|
|
|
223 end "and";
|
|
|
224
|
|
|
225 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
|
|
|
226 begin
|
|
|
227 return To_LW (From_LW (Left) or From_LW (Right));
|
|
|
228 end "or";
|
|
|
229
|
|
|
230 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
|
|
|
231 begin
|
|
|
232 return To_LW (From_LW (Left) xor From_LW (Right));
|
|
|
233 end "xor";
|
|
|
234
|
|
|
235 -------------------------------
|
|
|
236 -- Operations on Unsigned_32 --
|
|
|
237 -------------------------------
|
|
|
238
|
|
|
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)
|
|
|
241
|
|
|
242 type U32 is mod 2 ** Unsigned_32'Size;
|
|
|
243 -- Unsigned type of same length as Unsigned_32
|
|
|
244
|
|
|
245 function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32);
|
|
|
246 function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32);
|
|
|
247
|
|
|
248 function "not" (Left : Unsigned_32) return Unsigned_32 is
|
|
|
249 begin
|
|
|
250 return To_U32 (not From_U32 (Left));
|
|
|
251 end "not";
|
|
|
252
|
|
|
253 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
|
|
|
254 begin
|
|
|
255 return To_U32 (From_U32 (Left) and From_U32 (Right));
|
|
|
256 end "and";
|
|
|
257
|
|
|
258 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
|
|
|
259 begin
|
|
|
260 return To_U32 (From_U32 (Left) or From_U32 (Right));
|
|
|
261 end "or";
|
|
|
262
|
|
|
263 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
|
|
|
264 begin
|
|
|
265 return To_U32 (From_U32 (Left) xor From_U32 (Right));
|
|
|
266 end "xor";
|
|
|
267
|
|
|
268 -------------------------------------
|
|
|
269 -- Operations on Unsigned_Quadword --
|
|
|
270 -------------------------------------
|
|
|
271
|
|
|
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)
|
|
|
274
|
|
|
275 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
|
|
|
276 -- Unsigned type of same length as Unsigned_Quadword
|
|
|
277
|
|
|
278 function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword);
|
|
|
279 function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU);
|
|
|
280
|
|
|
281 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
|
|
|
282 begin
|
|
|
283 return To_QW (not From_QW (Left));
|
|
|
284 end "not";
|
|
|
285
|
|
|
286 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
|
|
|
287 begin
|
|
|
288 return To_QW (From_QW (Left) and From_QW (Right));
|
|
|
289 end "and";
|
|
|
290
|
|
|
291 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
|
|
|
292 begin
|
|
|
293 return To_QW (From_QW (Left) or From_QW (Right));
|
|
|
294 end "or";
|
|
|
295
|
|
|
296 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
|
|
|
297 begin
|
|
|
298 return To_QW (From_QW (Left) xor From_QW (Right));
|
|
|
299 end "xor";
|
|
|
300
|
|
|
301 -----------------------
|
|
|
302 -- Clear_Interlocked --
|
|
|
303 -----------------------
|
|
|
304
|
|
|
305 procedure Clear_Interlocked
|
|
|
306 (Bit : in out Boolean;
|
|
|
307 Old_Value : out Boolean)
|
|
|
308 is
|
|
|
309 begin
|
|
|
310 SSL.Lock_Task.all;
|
|
|
311 Old_Value := Bit;
|
|
|
312 Bit := False;
|
|
|
313 SSL.Unlock_Task.all;
|
|
|
314 end Clear_Interlocked;
|
|
|
315
|
|
|
316 procedure Clear_Interlocked
|
|
|
317 (Bit : in out Boolean;
|
|
|
318 Old_Value : out Boolean;
|
|
|
319 Retry_Count : Natural;
|
|
|
320 Success_Flag : out Boolean)
|
|
|
321 is
|
|
|
322 pragma Warnings (Off, Retry_Count);
|
|
|
323
|
|
|
324 begin
|
|
|
325 SSL.Lock_Task.all;
|
|
|
326 Old_Value := Bit;
|
|
|
327 Bit := False;
|
|
|
328 Success_Flag := True;
|
|
|
329 SSL.Unlock_Task.all;
|
|
|
330 end Clear_Interlocked;
|
|
|
331
|
|
|
332 ---------------------
|
|
|
333 -- Set_Interlocked --
|
|
|
334 ---------------------
|
|
|
335
|
|
|
336 procedure Set_Interlocked
|
|
|
337 (Bit : in out Boolean;
|
|
|
338 Old_Value : out Boolean)
|
|
|
339 is
|
|
|
340 begin
|
|
|
341 SSL.Lock_Task.all;
|
|
|
342 Old_Value := Bit;
|
|
|
343 Bit := True;
|
|
|
344 SSL.Unlock_Task.all;
|
|
|
345 end Set_Interlocked;
|
|
|
346
|
|
|
347 procedure Set_Interlocked
|
|
|
348 (Bit : in out Boolean;
|
|
|
349 Old_Value : out Boolean;
|
|
|
350 Retry_Count : Natural;
|
|
|
351 Success_Flag : out Boolean)
|
|
|
352 is
|
|
|
353 pragma Warnings (Off, Retry_Count);
|
|
|
354
|
|
|
355 begin
|
|
|
356 SSL.Lock_Task.all;
|
|
|
357 Old_Value := Bit;
|
|
|
358 Bit := True;
|
|
|
359 Success_Flag := True;
|
|
|
360 SSL.Unlock_Task.all;
|
|
|
361 end Set_Interlocked;
|
|
|
362
|
|
|
363 ---------------------
|
|
|
364 -- Add_Interlocked --
|
|
|
365 ---------------------
|
|
|
366
|
|
|
367 procedure Add_Interlocked
|
|
|
368 (Addend : Short_Integer;
|
|
|
369 Augend : in out Aligned_Word;
|
|
|
370 Sign : out Integer)
|
|
|
371 is
|
|
|
372 begin
|
|
|
373 SSL.Lock_Task.all;
|
|
|
374 Augend.Value := Augend.Value + Addend;
|
|
|
375
|
|
|
376 if Augend.Value < 0 then
|
|
|
377 Sign := -1;
|
|
|
378 elsif Augend.Value > 0 then
|
|
|
379 Sign := +1;
|
|
|
380 else
|
|
|
381 Sign := 0;
|
|
|
382 end if;
|
|
|
383
|
|
|
384 SSL.Unlock_Task.all;
|
|
|
385 end Add_Interlocked;
|
|
|
386
|
|
|
387 ----------------
|
|
|
388 -- Add_Atomic --
|
|
|
389 ----------------
|
|
|
390
|
|
|
391 procedure Add_Atomic
|
|
|
392 (To : in out Aligned_Integer;
|
|
|
393 Amount : Integer)
|
|
|
394 is
|
|
|
395 begin
|
|
|
396 SSL.Lock_Task.all;
|
|
|
397 To.Value := To.Value + Amount;
|
|
|
398 SSL.Unlock_Task.all;
|
|
|
399 end Add_Atomic;
|
|
|
400
|
|
|
401 procedure Add_Atomic
|
|
|
402 (To : in out Aligned_Integer;
|
|
|
403 Amount : Integer;
|
|
|
404 Retry_Count : Natural;
|
|
|
405 Old_Value : out Integer;
|
|
|
406 Success_Flag : out Boolean)
|
|
|
407 is
|
|
|
408 pragma Warnings (Off, Retry_Count);
|
|
|
409
|
|
|
410 begin
|
|
|
411 SSL.Lock_Task.all;
|
|
|
412 Old_Value := To.Value;
|
|
|
413 To.Value := To.Value + Amount;
|
|
|
414 Success_Flag := True;
|
|
|
415 SSL.Unlock_Task.all;
|
|
|
416 end Add_Atomic;
|
|
|
417
|
|
|
418 procedure Add_Atomic
|
|
|
419 (To : in out Aligned_Long_Integer;
|
|
|
420 Amount : Long_Integer)
|
|
|
421 is
|
|
|
422 begin
|
|
|
423 SSL.Lock_Task.all;
|
|
|
424 To.Value := To.Value + Amount;
|
|
|
425 SSL.Unlock_Task.all;
|
|
|
426 end Add_Atomic;
|
|
|
427
|
|
|
428 procedure Add_Atomic
|
|
|
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)
|
|
|
434 is
|
|
|
435 pragma Warnings (Off, Retry_Count);
|
|
|
436
|
|
|
437 begin
|
|
|
438 SSL.Lock_Task.all;
|
|
|
439 Old_Value := To.Value;
|
|
|
440 To.Value := To.Value + Amount;
|
|
|
441 Success_Flag := True;
|
|
|
442 SSL.Unlock_Task.all;
|
|
|
443 end Add_Atomic;
|
|
|
444
|
|
|
445 ----------------
|
|
|
446 -- And_Atomic --
|
|
|
447 ----------------
|
|
|
448
|
|
|
449 type IU is mod 2 ** Integer'Size;
|
|
|
450 type LU is mod 2 ** Long_Integer'Size;
|
|
|
451
|
|
|
452 function To_IU is new Ada.Unchecked_Conversion (Integer, IU);
|
|
|
453 function From_IU is new Ada.Unchecked_Conversion (IU, Integer);
|
|
|
454
|
|
|
455 function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU);
|
|
|
456 function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer);
|
|
|
457
|
|
|
458 procedure And_Atomic
|
|
|
459 (To : in out Aligned_Integer;
|
|
|
460 From : Integer)
|
|
|
461 is
|
|
|
462 begin
|
|
|
463 SSL.Lock_Task.all;
|
|
|
464 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
|
|
|
465 SSL.Unlock_Task.all;
|
|
|
466 end And_Atomic;
|
|
|
467
|
|
|
468 procedure And_Atomic
|
|
|
469 (To : in out Aligned_Integer;
|
|
|
470 From : Integer;
|
|
|
471 Retry_Count : Natural;
|
|
|
472 Old_Value : out Integer;
|
|
|
473 Success_Flag : out Boolean)
|
|
|
474 is
|
|
|
475 pragma Warnings (Off, Retry_Count);
|
|
|
476
|
|
|
477 begin
|
|
|
478 SSL.Lock_Task.all;
|
|
|
479 Old_Value := To.Value;
|
|
|
480 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
|
|
|
481 Success_Flag := True;
|
|
|
482 SSL.Unlock_Task.all;
|
|
|
483 end And_Atomic;
|
|
|
484
|
|
|
485 procedure And_Atomic
|
|
|
486 (To : in out Aligned_Long_Integer;
|
|
|
487 From : Long_Integer)
|
|
|
488 is
|
|
|
489 begin
|
|
|
490 SSL.Lock_Task.all;
|
|
|
491 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
|
|
|
492 SSL.Unlock_Task.all;
|
|
|
493 end And_Atomic;
|
|
|
494
|
|
|
495 procedure And_Atomic
|
|
|
496 (To : in out Aligned_Long_Integer;
|
|
|
497 From : Long_Integer;
|
|
|
498 Retry_Count : Natural;
|
|
|
499 Old_Value : out Long_Integer;
|
|
|
500 Success_Flag : out Boolean)
|
|
|
501 is
|
|
|
502 pragma Warnings (Off, Retry_Count);
|
|
|
503
|
|
|
504 begin
|
|
|
505 SSL.Lock_Task.all;
|
|
|
506 Old_Value := To.Value;
|
|
|
507 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
|
|
|
508 Success_Flag := True;
|
|
|
509 SSL.Unlock_Task.all;
|
|
|
510 end And_Atomic;
|
|
|
511
|
|
|
512 ---------------
|
|
|
513 -- Or_Atomic --
|
|
|
514 ---------------
|
|
|
515
|
|
|
516 procedure Or_Atomic
|
|
|
517 (To : in out Aligned_Integer;
|
|
|
518 From : Integer)
|
|
|
519 is
|
|
|
520 begin
|
|
|
521 SSL.Lock_Task.all;
|
|
|
522 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
|
|
|
523 SSL.Unlock_Task.all;
|
|
|
524 end Or_Atomic;
|
|
|
525
|
|
|
526 procedure Or_Atomic
|
|
|
527 (To : in out Aligned_Integer;
|
|
|
528 From : Integer;
|
|
|
529 Retry_Count : Natural;
|
|
|
530 Old_Value : out Integer;
|
|
|
531 Success_Flag : out Boolean)
|
|
|
532 is
|
|
|
533 pragma Warnings (Off, Retry_Count);
|
|
|
534
|
|
|
535 begin
|
|
|
536 SSL.Lock_Task.all;
|
|
|
537 Old_Value := To.Value;
|
|
|
538 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
|
|
|
539 Success_Flag := True;
|
|
|
540 SSL.Unlock_Task.all;
|
|
|
541 end Or_Atomic;
|
|
|
542
|
|
|
543 procedure Or_Atomic
|
|
|
544 (To : in out Aligned_Long_Integer;
|
|
|
545 From : Long_Integer)
|
|
|
546 is
|
|
|
547 begin
|
|
|
548 SSL.Lock_Task.all;
|
|
|
549 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
|
|
|
550 SSL.Unlock_Task.all;
|
|
|
551 end Or_Atomic;
|
|
|
552
|
|
|
553 procedure Or_Atomic
|
|
|
554 (To : in out Aligned_Long_Integer;
|
|
|
555 From : Long_Integer;
|
|
|
556 Retry_Count : Natural;
|
|
|
557 Old_Value : out Long_Integer;
|
|
|
558 Success_Flag : out Boolean)
|
|
|
559 is
|
|
|
560 pragma Warnings (Off, Retry_Count);
|
|
|
561
|
|
|
562 begin
|
|
|
563 SSL.Lock_Task.all;
|
|
|
564 Old_Value := To.Value;
|
|
|
565 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
|
|
|
566 Success_Flag := True;
|
|
|
567 SSL.Unlock_Task.all;
|
|
|
568 end Or_Atomic;
|
|
|
569
|
|
|
570 ------------------------------------
|
|
|
571 -- Declarations for Queue Objects --
|
|
|
572 ------------------------------------
|
|
|
573
|
|
|
574 type QR;
|
|
|
575
|
|
|
576 type QR_Ptr is access QR;
|
|
|
577
|
|
|
578 type QR is record
|
|
|
579 Forward : QR_Ptr;
|
|
|
580 Backward : QR_Ptr;
|
|
|
581 end record;
|
|
|
582
|
|
|
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);
|
|
|
585
|
|
|
586 ------------
|
|
|
587 -- Insqhi --
|
|
|
588 ------------
|
|
|
589
|
|
|
590 procedure Insqhi
|
|
|
591 (Item : Address;
|
|
|
592 Header : Address;
|
|
|
593 Status : out Insq_Status)
|
|
|
594 is
|
|
|
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);
|
|
|
598
|
|
|
599 begin
|
|
|
600 SSL.Lock_Task.all;
|
|
|
601
|
|
|
602 Itm.Forward := Next;
|
|
|
603 Itm.Backward := Hedr;
|
|
|
604 Hedr.Forward := Itm;
|
|
|
605
|
|
|
606 if Next = null then
|
|
|
607 Status := OK_First;
|
|
|
608
|
|
|
609 else
|
|
|
610 Next.Backward := Itm;
|
|
|
611 Status := OK_Not_First;
|
|
|
612 end if;
|
|
|
613
|
|
|
614 SSL.Unlock_Task.all;
|
|
|
615 end Insqhi;
|
|
|
616
|
|
|
617 ------------
|
|
|
618 -- Remqhi --
|
|
|
619 ------------
|
|
|
620
|
|
|
621 procedure Remqhi
|
|
|
622 (Header : Address;
|
|
|
623 Item : out Address;
|
|
|
624 Status : out Remq_Status)
|
|
|
625 is
|
|
|
626 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
|
|
|
627 Next : constant QR_Ptr := Hedr.Forward;
|
|
|
628
|
|
|
629 begin
|
|
|
630 SSL.Lock_Task.all;
|
|
|
631
|
|
|
632 Item := From_QR_Ptr (Next);
|
|
|
633
|
|
|
634 if Next = null then
|
|
|
635 Status := Fail_Was_Empty;
|
|
|
636
|
|
|
637 else
|
|
|
638 Hedr.Forward := To_QR_Ptr (Item).Forward;
|
|
|
639
|
|
|
640 if Hedr.Forward = null then
|
|
|
641 Status := OK_Empty;
|
|
|
642
|
|
|
643 else
|
|
|
644 Hedr.Forward.Backward := Hedr;
|
|
|
645 Status := OK_Not_Empty;
|
|
|
646 end if;
|
|
|
647 end if;
|
|
|
648
|
|
|
649 SSL.Unlock_Task.all;
|
|
|
650 end Remqhi;
|
|
|
651
|
|
|
652 ------------
|
|
|
653 -- Insqti --
|
|
|
654 ------------
|
|
|
655
|
|
|
656 procedure Insqti
|
|
|
657 (Item : Address;
|
|
|
658 Header : Address;
|
|
|
659 Status : out Insq_Status)
|
|
|
660 is
|
|
|
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);
|
|
|
664
|
|
|
665 begin
|
|
|
666 SSL.Lock_Task.all;
|
|
|
667
|
|
|
668 Itm.Backward := Prev;
|
|
|
669 Itm.Forward := Hedr;
|
|
|
670 Hedr.Backward := Itm;
|
|
|
671
|
|
|
672 if Prev = null then
|
|
|
673 Status := OK_First;
|
|
|
674
|
|
|
675 else
|
|
|
676 Prev.Forward := Itm;
|
|
|
677 Status := OK_Not_First;
|
|
|
678 end if;
|
|
|
679
|
|
|
680 SSL.Unlock_Task.all;
|
|
|
681 end Insqti;
|
|
|
682
|
|
|
683 ------------
|
|
|
684 -- Remqti --
|
|
|
685 ------------
|
|
|
686
|
|
|
687 procedure Remqti
|
|
|
688 (Header : Address;
|
|
|
689 Item : out Address;
|
|
|
690 Status : out Remq_Status)
|
|
|
691 is
|
|
|
692 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
|
|
|
693 Prev : constant QR_Ptr := Hedr.Backward;
|
|
|
694
|
|
|
695 begin
|
|
|
696 SSL.Lock_Task.all;
|
|
|
697
|
|
|
698 Item := From_QR_Ptr (Prev);
|
|
|
699
|
|
|
700 if Prev = null then
|
|
|
701 Status := Fail_Was_Empty;
|
|
|
702
|
|
|
703 else
|
|
|
704 Hedr.Backward := To_QR_Ptr (Item).Backward;
|
|
|
705
|
|
|
706 if Hedr.Backward = null then
|
|
|
707 Status := OK_Empty;
|
|
|
708
|
|
|
709 else
|
|
|
710 Hedr.Backward.Forward := Hedr;
|
|
|
711 Status := OK_Not_Empty;
|
|
|
712 end if;
|
|
|
713 end if;
|
|
|
714
|
|
|
715 SSL.Unlock_Task.all;
|
|
|
716 end Remqti;
|
|
|
717
|
|
|
718 end System.Aux_DEC;
|
