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-2009, 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;