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