Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-auxdec.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
| 68:561a7518be6b | 111:04ced10e8804 |
|---|---|
| 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; |