gcc/ada/a-crdlli.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                       A D A . C O N T A I N E R S .                      --
   6 --        R E S R I C T E D  _ D O U B L Y _ L I N K E D _ L I S T S        --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, 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 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 with System;  use type System.Address;
  34
  35 package body Ada.Containers.Restricted_Doubly_Linked_Lists is
  36
  37    -----------------------
  38    -- Local Subprograms --
  39    -----------------------
  40
  41    procedure Allocate
  42      (Container : in out List'Class;
  43       New_Item  : Element_Type;
  44       New_Node  : out Count_Type);
  45
  46    procedure Free
  47      (Container : in out List'Class;
  48       X         : Count_Type);
  49
  50    procedure Insert_Internal
  51      (Container : in out List'Class;
  52       Before    : Count_Type;
  53       New_Node  : Count_Type);
  54
  55    function Vet (Position : Cursor) return Boolean;
  56
  57    ---------
  58    -- "=" --
  59    ---------
  60
  61    function "=" (Left, Right : List) return Boolean is
  62       LN : Node_Array renames Left.Nodes;
  63       RN : Node_Array renames Right.Nodes;
  64
  65       LI : Count_Type := Left.First;
  66       RI : Count_Type := Right.First;
  67
  68    begin
  69       if Left'Address = Right'Address then
  70          return True;
  71       end if;
  72
  73       if Left.Length /= Right.Length then
  74          return False;
  75       end if;
  76
  77       for J in 1 .. Left.Length loop
  78          if LN (LI).Element /= RN (RI).Element then
  79             return False;
  80          end if;
  81
  82          LI := LN (LI).Next;
  83          RI := RN (RI).Next;
  84       end loop;
  85
  86       return True;
  87    end "=";
  88
  89    --------------
  90    -- Allocate --
  91    --------------
  92
  93    procedure Allocate
  94      (Container : in out List'Class;
  95       New_Item  : Element_Type;
  96       New_Node  : out Count_Type)
  97    is
  98       N : Node_Array renames Container.Nodes;
  99
 100    begin
 101       if Container.Free >= 0 then
 102          New_Node := Container.Free;
 103          N (New_Node).Element := New_Item;
 104          Container.Free := N (New_Node).Next;
 105
 106       else
 107          New_Node := abs Container.Free;
 108          N (New_Node).Element := New_Item;
 109          Container.Free := Container.Free - 1;
 110       end if;
 111    end Allocate;
 112
 113    ------------
 114    -- Append --
 115    ------------
 116
 117    procedure Append
 118      (Container : in out List;
 119       New_Item  : Element_Type;
 120       Count     : Count_Type := 1)
 121    is
 122    begin
 123       Insert (Container, No_Element, New_Item, Count);
 124    end Append;
 125
 126    ------------
 127    -- Assign --
 128    ------------
 129
 130    procedure Assign (Target : in out List; Source : List) is
 131    begin
 132       if Target'Address = Source'Address then
 133          return;
 134       end if;
 135
 136       if Target.Capacity < Source.Length then
 137          raise Constraint_Error;  -- ???
 138       end if;
 139
 140       Clear (Target);
 141
 142       declare
 143          N : Node_Array renames Source.Nodes;
 144          J : Count_Type := Source.First;
 145
 146       begin
 147          while J /= 0 loop
 148             Append (Target, N (J).Element);
 149             J := N (J).Next;
 150          end loop;
 151       end;
 152    end Assign;
 153
 154    -----------
 155    -- Clear --
 156    -----------
 157
 158    procedure Clear (Container : in out List) is
 159       N : Node_Array renames Container.Nodes;
 160       X : Count_Type;
 161
 162    begin
 163       if Container.Length = 0 then
 164          pragma Assert (Container.First = 0);
 165          pragma Assert (Container.Last = 0);
 166 --       pragma Assert (Container.Busy = 0);
 167 --       pragma Assert (Container.Lock = 0);
 168          return;
 169       end if;
 170
 171       pragma Assert (Container.First >= 1);
 172       pragma Assert (Container.Last >= 1);
 173       pragma Assert (N (Container.First).Prev = 0);
 174       pragma Assert (N (Container.Last).Next = 0);
 175
 176 --    if Container.Busy > 0 then
 177 --      raise Program_Error;
 178 --    end if;
 179
 180       while Container.Length > 1 loop
 181          X := Container.First;
 182
 183          Container.First := N (X).Next;
 184          N (Container.First).Prev := 0;
 185
 186          Container.Length := Container.Length - 1;
 187
 188          Free (Container, X);
 189       end loop;
 190
 191       X := Container.First;
 192
 193       Container.First := 0;
 194       Container.Last := 0;
 195       Container.Length := 0;
 196
 197       Free (Container, X);
 198    end Clear;
 199
 200    --------------
 201    -- Contains --
 202    --------------
 203
 204    function Contains
 205      (Container : List;
 206       Item      : Element_Type) return Boolean
 207    is
 208    begin
 209       return Find (Container, Item) /= No_Element;
 210    end Contains;
 211
 212    ------------
 213    -- Delete --
 214    ------------
 215
 216    procedure Delete
 217      (Container : in out List;
 218       Position  : in out Cursor;
 219       Count     : Count_Type := 1)
 220    is
 221       N : Node_Array renames Container.Nodes;
 222       X : Count_Type;
 223
 224    begin
 225       if Position.Node = 0 then
 226          raise Constraint_Error;
 227       end if;
 228
 229       if Position.Container /= Container'Unrestricted_Access then
 230          raise Program_Error;
 231       end if;
 232
 233       pragma Assert (Vet (Position), "bad cursor in Delete");
 234
 235       if Position.Node = Container.First then
 236          Delete_First (Container, Count);
 237          Position := No_Element;
 238          return;
 239       end if;
 240
 241       if Count = 0 then
 242          Position := No_Element;
 243          return;
 244       end if;
 245
 246 --    if Container.Busy > 0 then
 247 --       raise Program_Error;
 248 --    end if;
 249
 250       pragma Assert (Container.First >= 1);
 251       pragma Assert (Container.Last >= 1);
 252       pragma Assert (N (Container.First).Prev = 0);
 253       pragma Assert (N (Container.Last).Next = 0);
 254
 255       for Index in 1 .. Count loop
 256          pragma Assert (Container.Length >= 2);
 257
 258          X := Position.Node;
 259          Container.Length := Container.Length - 1;
 260
 261          if X = Container.Last then
 262             Position := No_Element;
 263
 264             Container.Last := N (X).Prev;
 265             N (Container.Last).Next := 0;
 266
 267             Free (Container, X);
 268             return;
 269          end if;
 270
 271          Position.Node := N (X).Next;
 272
 273          N (N (X).Next).Prev := N (X).Prev;
 274          N (N (X).Prev).Next := N (X).Next;
 275
 276          Free (Container, X);
 277       end loop;
 278
 279       Position := No_Element;
 280    end Delete;
 281
 282    ------------------
 283    -- Delete_First --
 284    ------------------
 285
 286    procedure Delete_First
 287      (Container : in out List;
 288       Count     : Count_Type := 1)
 289    is
 290       N : Node_Array renames Container.Nodes;
 291       X : Count_Type;
 292
 293    begin
 294       if Count >= Container.Length then
 295          Clear (Container);
 296          return;
 297       end if;
 298
 299       if Count = 0 then
 300          return;
 301       end if;
 302
 303 --    if Container.Busy > 0 then
 304 --       raise Program_Error;
 305 --    end if;
 306
 307       for I in 1 .. Count loop
 308          X := Container.First;
 309          pragma Assert (N (N (X).Next).Prev = Container.First);
 310
 311          Container.First := N (X).Next;
 312          N (Container.First).Prev := 0;
 313
 314          Container.Length := Container.Length - 1;
 315
 316          Free (Container, X);
 317       end loop;
 318    end Delete_First;
 319
 320    -----------------
 321    -- Delete_Last --
 322    -----------------
 323
 324    procedure Delete_Last
 325      (Container : in out List;
 326       Count     : Count_Type := 1)
 327    is
 328       N : Node_Array renames Container.Nodes;
 329       X : Count_Type;
 330
 331    begin
 332       if Count >= Container.Length then
 333          Clear (Container);
 334          return;
 335       end if;
 336
 337       if Count = 0 then
 338          return;
 339       end if;
 340
 341 --    if Container.Busy > 0 then
 342 --       raise Program_Error;
 343 --    end if;
 344
 345       for I in 1 .. Count loop
 346          X := Container.Last;
 347          pragma Assert (N (N (X).Prev).Next = Container.Last);
 348
 349          Container.Last := N (X).Prev;
 350          N (Container.Last).Next := 0;
 351
 352          Container.Length := Container.Length - 1;
 353
 354          Free (Container, X);
 355       end loop;
 356    end Delete_Last;
 357
 358    -------------
 359    -- Element --
 360    -------------
 361
 362    function Element (Position : Cursor) return Element_Type is
 363    begin
 364       if Position.Node = 0 then
 365          raise Constraint_Error;
 366       end if;
 367
 368       pragma Assert (Vet (Position), "bad cursor in Element");
 369
 370       declare
 371          N : Node_Array renames Position.Container.Nodes;
 372       begin
 373          return N (Position.Node).Element;
 374       end;
 375    end Element;
 376
 377    ----------
 378    -- Find --
 379    ----------
 380
 381    function Find
 382      (Container : List;
 383       Item      : Element_Type;
 384       Position  : Cursor := No_Element) return Cursor
 385    is
 386       Nodes : Node_Array renames Container.Nodes;
 387       Node  : Count_Type := Position.Node;
 388
 389    begin
 390       if Node = 0 then
 391          Node := Container.First;
 392
 393       else
 394          if Position.Container /= Container'Unrestricted_Access then
 395             raise Program_Error;
 396          end if;
 397
 398          pragma Assert (Vet (Position), "bad cursor in Find");
 399       end if;
 400
 401       while Node /= 0 loop
 402          if Nodes (Node).Element = Item then
 403             return Cursor'(Container'Unrestricted_Access, Node);
 404          end if;
 405
 406          Node := Nodes (Node).Next;
 407       end loop;
 408
 409       return No_Element;
 410    end Find;
 411
 412    -----------
 413    -- First --
 414    -----------
 415
 416    function First (Container : List) return Cursor is
 417    begin
 418       if Container.First = 0 then
 419          return No_Element;
 420       end if;
 421
 422       return Cursor'(Container'Unrestricted_Access, Container.First);
 423    end First;
 424
 425    -------------------
 426    -- First_Element --
 427    -------------------
 428
 429    function First_Element (Container : List) return Element_Type is
 430       N : Node_Array renames Container.Nodes;
 431
 432    begin
 433       if Container.First = 0 then
 434          raise Constraint_Error;
 435       end if;
 436
 437       return N (Container.First).Element;
 438    end First_Element;
 439
 440    ----------
 441    -- Free --
 442    ----------
 443
 444    procedure Free
 445      (Container : in out List'Class;
 446       X         : Count_Type)
 447    is
 448       pragma Assert (X > 0);
 449       pragma Assert (X <= Container.Capacity);
 450
 451       N : Node_Array renames Container.Nodes;
 452
 453    begin
 454       N (X).Prev := -1;  -- Node is deallocated (not on active list)
 455
 456       if Container.Free >= 0 then
 457          N (X).Next := Container.Free;
 458          Container.Free := X;
 459
 460       elsif X + 1 = abs Container.Free then
 461          N (X).Next := 0;  -- Not strictly necessary, but marginally safer
 462          Container.Free := Container.Free + 1;
 463
 464       else
 465          Container.Free := abs Container.Free;
 466
 467          if Container.Free > Container.Capacity then
 468             Container.Free := 0;
 469
 470          else
 471             for I in Container.Free .. Container.Capacity - 1 loop
 472                N (I).Next := I + 1;
 473             end loop;
 474
 475             N (Container.Capacity).Next := 0;
 476          end if;
 477
 478          N (X).Next := Container.Free;
 479          Container.Free := X;
 480       end if;
 481    end Free;
 482
 483    ---------------------
 484    -- Generic_Sorting --
 485    ---------------------
 486
 487    package body Generic_Sorting is
 488
 489       ---------------
 490       -- Is_Sorted --
 491       ---------------
 492
 493       function Is_Sorted (Container : List) return Boolean is
 494          Nodes : Node_Array renames Container.Nodes;
 495          Node  : Count_Type := Container.First;
 496
 497       begin
 498          for I in 2 .. Container.Length loop
 499             if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
 500                return False;
 501             end if;
 502
 503             Node := Nodes (Node).Next;
 504          end loop;
 505
 506          return True;
 507       end Is_Sorted;
 508
 509       ----------
 510       -- Sort --
 511       ----------
 512
 513       procedure Sort (Container : in out List) is
 514          N : Node_Array renames Container.Nodes;
 515
 516          procedure Partition (Pivot, Back : Count_Type);
 517          procedure Sort (Front, Back : Count_Type);
 518
 519          ---------------
 520          -- Partition --
 521          ---------------
 522
 523          procedure Partition (Pivot, Back : Count_Type) is
 524             Node : Count_Type := N (Pivot).Next;
 525
 526          begin
 527             while Node /= Back loop
 528                if N (Node).Element < N (Pivot).Element then
 529                   declare
 530                      Prev : constant Count_Type := N (Node).Prev;
 531                      Next : constant Count_Type := N (Node).Next;
 532
 533                   begin
 534                      N (Prev).Next := Next;
 535
 536                      if Next = 0 then
 537                         Container.Last := Prev;
 538                      else
 539                         N (Next).Prev := Prev;
 540                      end if;
 541
 542                      N (Node).Next := Pivot;
 543                      N (Node).Prev := N (Pivot).Prev;
 544
 545                      N (Pivot).Prev := Node;
 546
 547                      if N (Node).Prev = 0 then
 548                         Container.First := Node;
 549                      else
 550                         N (N (Node).Prev).Next := Node;
 551                      end if;
 552
 553                      Node := Next;
 554                   end;
 555
 556                else
 557                   Node := N (Node).Next;
 558                end if;
 559             end loop;
 560          end Partition;
 561
 562          ----------
 563          -- Sort --
 564          ----------
 565
 566          procedure Sort (Front, Back : Count_Type) is
 567             Pivot : Count_Type;
 568
 569          begin
 570             if Front = 0 then
 571                Pivot := Container.First;
 572             else
 573                Pivot := N (Front).Next;
 574             end if;
 575
 576             if Pivot /= Back then
 577                Partition (Pivot, Back);
 578                Sort (Front, Pivot);
 579                Sort (Pivot, Back);
 580             end if;
 581          end Sort;
 582
 583       --  Start of processing for Sort
 584
 585       begin
 586          if Container.Length <= 1 then
 587             return;
 588          end if;
 589
 590          pragma Assert (N (Container.First).Prev = 0);
 591          pragma Assert (N (Container.Last).Next = 0);
 592
 593 --       if Container.Busy > 0 then
 594 --          raise Program_Error;
 595 --       end if;
 596
 597          Sort (Front => 0, Back => 0);
 598
 599          pragma Assert (N (Container.First).Prev = 0);
 600          pragma Assert (N (Container.Last).Next = 0);
 601       end Sort;
 602
 603    end Generic_Sorting;
 604
 605    -----------------
 606    -- Has_Element --
 607    -----------------
 608
 609    function Has_Element (Position : Cursor) return Boolean is
 610    begin
 611       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 612       return Position.Node /= 0;
 613    end Has_Element;
 614
 615    ------------
 616    -- Insert --
 617    ------------
 618
 619    procedure Insert
 620      (Container : in out List;
 621       Before    : Cursor;
 622       New_Item  : Element_Type;
 623       Position  : out Cursor;
 624       Count     : Count_Type := 1)
 625    is
 626       J : Count_Type;
 627
 628    begin
 629       if Before.Container /= null then
 630          if Before.Container /= Container'Unrestricted_Access then
 631             raise Program_Error;
 632          end if;
 633
 634          pragma Assert (Vet (Before), "bad cursor in Insert");
 635       end if;
 636
 637       if Count = 0 then
 638          Position := Before;
 639          return;
 640       end if;
 641
 642       if Container.Length > Container.Capacity - Count then
 643          raise Constraint_Error;
 644       end if;
 645
 646 --    if Container.Busy > 0 then
 647 --       raise Program_Error;
 648 --    end if;
 649
 650       Allocate (Container, New_Item, New_Node => J);
 651       Insert_Internal (Container, Before.Node, New_Node => J);
 652       Position := Cursor'(Container'Unrestricted_Access, Node => J);
 653
 654       for Index in 2 .. Count loop
 655          Allocate (Container, New_Item, New_Node => J);
 656          Insert_Internal (Container, Before.Node, New_Node => J);
 657       end loop;
 658    end Insert;
 659
 660    procedure Insert
 661      (Container : in out List;
 662       Before    : Cursor;
 663       New_Item  : Element_Type;
 664       Count     : Count_Type := 1)
 665    is
 666       Position : Cursor;
 667       pragma Unreferenced (Position);
 668    begin
 669       Insert (Container, Before, New_Item, Position, Count);
 670    end Insert;
 671
 672    procedure Insert
 673      (Container : in out List;
 674       Before    : Cursor;
 675       Position  : out Cursor;
 676       Count     : Count_Type := 1)
 677    is
 678       New_Item : Element_Type;  -- Do we need to reinit node ???
 679       pragma Warnings (Off, New_Item);
 680
 681    begin
 682       Insert (Container, Before, New_Item, Position, Count);
 683    end Insert;
 684
 685    ---------------------
 686    -- Insert_Internal --
 687    ---------------------
 688
 689    procedure Insert_Internal
 690      (Container : in out List'Class;
 691       Before    : Count_Type;
 692       New_Node  : Count_Type)
 693    is
 694       N : Node_Array renames Container.Nodes;
 695
 696    begin
 697       if Container.Length = 0 then
 698          pragma Assert (Before = 0);
 699          pragma Assert (Container.First = 0);
 700          pragma Assert (Container.Last = 0);
 701
 702          Container.First := New_Node;
 703          Container.Last := New_Node;
 704
 705          N (Container.First).Prev := 0;
 706          N (Container.Last).Next := 0;
 707
 708       elsif Before = 0 then
 709          pragma Assert (N (Container.Last).Next = 0);
 710
 711          N (Container.Last).Next := New_Node;
 712          N (New_Node).Prev := Container.Last;
 713
 714          Container.Last := New_Node;
 715          N (Container.Last).Next := 0;
 716
 717       elsif Before = Container.First then
 718          pragma Assert (N (Container.First).Prev = 0);
 719
 720          N (Container.First).Prev := New_Node;
 721          N (New_Node).Next := Container.First;
 722
 723          Container.First := New_Node;
 724          N (Container.First).Prev := 0;
 725
 726       else
 727          pragma Assert (N (Container.First).Prev = 0);
 728          pragma Assert (N (Container.Last).Next = 0);
 729
 730          N (New_Node).Next := Before;
 731          N (New_Node).Prev := N (Before).Prev;
 732
 733          N (N (Before).Prev).Next := New_Node;
 734          N (Before).Prev := New_Node;
 735       end if;
 736
 737       Container.Length := Container.Length + 1;
 738    end Insert_Internal;
 739
 740    --------------
 741    -- Is_Empty --
 742    --------------
 743
 744    function Is_Empty (Container : List) return Boolean is
 745    begin
 746       return Container.Length = 0;
 747    end Is_Empty;
 748
 749    -------------
 750    -- Iterate --
 751    -------------
 752
 753    procedure Iterate
 754      (Container : List;
 755       Process   : not null access procedure (Position : Cursor))
 756    is
 757       C : List renames Container'Unrestricted_Access.all;
 758       N : Node_Array renames C.Nodes;
 759 --    B : Natural renames C.Busy;
 760
 761       Node  : Count_Type := Container.First;
 762
 763       Index     : Count_Type := 0;
 764       Index_Max : constant Count_Type := Container.Length;
 765
 766    begin
 767       if Index_Max = 0 then
 768          pragma Assert (Node = 0);
 769          return;
 770       end if;
 771
 772       loop
 773          pragma Assert (Node /= 0);
 774
 775          Process (Cursor'(C'Unchecked_Access, Node));
 776          pragma Assert (Container.Length = Index_Max);
 777          pragma Assert (N (Node).Prev /= -1);
 778
 779          Node := N (Node).Next;
 780          Index := Index + 1;
 781
 782          if Index = Index_Max then
 783             pragma Assert (Node = 0);
 784             return;
 785          end if;
 786       end loop;
 787    end Iterate;
 788
 789    ----------
 790    -- Last --
 791    ----------
 792
 793    function Last (Container : List) return Cursor is
 794    begin
 795       if Container.Last = 0 then
 796          return No_Element;
 797       end if;
 798
 799       return Cursor'(Container'Unrestricted_Access, Container.Last);
 800    end Last;
 801
 802    ------------------
 803    -- Last_Element --
 804    ------------------
 805
 806    function Last_Element (Container : List) return Element_Type is
 807       N : Node_Array renames Container.Nodes;
 808
 809    begin
 810       if Container.Last = 0 then
 811          raise Constraint_Error;
 812       end if;
 813
 814       return N (Container.Last).Element;
 815    end Last_Element;
 816
 817    ------------
 818    -- Length --
 819    ------------
 820
 821    function Length (Container : List) return Count_Type is
 822    begin
 823       return Container.Length;
 824    end Length;
 825
 826    ----------
 827    -- Next --
 828    ----------
 829
 830    procedure Next (Position : in out Cursor) is
 831    begin
 832       Position := Next (Position);
 833    end Next;
 834
 835    function Next (Position : Cursor) return Cursor is
 836    begin
 837       if Position.Node = 0 then
 838          return No_Element;
 839       end if;
 840
 841       pragma Assert (Vet (Position), "bad cursor in Next");
 842
 843       declare
 844          Nodes : Node_Array renames Position.Container.Nodes;
 845          Node  : constant Count_Type := Nodes (Position.Node).Next;
 846
 847       begin
 848          if Node = 0 then
 849             return No_Element;
 850          end if;
 851
 852          return Cursor'(Position.Container, Node);
 853       end;
 854    end Next;
 855
 856    -------------
 857    -- Prepend --
 858    -------------
 859
 860    procedure Prepend
 861      (Container : in out List;
 862       New_Item  : Element_Type;
 863       Count     : Count_Type := 1)
 864    is
 865    begin
 866       Insert (Container, First (Container), New_Item, Count);
 867    end Prepend;
 868
 869    --------------
 870    -- Previous --
 871    --------------
 872
 873    procedure Previous (Position : in out Cursor) is
 874    begin
 875       Position := Previous (Position);
 876    end Previous;
 877
 878    function Previous (Position : Cursor) return Cursor is
 879    begin
 880       if Position.Node = 0 then
 881          return No_Element;
 882       end if;
 883
 884       pragma Assert (Vet (Position), "bad cursor in Previous");
 885
 886       declare
 887          Nodes : Node_Array renames Position.Container.Nodes;
 888          Node  : constant Count_Type := Nodes (Position.Node).Prev;
 889       begin
 890          if Node = 0 then
 891             return No_Element;
 892          end if;
 893
 894          return Cursor'(Position.Container, Node);
 895       end;
 896    end Previous;
 897
 898    -------------------
 899    -- Query_Element --
 900    -------------------
 901
 902    procedure Query_Element
 903      (Position : Cursor;
 904       Process  : not null access procedure (Element : Element_Type))
 905    is
 906    begin
 907       if Position.Node = 0 then
 908          raise Constraint_Error;
 909       end if;
 910
 911       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 912
 913       declare
 914          C : List renames Position.Container.all'Unrestricted_Access.all;
 915          N : Node_Type renames C.Nodes (Position.Node);
 916
 917       begin
 918          Process (N.Element);
 919          pragma Assert (N.Prev >= 0);
 920       end;
 921    end Query_Element;
 922
 923    ---------------------
 924    -- Replace_Element --
 925    ---------------------
 926
 927    procedure Replace_Element
 928      (Container : in out List;
 929       Position  : Cursor;
 930       New_Item  : Element_Type)
 931    is
 932    begin
 933       if Position.Container = null then
 934          raise Constraint_Error;
 935       end if;
 936
 937       if Position.Container /= Container'Unrestricted_Access then
 938          raise Program_Error;
 939       end if;
 940
 941 --    if Container.Lock > 0 then
 942 --       raise Program_Error;
 943 --    end if;
 944
 945       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 946
 947       declare
 948          N : Node_Array renames Container.Nodes;
 949       begin
 950          N (Position.Node).Element := New_Item;
 951       end;
 952    end Replace_Element;
 953
 954    ----------------------
 955    -- Reverse_Elements --
 956    ----------------------
 957
 958    procedure Reverse_Elements (Container : in out List) is
 959       N : Node_Array renames Container.Nodes;
 960       I : Count_Type := Container.First;
 961       J : Count_Type := Container.Last;
 962
 963       procedure Swap (L, R : Count_Type);
 964
 965       ----------
 966       -- Swap --
 967       ----------
 968
 969       procedure Swap (L, R : Count_Type) is
 970          LN : constant Count_Type := N (L).Next;
 971          LP : constant Count_Type := N (L).Prev;
 972
 973          RN : constant Count_Type := N (R).Next;
 974          RP : constant Count_Type := N (R).Prev;
 975
 976       begin
 977          if LP /= 0 then
 978             N (LP).Next := R;
 979          end if;
 980
 981          if RN /= 0 then
 982             N (RN).Prev := L;
 983          end if;
 984
 985          N (L).Next := RN;
 986          N (R).Prev := LP;
 987
 988          if LN = R then
 989             pragma Assert (RP = L);
 990
 991             N (L).Prev := R;
 992             N (R).Next := L;
 993
 994          else
 995             N (L).Prev := RP;
 996             N (RP).Next := L;
 997
 998             N (R).Next := LN;
 999             N (LN).Prev := R;
1000          end if;
1001       end Swap;
1002
1003    --  Start of processing for Reverse_Elements
1004
1005    begin
1006       if Container.Length <= 1 then
1007          return;
1008       end if;
1009
1010       pragma Assert (N (Container.First).Prev = 0);
1011       pragma Assert (N (Container.Last).Next = 0);
1012
1013 --    if Container.Busy > 0 then
1014 --       raise Program_Error;
1015 --    end if;
1016
1017       Container.First := J;
1018       Container.Last := I;
1019       loop
1020          Swap (L => I, R => J);
1021
1022          J := N (J).Next;
1023          exit when I = J;
1024
1025          I := N (I).Prev;
1026          exit when I = J;
1027
1028          Swap (L => J, R => I);
1029
1030          I := N (I).Next;
1031          exit when I = J;
1032
1033          J := N (J).Prev;
1034          exit when I = J;
1035       end loop;
1036
1037       pragma Assert (N (Container.First).Prev = 0);
1038       pragma Assert (N (Container.Last).Next = 0);
1039    end Reverse_Elements;
1040
1041    ------------------
1042    -- Reverse_Find --
1043    ------------------
1044
1045    function Reverse_Find
1046      (Container : List;
1047       Item      : Element_Type;
1048       Position  : Cursor := No_Element) return Cursor
1049    is
1050       N    : Node_Array renames Container.Nodes;
1051       Node : Count_Type := Position.Node;
1052
1053    begin
1054       if Node = 0 then
1055          Node := Container.Last;
1056
1057       else
1058          if Position.Container /= Container'Unrestricted_Access then
1059             raise Program_Error;
1060          end if;
1061
1062          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1063       end if;
1064
1065       while Node /= 0 loop
1066          if N (Node).Element = Item then
1067             return Cursor'(Container'Unrestricted_Access, Node);
1068          end if;
1069
1070          Node := N (Node).Prev;
1071       end loop;
1072
1073       return No_Element;
1074    end Reverse_Find;
1075
1076    ---------------------
1077    -- Reverse_Iterate --
1078    ---------------------
1079
1080    procedure Reverse_Iterate
1081      (Container : List;
1082       Process   : not null access procedure (Position : Cursor))
1083    is
1084       C : List renames Container'Unrestricted_Access.all;
1085       N : Node_Array renames C.Nodes;
1086 --    B : Natural renames C.Busy;
1087
1088       Node : Count_Type := Container.Last;
1089
1090       Index     : Count_Type := 0;
1091       Index_Max : constant Count_Type := Container.Length;
1092
1093    begin
1094       if Index_Max = 0 then
1095          pragma Assert (Node = 0);
1096          return;
1097       end if;
1098
1099       loop
1100          pragma Assert (Node > 0);
1101
1102          Process (Cursor'(C'Unchecked_Access, Node));
1103          pragma Assert (Container.Length = Index_Max);
1104          pragma Assert (N (Node).Prev /= -1);
1105
1106          Node := N (Node).Prev;
1107          Index := Index + 1;
1108
1109          if Index = Index_Max then
1110             pragma Assert (Node = 0);
1111             return;
1112          end if;
1113       end loop;
1114    end Reverse_Iterate;
1115
1116    ------------
1117    -- Splice --
1118    ------------
1119
1120    procedure Splice
1121      (Container : in out List;
1122       Before    : Cursor;
1123       Position  : in out Cursor)
1124    is
1125       N : Node_Array renames Container.Nodes;
1126
1127    begin
1128       if Before.Container /= null then
1129          if Before.Container /= Container'Unrestricted_Access then
1130             raise Program_Error;
1131          end if;
1132
1133          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1134       end if;
1135
1136       if Position.Node = 0 then
1137          raise Constraint_Error;
1138       end if;
1139
1140       if Position.Container /= Container'Unrestricted_Access then
1141          raise Program_Error;
1142       end if;
1143
1144       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1145
1146       if Position.Node = Before.Node
1147         or else N (Position.Node).Next = Before.Node
1148       then
1149          return;
1150       end if;
1151
1152       pragma Assert (Container.Length >= 2);
1153
1154 --    if Container.Busy > 0 then
1155 --       raise Program_Error;
1156 --    end if;
1157
1158       if Before.Node = 0 then
1159          pragma Assert (Position.Node /= Container.Last);
1160
1161          if Position.Node = Container.First then
1162             Container.First := N (Position.Node).Next;
1163             N (Container.First).Prev := 0;
1164
1165          else
1166             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1167             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1168          end if;
1169
1170          N (Container.Last).Next := Position.Node;
1171          N (Position.Node).Prev := Container.Last;
1172
1173          Container.Last := Position.Node;
1174          N (Container.Last).Next := 0;
1175
1176          return;
1177       end if;
1178
1179       if Before.Node = Container.First then
1180          pragma Assert (Position.Node /= Container.First);
1181
1182          if Position.Node = Container.Last then
1183             Container.Last := N (Position.Node).Prev;
1184             N (Container.Last).Next := 0;
1185
1186          else
1187             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1188             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1189          end if;
1190
1191          N (Container.First).Prev := Position.Node;
1192          N (Position.Node).Next := Container.First;
1193
1194          Container.First := Position.Node;
1195          N (Container.First).Prev := 0;
1196
1197          return;
1198       end if;
1199
1200       if Position.Node = Container.First then
1201          Container.First := N (Position.Node).Next;
1202          N (Container.First).Prev := 0;
1203
1204       elsif Position.Node = Container.Last then
1205          Container.Last := N (Position.Node).Prev;
1206          N (Container.Last).Next := 0;
1207
1208       else
1209          N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1210          N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1211       end if;
1212
1213       N (N (Before.Node).Prev).Next := Position.Node;
1214       N (Position.Node).Prev := N (Before.Node).Prev;
1215
1216       N (Before.Node).Prev := Position.Node;
1217       N (Position.Node).Next := Before.Node;
1218
1219       pragma Assert (N (Container.First).Prev = 0);
1220       pragma Assert (N (Container.Last).Next = 0);
1221    end Splice;
1222
1223    ----------
1224    -- Swap --
1225    ----------
1226
1227    procedure Swap
1228      (Container : in out List;
1229       I, J      : Cursor)
1230    is
1231    begin
1232       if I.Node = 0
1233         or else J.Node = 0
1234       then
1235          raise Constraint_Error;
1236       end if;
1237
1238       if I.Container /= Container'Unrestricted_Access
1239         or else J.Container /= Container'Unrestricted_Access
1240       then
1241          raise Program_Error;
1242       end if;
1243
1244       if I.Node = J.Node then
1245          return;
1246       end if;
1247
1248 --    if Container.Lock > 0 then
1249 --       raise Program_Error;
1250 --    end if;
1251
1252       pragma Assert (Vet (I), "bad I cursor in Swap");
1253       pragma Assert (Vet (J), "bad J cursor in Swap");
1254
1255       declare
1256          N  : Node_Array renames Container.Nodes;
1257
1258          EI : Element_Type renames N (I.Node).Element;
1259          EJ : Element_Type renames N (J.Node).Element;
1260
1261          EI_Copy : constant Element_Type := EI;
1262
1263       begin
1264          EI := EJ;
1265          EJ := EI_Copy;
1266       end;
1267    end Swap;
1268
1269    ----------------
1270    -- Swap_Links --
1271    ----------------
1272
1273    procedure Swap_Links
1274      (Container : in out List;
1275       I, J      : Cursor)
1276    is
1277    begin
1278       if I.Node = 0
1279         or else J.Node = 0
1280       then
1281          raise Constraint_Error;
1282       end if;
1283
1284       if I.Container /= Container'Unrestricted_Access
1285         or else I.Container /= J.Container
1286       then
1287          raise Program_Error;
1288       end if;
1289
1290       if I.Node = J.Node then
1291          return;
1292       end if;
1293
1294 --    if Container.Busy > 0 then
1295 --       raise Program_Error;
1296 --    end if;
1297
1298       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1299       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1300
1301       declare
1302          I_Next : constant Cursor := Next (I);
1303
1304          J_Copy : Cursor := J;
1305          pragma Warnings (Off, J_Copy);
1306
1307       begin
1308          if I_Next = J then
1309             Splice (Container, Before => I, Position => J_Copy);
1310
1311          else
1312             declare
1313                J_Next : constant Cursor := Next (J);
1314
1315                I_Copy : Cursor := I;
1316                pragma Warnings (Off, I_Copy);
1317
1318             begin
1319                if J_Next = I then
1320                   Splice (Container, Before => J, Position => I_Copy);
1321
1322                else
1323                   pragma Assert (Container.Length >= 3);
1324
1325                   Splice (Container, Before => I_Next, Position => J_Copy);
1326                   Splice (Container, Before => J_Next, Position => I_Copy);
1327                end if;
1328             end;
1329          end if;
1330       end;
1331    end Swap_Links;
1332
1333    --------------------
1334    -- Update_Element --
1335    --------------------
1336
1337    procedure Update_Element
1338      (Container : in out List;
1339       Position  : Cursor;
1340       Process   : not null access procedure (Element : in out Element_Type))
1341    is
1342    begin
1343       if Position.Node = 0 then
1344          raise Constraint_Error;
1345       end if;
1346
1347       if Position.Container /= Container'Unrestricted_Access then
1348          raise Program_Error;
1349       end if;
1350
1351       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1352
1353       declare
1354          N  : Node_Type renames Container.Nodes (Position.Node);
1355
1356       begin
1357          Process (N.Element);
1358          pragma Assert (N.Prev >= 0);
1359       end;
1360    end Update_Element;
1361
1362    ---------
1363    -- Vet --
1364    ---------
1365
1366    function Vet (Position : Cursor) return Boolean is
1367    begin
1368       if Position.Node = 0 then
1369          return Position.Container = null;
1370       end if;
1371
1372       if Position.Container = null then
1373          return False;
1374       end if;
1375
1376       declare
1377          L : List renames Position.Container.all;
1378          N : Node_Array renames L.Nodes;
1379
1380       begin
1381          if L.Length = 0 then
1382             return False;
1383          end if;
1384
1385          if L.First = 0 then
1386             return False;
1387          end if;
1388
1389          if L.Last = 0 then
1390             return False;
1391          end if;
1392
1393          if Position.Node > L.Capacity then
1394             return False;
1395          end if;
1396
1397          if N (Position.Node).Prev < 0
1398            or else N (Position.Node).Prev > L.Capacity
1399          then
1400             return False;
1401          end if;
1402
1403          if N (Position.Node).Next > L.Capacity then
1404             return False;
1405          end if;
1406
1407          if N (L.First).Prev /= 0 then
1408             return False;
1409          end if;
1410
1411          if N (L.Last).Next /= 0 then
1412             return False;
1413          end if;
1414
1415          if N (Position.Node).Prev = 0
1416            and then Position.Node /= L.First
1417          then
1418             return False;
1419          end if;
1420
1421          if N (Position.Node).Next = 0
1422            and then Position.Node /= L.Last
1423          then
1424             return False;
1425          end if;
1426
1427          if L.Length = 1 then
1428             return L.First = L.Last;
1429          end if;
1430
1431          if L.First = L.Last then
1432             return False;
1433          end if;
1434
1435          if N (L.First).Next = 0 then
1436             return False;
1437          end if;
1438
1439          if N (L.Last).Prev = 0 then
1440             return False;
1441          end if;
1442
1443          if N (N (L.First).Next).Prev /= L.First then
1444             return False;
1445          end if;
1446
1447          if N (N (L.Last).Prev).Next /= L.Last then
1448             return False;
1449          end if;
1450
1451          if L.Length = 2 then
1452             if N (L.First).Next /= L.Last then
1453                return False;
1454             end if;
1455
1456             if N (L.Last).Prev /= L.First then
1457                return False;
1458             end if;
1459
1460             return True;
1461          end if;
1462
1463          if N (L.First).Next = L.Last then
1464             return False;
1465          end if;
1466
1467          if N (L.Last).Prev = L.First then
1468             return False;
1469          end if;
1470
1471          if Position.Node = L.First then
1472             return True;
1473          end if;
1474
1475          if Position.Node = L.Last then
1476             return True;
1477          end if;
1478
1479          if N (Position.Node).Next = 0 then
1480             return False;
1481          end if;
1482
1483          if N (Position.Node).Prev = 0 then
1484             return False;
1485          end if;
1486
1487          if N (N (Position.Node).Next).Prev /= Position.Node then
1488             return False;
1489          end if;
1490
1491          if N (N (Position.Node).Prev).Next /= Position.Node then
1492             return False;
1493          end if;
1494
1495          if L.Length = 3 then
1496             if N (L.First).Next /= Position.Node then
1497                return False;
1498             end if;
1499
1500             if N (L.Last).Prev /= Position.Node then
1501                return False;
1502             end if;
1503          end if;
1504
1505          return True;
1506       end;
1507    end Vet;
1508
1509 end Ada.Containers.Restricted_Doubly_Linked_Lists;