gcc/ada/s-auxdec.adb

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