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