gcc/ada/a-cdlili.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --   A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2011, 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 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with System; use type System.Address;
  33
  34 package body Ada.Containers.Doubly_Linked_Lists is
  35
  36    type Iterator is new Limited_Controlled and
  37      List_Iterator_Interfaces.Reversible_Iterator with
  38    record
  39       Container : List_Access;
  40       Node      : Node_Access;
  41    end record;
  42
  43    overriding procedure Finalize (Object : in out Iterator);
  44
  45    overriding function First (Object : Iterator) return Cursor;
  46    overriding function Last  (Object : Iterator) return Cursor;
  47
  48    overriding function Next
  49      (Object   : Iterator;
  50       Position : Cursor) return Cursor;
  51
  52    overriding function Previous
  53      (Object   : Iterator;
  54       Position : Cursor) return Cursor;
  55
  56    -----------------------
  57    -- Local Subprograms --
  58    -----------------------
  59
  60    procedure Free (X : in out Node_Access);
  61
  62    procedure Insert_Internal
  63      (Container : in out List;
  64       Before    : Node_Access;
  65       New_Node  : Node_Access);
  66
  67    function Vet (Position : Cursor) return Boolean;
  68
  69    ---------
  70    -- "=" --
  71    ---------
  72
  73    function "=" (Left, Right : List) return Boolean is
  74       L : Node_Access := Left.First;
  75       R : Node_Access := Right.First;
  76
  77    begin
  78       if Left'Address = Right'Address then
  79          return True;
  80       end if;
  81
  82       if Left.Length /= Right.Length then
  83          return False;
  84       end if;
  85
  86       for J in 1 .. Left.Length loop
  87          if L.Element /= R.Element then
  88             return False;
  89          end if;
  90
  91          L := L.Next;
  92          R := R.Next;
  93       end loop;
  94
  95       return True;
  96    end "=";
  97
  98    ------------
  99    -- Adjust --
 100    ------------
 101
 102    procedure Adjust (Container : in out List) is
 103       Src : Node_Access := Container.First;
 104
 105    begin
 106       if Src = null then
 107          pragma Assert (Container.Last = null);
 108          pragma Assert (Container.Length = 0);
 109          pragma Assert (Container.Busy = 0);
 110          pragma Assert (Container.Lock = 0);
 111          return;
 112       end if;
 113
 114       pragma Assert (Container.First.Prev = null);
 115       pragma Assert (Container.Last.Next = null);
 116       pragma Assert (Container.Length > 0);
 117
 118       Container.First := null;
 119       Container.Last := null;
 120       Container.Length := 0;
 121       Container.Busy := 0;
 122       Container.Lock := 0;
 123
 124       Container.First := new Node_Type'(Src.Element, null, null);
 125       Container.Last := Container.First;
 126       Container.Length := 1;
 127
 128       Src := Src.Next;
 129       while Src /= null loop
 130          Container.Last.Next := new Node_Type'(Element => Src.Element,
 131                                                Prev    => Container.Last,
 132                                                Next    => null);
 133          Container.Last := Container.Last.Next;
 134          Container.Length := Container.Length + 1;
 135
 136          Src := Src.Next;
 137       end loop;
 138    end Adjust;
 139
 140    ------------
 141    -- Append --
 142    ------------
 143
 144    procedure Append
 145      (Container : in out List;
 146       New_Item  : Element_Type;
 147       Count     : Count_Type := 1)
 148    is
 149    begin
 150       Insert (Container, No_Element, New_Item, Count);
 151    end Append;
 152
 153    ------------
 154    -- Assign --
 155    ------------
 156
 157    procedure Assign (Target : in out List; Source : List) is
 158       Node : Node_Access;
 159
 160    begin
 161       if Target'Address = Source'Address then
 162          return;
 163       end if;
 164
 165       Target.Clear;
 166
 167       Node := Source.First;
 168       while Node /= null loop
 169          Target.Append (Node.Element);
 170          Node := Node.Next;
 171       end loop;
 172    end Assign;
 173
 174    -----------
 175    -- Clear --
 176    -----------
 177
 178    procedure Clear (Container : in out List) is
 179       X : Node_Access;
 180
 181    begin
 182       if Container.Length = 0 then
 183          pragma Assert (Container.First = null);
 184          pragma Assert (Container.Last = null);
 185          pragma Assert (Container.Busy = 0);
 186          pragma Assert (Container.Lock = 0);
 187          return;
 188       end if;
 189
 190       pragma Assert (Container.First.Prev = null);
 191       pragma Assert (Container.Last.Next = null);
 192
 193       if Container.Busy > 0 then
 194          raise Program_Error with
 195            "attempt to tamper with cursors (list is busy)";
 196       end if;
 197
 198       while Container.Length > 1 loop
 199          X := Container.First;
 200          pragma Assert (X.Next.Prev = Container.First);
 201
 202          Container.First := X.Next;
 203          Container.First.Prev := null;
 204
 205          Container.Length := Container.Length - 1;
 206
 207          Free (X);
 208       end loop;
 209
 210       X := Container.First;
 211       pragma Assert (X = Container.Last);
 212
 213       Container.First := null;
 214       Container.Last := null;
 215       Container.Length := 0;
 216
 217       pragma Warnings (Off);
 218       Free (X);
 219       pragma Warnings (On);
 220    end Clear;
 221
 222    ------------------------
 223    -- Constant_Reference --
 224    ------------------------
 225
 226    function Constant_Reference
 227      (Container : aliased List;
 228       Position  : Cursor) return Constant_Reference_Type
 229    is
 230    begin
 231       if Position.Container = null then
 232          raise Constraint_Error with "Position cursor has no element";
 233       end if;
 234
 235       if Position.Container /= Container'Unrestricted_Access then
 236          raise Program_Error with
 237            "Position cursor designates wrong container";
 238       end if;
 239
 240       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 241
 242       return (Element => Position.Node.Element'Access);
 243    end Constant_Reference;
 244
 245    --------------
 246    -- Contains --
 247    --------------
 248
 249    function Contains
 250      (Container : List;
 251       Item      : Element_Type) return Boolean
 252    is
 253    begin
 254       return Find (Container, Item) /= No_Element;
 255    end Contains;
 256
 257    ----------
 258    -- Copy --
 259    ----------
 260
 261    function Copy (Source : List) return List is
 262    begin
 263       return Target : List do
 264          Target.Assign (Source);
 265       end return;
 266    end Copy;
 267
 268    ------------
 269    -- Delete --
 270    ------------
 271
 272    procedure Delete
 273      (Container : in out List;
 274       Position  : in out Cursor;
 275       Count     : Count_Type := 1)
 276    is
 277       X : Node_Access;
 278
 279    begin
 280       if Position.Node = null then
 281          raise Constraint_Error with
 282            "Position cursor has no element";
 283       end if;
 284
 285       if Position.Container /= Container'Unrestricted_Access then
 286          raise Program_Error with
 287            "Position cursor designates wrong container";
 288       end if;
 289
 290       pragma Assert (Vet (Position), "bad cursor in Delete");
 291
 292       if Position.Node = Container.First then
 293          Delete_First (Container, Count);
 294          Position := No_Element; --  Post-York behavior
 295          return;
 296       end if;
 297
 298       if Count = 0 then
 299          Position := No_Element;  --  Post-York behavior
 300          return;
 301       end if;
 302
 303       if Container.Busy > 0 then
 304          raise Program_Error with
 305            "attempt to tamper with cursors (list is busy)";
 306       end if;
 307
 308       for Index in 1 .. Count loop
 309          X := Position.Node;
 310          Container.Length := Container.Length - 1;
 311
 312          if X = Container.Last then
 313             Position := No_Element;
 314
 315             Container.Last := X.Prev;
 316             Container.Last.Next := null;
 317
 318             Free (X);
 319             return;
 320          end if;
 321
 322          Position.Node := X.Next;
 323
 324          X.Next.Prev := X.Prev;
 325          X.Prev.Next := X.Next;
 326
 327          Free (X);
 328       end loop;
 329
 330       Position := No_Element;  --  Post-York behavior
 331    end Delete;
 332
 333    ------------------
 334    -- Delete_First --
 335    ------------------
 336
 337    procedure Delete_First
 338      (Container : in out List;
 339       Count     : Count_Type := 1)
 340    is
 341       X : Node_Access;
 342
 343    begin
 344       if Count >= Container.Length then
 345          Clear (Container);
 346          return;
 347       end if;
 348
 349       if Count = 0 then
 350          return;
 351       end if;
 352
 353       if Container.Busy > 0 then
 354          raise Program_Error with
 355            "attempt to tamper with cursors (list is busy)";
 356       end if;
 357
 358       for I in 1 .. Count loop
 359          X := Container.First;
 360          pragma Assert (X.Next.Prev = Container.First);
 361
 362          Container.First := X.Next;
 363          Container.First.Prev := null;
 364
 365          Container.Length := Container.Length - 1;
 366
 367          Free (X);
 368       end loop;
 369    end Delete_First;
 370
 371    -----------------
 372    -- Delete_Last --
 373    -----------------
 374
 375    procedure Delete_Last
 376      (Container : in out List;
 377       Count     : Count_Type := 1)
 378    is
 379       X : Node_Access;
 380
 381    begin
 382       if Count >= Container.Length then
 383          Clear (Container);
 384          return;
 385       end if;
 386
 387       if Count = 0 then
 388          return;
 389       end if;
 390
 391       if Container.Busy > 0 then
 392          raise Program_Error with
 393            "attempt to tamper with cursors (list is busy)";
 394       end if;
 395
 396       for I in 1 .. Count loop
 397          X := Container.Last;
 398          pragma Assert (X.Prev.Next = Container.Last);
 399
 400          Container.Last := X.Prev;
 401          Container.Last.Next := null;
 402
 403          Container.Length := Container.Length - 1;
 404
 405          Free (X);
 406       end loop;
 407    end Delete_Last;
 408
 409    -------------
 410    -- Element --
 411    -------------
 412
 413    function Element (Position : Cursor) return Element_Type is
 414    begin
 415       if Position.Node = null then
 416          raise Constraint_Error with
 417            "Position cursor has no element";
 418       end if;
 419
 420       pragma Assert (Vet (Position), "bad cursor in Element");
 421
 422       return Position.Node.Element;
 423    end Element;
 424
 425    --------------
 426    -- Finalize --
 427    --------------
 428
 429    procedure Finalize (Object : in out Iterator) is
 430    begin
 431       if Object.Container /= null then
 432          declare
 433             B : Natural renames Object.Container.all.Busy;
 434          begin
 435             B := B - 1;
 436          end;
 437       end if;
 438    end Finalize;
 439
 440    ----------
 441    -- Find --
 442    ----------
 443
 444    function Find
 445      (Container : List;
 446       Item      : Element_Type;
 447       Position  : Cursor := No_Element) return Cursor
 448    is
 449       Node : Node_Access := Position.Node;
 450
 451    begin
 452       if Node = null then
 453          Node := Container.First;
 454
 455       else
 456          if Position.Container /= Container'Unrestricted_Access then
 457             raise Program_Error with
 458               "Position cursor designates wrong container";
 459          end if;
 460
 461          pragma Assert (Vet (Position), "bad cursor in Find");
 462       end if;
 463
 464       while Node /= null loop
 465          if Node.Element = Item then
 466             return Cursor'(Container'Unrestricted_Access, Node);
 467          end if;
 468
 469          Node := Node.Next;
 470       end loop;
 471
 472       return No_Element;
 473    end Find;
 474
 475    -----------
 476    -- First --
 477    -----------
 478
 479    function First (Container : List) return Cursor is
 480    begin
 481       if Container.First = null then
 482          return No_Element;
 483       end if;
 484
 485       return Cursor'(Container'Unrestricted_Access, Container.First);
 486    end First;
 487
 488    function First (Object : Iterator) return Cursor is
 489    begin
 490       --  The value of the iterator object's Node component influences the
 491       --  behavior of the First (and Last) selector function.
 492
 493       --  When the Node component is null, this means the iterator object was
 494       --  constructed without a start expression, in which case the (forward)
 495       --  iteration starts from the (logical) beginning of the entire sequence
 496       --  of items (corresponding to Container.First, for a forward iterator).
 497
 498       --  Otherwise, this is iteration over a partial sequence of items. When
 499       --  the Node component is non-null, the iterator object was constructed
 500       --  with a start expression, that specifies the position from which the
 501       --  (forward) partial iteration begins.
 502
 503       if Object.Node = null then
 504          return Doubly_Linked_Lists.First (Object.Container.all);
 505       else
 506          return Cursor'(Object.Container, Object.Node);
 507       end if;
 508    end First;
 509
 510    -------------------
 511    -- First_Element --
 512    -------------------
 513
 514    function First_Element (Container : List) return Element_Type is
 515    begin
 516       if Container.First = null then
 517          raise Constraint_Error with "list is empty";
 518       end if;
 519
 520       return Container.First.Element;
 521    end First_Element;
 522
 523    ----------
 524    -- Free --
 525    ----------
 526
 527    procedure Free (X : in out Node_Access) is
 528       procedure Deallocate is
 529          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 530    begin
 531       X.Prev := X;
 532       X.Next := X;
 533       Deallocate (X);
 534    end Free;
 535
 536    ---------------------
 537    -- Generic_Sorting --
 538    ---------------------
 539
 540    package body Generic_Sorting is
 541
 542       ---------------
 543       -- Is_Sorted --
 544       ---------------
 545
 546       function Is_Sorted (Container : List) return Boolean is
 547          Node : Node_Access := Container.First;
 548
 549       begin
 550          for I in 2 .. Container.Length loop
 551             if Node.Next.Element < Node.Element then
 552                return False;
 553             end if;
 554
 555             Node := Node.Next;
 556          end loop;
 557
 558          return True;
 559       end Is_Sorted;
 560
 561       -----------
 562       -- Merge --
 563       -----------
 564
 565       procedure Merge
 566         (Target : in out List;
 567          Source : in out List)
 568       is
 569          LI, RI : Cursor;
 570
 571       begin
 572
 573          --  The semantics of Merge changed slightly per AI05-0021. It was
 574          --  originally the case that if Target and Source denoted the same
 575          --  container object, then the GNAT implementation of Merge did
 576          --  nothing. However, it was argued that RM05 did not precisely
 577          --  specify the semantics for this corner case. The decision of the
 578          --  ARG was that if Target and Source denote the same non-empty
 579          --  container object, then Program_Error is raised.
 580
 581          if Source.Is_Empty then
 582             return;
 583          end if;
 584
 585          if Target'Address = Source'Address then
 586             raise Program_Error with
 587               "Target and Source denote same non-empty container";
 588          end if;
 589
 590          if Target.Busy > 0 then
 591             raise Program_Error with
 592               "attempt to tamper with cursors of Target (list is busy)";
 593          end if;
 594
 595          if Source.Busy > 0 then
 596             raise Program_Error with
 597               "attempt to tamper with cursors of Source (list is busy)";
 598          end if;
 599
 600          LI := First (Target);
 601          RI := First (Source);
 602          while RI.Node /= null loop
 603             pragma Assert (RI.Node.Next = null
 604                              or else not (RI.Node.Next.Element <
 605                                           RI.Node.Element));
 606
 607             if LI.Node = null then
 608                Splice (Target, No_Element, Source);
 609                return;
 610             end if;
 611
 612             pragma Assert (LI.Node.Next = null
 613                              or else not (LI.Node.Next.Element <
 614                                           LI.Node.Element));
 615
 616             if RI.Node.Element < LI.Node.Element then
 617                declare
 618                   RJ : Cursor := RI;
 619                   pragma Warnings (Off, RJ);
 620                begin
 621                   RI.Node := RI.Node.Next;
 622                   Splice (Target, LI, Source, RJ);
 623                end;
 624
 625             else
 626                LI.Node := LI.Node.Next;
 627             end if;
 628          end loop;
 629       end Merge;
 630
 631       ----------
 632       -- Sort --
 633       ----------
 634
 635       procedure Sort (Container : in out List) is
 636
 637          procedure Partition (Pivot : Node_Access; Back : Node_Access);
 638
 639          procedure Sort (Front, Back : Node_Access);
 640
 641          ---------------
 642          -- Partition --
 643          ---------------
 644
 645          procedure Partition (Pivot : Node_Access; Back : Node_Access) is
 646             Node : Node_Access := Pivot.Next;
 647
 648          begin
 649             while Node /= Back loop
 650                if Node.Element < Pivot.Element then
 651                   declare
 652                      Prev : constant Node_Access := Node.Prev;
 653                      Next : constant Node_Access := Node.Next;
 654
 655                   begin
 656                      Prev.Next := Next;
 657
 658                      if Next = null then
 659                         Container.Last := Prev;
 660                      else
 661                         Next.Prev := Prev;
 662                      end if;
 663
 664                      Node.Next := Pivot;
 665                      Node.Prev := Pivot.Prev;
 666
 667                      Pivot.Prev := Node;
 668
 669                      if Node.Prev = null then
 670                         Container.First := Node;
 671                      else
 672                         Node.Prev.Next := Node;
 673                      end if;
 674
 675                      Node := Next;
 676                   end;
 677
 678                else
 679                   Node := Node.Next;
 680                end if;
 681             end loop;
 682          end Partition;
 683
 684          ----------
 685          -- Sort --
 686          ----------
 687
 688          procedure Sort (Front, Back : Node_Access) is
 689             Pivot : constant Node_Access :=
 690                       (if Front = null then Container.First else Front.Next);
 691          begin
 692             if Pivot /= Back then
 693                Partition (Pivot, Back);
 694                Sort (Front, Pivot);
 695                Sort (Pivot, Back);
 696             end if;
 697          end Sort;
 698
 699       --  Start of processing for Sort
 700
 701       begin
 702          if Container.Length <= 1 then
 703             return;
 704          end if;
 705
 706          pragma Assert (Container.First.Prev = null);
 707          pragma Assert (Container.Last.Next = null);
 708
 709          if Container.Busy > 0 then
 710             raise Program_Error with
 711               "attempt to tamper with cursors (list is busy)";
 712          end if;
 713
 714          Sort (Front => null, Back => null);
 715
 716          pragma Assert (Container.First.Prev = null);
 717          pragma Assert (Container.Last.Next = null);
 718       end Sort;
 719
 720    end Generic_Sorting;
 721
 722    -----------------
 723    -- Has_Element --
 724    -----------------
 725
 726    function Has_Element (Position : Cursor) return Boolean is
 727    begin
 728       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 729       return Position.Node /= null;
 730    end Has_Element;
 731
 732    ------------
 733    -- Insert --
 734    ------------
 735
 736    procedure Insert
 737      (Container : in out List;
 738       Before    : Cursor;
 739       New_Item  : Element_Type;
 740       Position  : out Cursor;
 741       Count     : Count_Type := 1)
 742    is
 743       New_Node : Node_Access;
 744
 745    begin
 746       if Before.Container /= null then
 747          if Before.Container /= Container'Unrestricted_Access then
 748             raise Program_Error with
 749               "Before cursor designates wrong list";
 750          end if;
 751
 752          pragma Assert (Vet (Before), "bad cursor in Insert");
 753       end if;
 754
 755       if Count = 0 then
 756          Position := Before;
 757          return;
 758       end if;
 759
 760       if Container.Length > Count_Type'Last - Count then
 761          raise Constraint_Error with "new length exceeds maximum";
 762       end if;
 763
 764       if Container.Busy > 0 then
 765          raise Program_Error with
 766            "attempt to tamper with cursors (list is busy)";
 767       end if;
 768
 769       New_Node := new Node_Type'(New_Item, null, null);
 770       Insert_Internal (Container, Before.Node, New_Node);
 771
 772       Position := Cursor'(Container'Unchecked_Access, New_Node);
 773
 774       for J in Count_Type'(2) .. Count loop
 775          New_Node := new Node_Type'(New_Item, null, null);
 776          Insert_Internal (Container, Before.Node, New_Node);
 777       end loop;
 778    end Insert;
 779
 780    procedure Insert
 781      (Container : in out List;
 782       Before    : Cursor;
 783       New_Item  : Element_Type;
 784       Count     : Count_Type := 1)
 785    is
 786       Position : Cursor;
 787       pragma Unreferenced (Position);
 788    begin
 789       Insert (Container, Before, New_Item, Position, Count);
 790    end Insert;
 791
 792    procedure Insert
 793      (Container : in out List;
 794       Before    : Cursor;
 795       Position  : out Cursor;
 796       Count     : Count_Type := 1)
 797    is
 798       New_Node : Node_Access;
 799
 800    begin
 801       if Before.Container /= null then
 802          if Before.Container /= Container'Unrestricted_Access then
 803             raise Program_Error with
 804               "Before cursor designates wrong list";
 805          end if;
 806
 807          pragma Assert (Vet (Before), "bad cursor in Insert");
 808       end if;
 809
 810       if Count = 0 then
 811          Position := Before;
 812          return;
 813       end if;
 814
 815       if Container.Length > Count_Type'Last - Count then
 816          raise Constraint_Error with "new length exceeds maximum";
 817       end if;
 818
 819       if Container.Busy > 0 then
 820          raise Program_Error with
 821            "attempt to tamper with cursors (list is busy)";
 822       end if;
 823
 824       New_Node := new Node_Type;
 825       Insert_Internal (Container, Before.Node, New_Node);
 826
 827       Position := Cursor'(Container'Unchecked_Access, New_Node);
 828
 829       for J in Count_Type'(2) .. Count loop
 830          New_Node := new Node_Type;
 831          Insert_Internal (Container, Before.Node, New_Node);
 832       end loop;
 833    end Insert;
 834
 835    ---------------------
 836    -- Insert_Internal --
 837    ---------------------
 838
 839    procedure Insert_Internal
 840      (Container : in out List;
 841       Before    : Node_Access;
 842       New_Node  : Node_Access)
 843    is
 844    begin
 845       if Container.Length = 0 then
 846          pragma Assert (Before = null);
 847          pragma Assert (Container.First = null);
 848          pragma Assert (Container.Last = null);
 849
 850          Container.First := New_Node;
 851          Container.Last := New_Node;
 852
 853       elsif Before = null then
 854          pragma Assert (Container.Last.Next = null);
 855
 856          Container.Last.Next := New_Node;
 857          New_Node.Prev := Container.Last;
 858
 859          Container.Last := New_Node;
 860
 861       elsif Before = Container.First then
 862          pragma Assert (Container.First.Prev = null);
 863
 864          Container.First.Prev := New_Node;
 865          New_Node.Next := Container.First;
 866
 867          Container.First := New_Node;
 868
 869       else
 870          pragma Assert (Container.First.Prev = null);
 871          pragma Assert (Container.Last.Next = null);
 872
 873          New_Node.Next := Before;
 874          New_Node.Prev := Before.Prev;
 875
 876          Before.Prev.Next := New_Node;
 877          Before.Prev := New_Node;
 878       end if;
 879
 880       Container.Length := Container.Length + 1;
 881    end Insert_Internal;
 882
 883    --------------
 884    -- Is_Empty --
 885    --------------
 886
 887    function Is_Empty (Container : List) return Boolean is
 888    begin
 889       return Container.Length = 0;
 890    end Is_Empty;
 891
 892    -------------
 893    -- Iterate --
 894    -------------
 895
 896    procedure Iterate
 897      (Container : List;
 898       Process   : not null access procedure (Position : Cursor))
 899    is
 900       B    : Natural renames Container'Unrestricted_Access.all.Busy;
 901       Node : Node_Access := Container.First;
 902
 903    begin
 904       B := B + 1;
 905
 906       begin
 907          while Node /= null loop
 908             Process (Cursor'(Container'Unrestricted_Access, Node));
 909             Node := Node.Next;
 910          end loop;
 911       exception
 912          when others =>
 913             B := B - 1;
 914             raise;
 915       end;
 916
 917       B := B - 1;
 918    end Iterate;
 919
 920    function Iterate (Container : List)
 921      return List_Iterator_Interfaces.Reversible_Iterator'Class
 922    is
 923       B : Natural renames Container'Unrestricted_Access.all.Busy;
 924
 925    begin
 926       --  The value of the Node component influences the behavior of the First
 927       --  and Last selector functions of the iterator object. When the Node
 928       --  component is null (as is the case here), this means the iterator
 929       --  object was constructed without a start expression. This is a
 930       --  complete iterator, meaning that the iteration starts from the
 931       --  (logical) beginning of the sequence of items.
 932
 933       --  Note: For a forward iterator, Container.First is the beginning, and
 934       --  for a reverse iterator, Container.Last is the beginning.
 935
 936       return It : constant Iterator :=
 937                     Iterator'(Limited_Controlled with
 938                                 Container => Container'Unrestricted_Access,
 939                                 Node      => null)
 940       do
 941          B := B + 1;
 942       end return;
 943    end Iterate;
 944
 945    function Iterate (Container : List; Start : Cursor)
 946      return List_Iterator_Interfaces.Reversible_Iterator'Class
 947    is
 948       B  : Natural renames Container'Unrestricted_Access.all.Busy;
 949
 950    begin
 951       --  It was formerly the case that when Start = No_Element, the partial
 952       --  iterator was defined to behave the same as for a complete iterator,
 953       --  and iterate over the entire sequence of items. However, those
 954       --  semantics were unintuitive and arguably error-prone (it is too easy
 955       --  to accidentally create an endless loop), and so they were changed,
 956       --  per the ARG meeting in Denver on 2011/11. However, there was no
 957       --  consensus about what positive meaning this corner case should have,
 958       --  and so it was decided to simply raise an exception. This does imply,
 959       --  however, that it is not possible to use a partial iterator to specify
 960       --  an empty sequence of items.
 961
 962       if Start = No_Element then
 963          raise Constraint_Error with
 964            "Start position for iterator equals No_Element";
 965       end if;
 966
 967       if Start.Container /= Container'Unrestricted_Access then
 968          raise Program_Error with
 969            "Start cursor of Iterate designates wrong list";
 970       end if;
 971
 972       pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
 973
 974       --  The value of the Node component influences the behavior of the First
 975       --  and Last selector functions of the iterator object. When the Node
 976       --  component is non-null (as is the case here), it means that this
 977       --  is a partial iteration, over a subset of the complete sequence of
 978       --  items. The iterator object was constructed with a start expression,
 979       --  indicating the position from which the iteration begins. Note that
 980       --  the start position has the same value irrespective of whether this
 981       --  is a forward or reverse iteration.
 982
 983       return It : constant Iterator :=
 984                     Iterator'(Limited_Controlled with
 985                                 Container => Container'Unrestricted_Access,
 986                                 Node      => Start.Node)
 987       do
 988          B := B + 1;
 989       end return;
 990    end Iterate;
 991
 992    ----------
 993    -- Last --
 994    ----------
 995
 996    function Last (Container : List) return Cursor is
 997    begin
 998       if Container.Last = null then
 999          return No_Element;
1000       end if;
1001
1002       return Cursor'(Container'Unrestricted_Access, Container.Last);
1003    end Last;
1004
1005    function Last (Object : Iterator) return Cursor is
1006    begin
1007       --  The value of the iterator object's Node component influences the
1008       --  behavior of the Last (and First) selector function.
1009
1010       --  When the Node component is null, this means the iterator object was
1011       --  constructed without a start expression, in which case the (reverse)
1012       --  iteration starts from the (logical) beginning of the entire sequence
1013       --  (corresponding to Container.Last, for a reverse iterator).
1014
1015       --  Otherwise, this is iteration over a partial sequence of items. When
1016       --  the Node component is non-null, the iterator object was constructed
1017       --  with a start expression, that specifies the position from which the
1018       --  (reverse) partial iteration begins.
1019
1020       if Object.Node = null then
1021          return Doubly_Linked_Lists.Last (Object.Container.all);
1022       else
1023          return Cursor'(Object.Container, Object.Node);
1024       end if;
1025    end Last;
1026
1027    ------------------
1028    -- Last_Element --
1029    ------------------
1030
1031    function Last_Element (Container : List) return Element_Type is
1032    begin
1033       if Container.Last = null then
1034          raise Constraint_Error with "list is empty";
1035       end if;
1036
1037       return Container.Last.Element;
1038    end Last_Element;
1039
1040    ------------
1041    -- Length --
1042    ------------
1043
1044    function Length (Container : List) return Count_Type is
1045    begin
1046       return Container.Length;
1047    end Length;
1048
1049    ----------
1050    -- Move --
1051    ----------
1052
1053    procedure Move
1054      (Target : in out List;
1055       Source : in out List)
1056    is
1057    begin
1058       if Target'Address = Source'Address then
1059          return;
1060       end if;
1061
1062       if Source.Busy > 0 then
1063          raise Program_Error with
1064            "attempt to tamper with cursors of Source (list is busy)";
1065       end if;
1066
1067       Clear (Target);
1068
1069       Target.First := Source.First;
1070       Source.First := null;
1071
1072       Target.Last := Source.Last;
1073       Source.Last := null;
1074
1075       Target.Length := Source.Length;
1076       Source.Length := 0;
1077    end Move;
1078
1079    ----------
1080    -- Next --
1081    ----------
1082
1083    procedure Next (Position : in out Cursor) is
1084    begin
1085       Position := Next (Position);
1086    end Next;
1087
1088    function Next (Position : Cursor) return Cursor is
1089    begin
1090       if Position.Node = null then
1091          return No_Element;
1092       end if;
1093
1094       pragma Assert (Vet (Position), "bad cursor in Next");
1095
1096       declare
1097          Next_Node : constant Node_Access := Position.Node.Next;
1098
1099       begin
1100          if Next_Node = null then
1101             return No_Element;
1102          end if;
1103
1104          return Cursor'(Position.Container, Next_Node);
1105       end;
1106    end Next;
1107
1108    function Next
1109      (Object   : Iterator;
1110       Position : Cursor) return Cursor
1111    is
1112    begin
1113       if Position.Container = null then
1114          return No_Element;
1115       end if;
1116
1117       if Position.Container /= Object.Container then
1118          raise Program_Error with
1119            "Position cursor of Next designates wrong list";
1120       end if;
1121
1122       return Next (Position);
1123    end Next;
1124
1125    -------------
1126    -- Prepend --
1127    -------------
1128
1129    procedure Prepend
1130      (Container : in out List;
1131       New_Item  : Element_Type;
1132       Count     : Count_Type := 1)
1133    is
1134    begin
1135       Insert (Container, First (Container), New_Item, Count);
1136    end Prepend;
1137
1138    --------------
1139    -- Previous --
1140    --------------
1141
1142    procedure Previous (Position : in out Cursor) is
1143    begin
1144       Position := Previous (Position);
1145    end Previous;
1146
1147    function Previous (Position : Cursor) return Cursor is
1148    begin
1149       if Position.Node = null then
1150          return No_Element;
1151       end if;
1152
1153       pragma Assert (Vet (Position), "bad cursor in Previous");
1154
1155       declare
1156          Prev_Node : constant Node_Access := Position.Node.Prev;
1157
1158       begin
1159          if Prev_Node = null then
1160             return No_Element;
1161          end if;
1162
1163          return Cursor'(Position.Container, Prev_Node);
1164       end;
1165    end Previous;
1166
1167    function Previous
1168      (Object   : Iterator;
1169       Position : Cursor) return Cursor
1170    is
1171    begin
1172       if Position.Container = null then
1173          return No_Element;
1174       end if;
1175
1176       if Position.Container /= Object.Container then
1177          raise Program_Error with
1178            "Position cursor of Previous designates wrong list";
1179       end if;
1180
1181       return Previous (Position);
1182    end Previous;
1183
1184    -------------------
1185    -- Query_Element --
1186    -------------------
1187
1188    procedure Query_Element
1189      (Position : Cursor;
1190       Process  : not null access procedure (Element : Element_Type))
1191    is
1192    begin
1193       if Position.Node = null then
1194          raise Constraint_Error with
1195            "Position cursor has no element";
1196       end if;
1197
1198       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1199
1200       declare
1201          C : List renames Position.Container.all'Unrestricted_Access.all;
1202          B : Natural renames C.Busy;
1203          L : Natural renames C.Lock;
1204
1205       begin
1206          B := B + 1;
1207          L := L + 1;
1208
1209          begin
1210             Process (Position.Node.Element);
1211          exception
1212             when others =>
1213                L := L - 1;
1214                B := B - 1;
1215                raise;
1216          end;
1217
1218          L := L - 1;
1219          B := B - 1;
1220       end;
1221    end Query_Element;
1222
1223    ----------
1224    -- Read --
1225    ----------
1226
1227    procedure Read
1228      (Stream : not null access Root_Stream_Type'Class;
1229       Item   : out List)
1230    is
1231       N : Count_Type'Base;
1232       X : Node_Access;
1233
1234    begin
1235       Clear (Item);
1236       Count_Type'Base'Read (Stream, N);
1237
1238       if N = 0 then
1239          return;
1240       end if;
1241
1242       X := new Node_Type;
1243
1244       begin
1245          Element_Type'Read (Stream, X.Element);
1246       exception
1247          when others =>
1248             Free (X);
1249             raise;
1250       end;
1251
1252       Item.First := X;
1253       Item.Last := X;
1254
1255       loop
1256          Item.Length := Item.Length + 1;
1257          exit when Item.Length = N;
1258
1259          X := new Node_Type;
1260
1261          begin
1262             Element_Type'Read (Stream, X.Element);
1263          exception
1264             when others =>
1265                Free (X);
1266                raise;
1267          end;
1268
1269          X.Prev := Item.Last;
1270          Item.Last.Next := X;
1271          Item.Last := X;
1272       end loop;
1273    end Read;
1274
1275    procedure Read
1276      (Stream : not null access Root_Stream_Type'Class;
1277       Item   : out Cursor)
1278    is
1279    begin
1280       raise Program_Error with "attempt to stream list cursor";
1281    end Read;
1282
1283    procedure Read
1284      (Stream : not null access Root_Stream_Type'Class;
1285       Item   : out Reference_Type)
1286    is
1287    begin
1288       raise Program_Error with "attempt to stream reference";
1289    end Read;
1290
1291    procedure Read
1292      (Stream : not null access Root_Stream_Type'Class;
1293       Item   : out Constant_Reference_Type)
1294    is
1295    begin
1296       raise Program_Error with "attempt to stream reference";
1297    end Read;
1298
1299    ---------------
1300    -- Reference --
1301    ---------------
1302
1303    function Reference
1304      (Container : aliased in out List;
1305       Position  : Cursor) return Reference_Type
1306    is
1307    begin
1308       if Position.Container = null then
1309          raise Constraint_Error with "Position cursor has no element";
1310       end if;
1311
1312       if Position.Container /= Container'Unchecked_Access then
1313          raise Program_Error with
1314            "Position cursor designates wrong container";
1315       end if;
1316
1317       pragma Assert (Vet (Position), "bad cursor in function Reference");
1318
1319       return (Element => Position.Node.Element'Access);
1320    end Reference;
1321
1322    ---------------------
1323    -- Replace_Element --
1324    ---------------------
1325
1326    procedure Replace_Element
1327      (Container : in out List;
1328       Position  : Cursor;
1329       New_Item  : Element_Type)
1330    is
1331    begin
1332       if Position.Container = null then
1333          raise Constraint_Error with "Position cursor has no element";
1334       end if;
1335
1336       if Position.Container /= Container'Unchecked_Access then
1337          raise Program_Error with
1338            "Position cursor designates wrong container";
1339       end if;
1340
1341       if Container.Lock > 0 then
1342          raise Program_Error with
1343            "attempt to tamper with elements (list is locked)";
1344       end if;
1345
1346       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1347
1348       Position.Node.Element := New_Item;
1349    end Replace_Element;
1350
1351    ----------------------
1352    -- Reverse_Elements --
1353    ----------------------
1354
1355    procedure Reverse_Elements (Container : in out List) is
1356       I : Node_Access := Container.First;
1357       J : Node_Access := Container.Last;
1358
1359       procedure Swap (L, R : Node_Access);
1360
1361       ----------
1362       -- Swap --
1363       ----------
1364
1365       procedure Swap (L, R : Node_Access) is
1366          LN : constant Node_Access := L.Next;
1367          LP : constant Node_Access := L.Prev;
1368
1369          RN : constant Node_Access := R.Next;
1370          RP : constant Node_Access := R.Prev;
1371
1372       begin
1373          if LP /= null then
1374             LP.Next := R;
1375          end if;
1376
1377          if RN /= null then
1378             RN.Prev := L;
1379          end if;
1380
1381          L.Next := RN;
1382          R.Prev := LP;
1383
1384          if LN = R then
1385             pragma Assert (RP = L);
1386
1387             L.Prev := R;
1388             R.Next := L;
1389
1390          else
1391             L.Prev := RP;
1392             RP.Next := L;
1393
1394             R.Next := LN;
1395             LN.Prev := R;
1396          end if;
1397       end Swap;
1398
1399    --  Start of processing for Reverse_Elements
1400
1401    begin
1402       if Container.Length <= 1 then
1403          return;
1404       end if;
1405
1406       pragma Assert (Container.First.Prev = null);
1407       pragma Assert (Container.Last.Next = null);
1408
1409       if Container.Busy > 0 then
1410          raise Program_Error with
1411            "attempt to tamper with cursors (list is busy)";
1412       end if;
1413
1414       Container.First := J;
1415       Container.Last := I;
1416       loop
1417          Swap (L => I, R => J);
1418
1419          J := J.Next;
1420          exit when I = J;
1421
1422          I := I.Prev;
1423          exit when I = J;
1424
1425          Swap (L => J, R => I);
1426
1427          I := I.Next;
1428          exit when I = J;
1429
1430          J := J.Prev;
1431          exit when I = J;
1432       end loop;
1433
1434       pragma Assert (Container.First.Prev = null);
1435       pragma Assert (Container.Last.Next = null);
1436    end Reverse_Elements;
1437
1438    ------------------
1439    -- Reverse_Find --
1440    ------------------
1441
1442    function Reverse_Find
1443      (Container : List;
1444       Item      : Element_Type;
1445       Position  : Cursor := No_Element) return Cursor
1446    is
1447       Node : Node_Access := Position.Node;
1448
1449    begin
1450       if Node = null then
1451          Node := Container.Last;
1452
1453       else
1454          if Position.Container /= Container'Unrestricted_Access then
1455             raise Program_Error with
1456               "Position cursor designates wrong container";
1457          end if;
1458
1459          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1460       end if;
1461
1462       while Node /= null loop
1463          if Node.Element = Item then
1464             return Cursor'(Container'Unrestricted_Access, Node);
1465          end if;
1466
1467          Node := Node.Prev;
1468       end loop;
1469
1470       return No_Element;
1471    end Reverse_Find;
1472
1473    ---------------------
1474    -- Reverse_Iterate --
1475    ---------------------
1476
1477    procedure Reverse_Iterate
1478      (Container : List;
1479       Process   : not null access procedure (Position : Cursor))
1480    is
1481       C : List renames Container'Unrestricted_Access.all;
1482       B : Natural renames C.Busy;
1483
1484       Node : Node_Access := Container.Last;
1485
1486    begin
1487       B := B + 1;
1488
1489       begin
1490          while Node /= null loop
1491             Process (Cursor'(Container'Unrestricted_Access, Node));
1492             Node := Node.Prev;
1493          end loop;
1494
1495       exception
1496          when others =>
1497             B := B - 1;
1498             raise;
1499       end;
1500
1501       B := B - 1;
1502    end Reverse_Iterate;
1503
1504    ------------
1505    -- Splice --
1506    ------------
1507
1508    procedure Splice
1509      (Target : in out List;
1510       Before : Cursor;
1511       Source : in out List)
1512    is
1513    begin
1514       if Before.Container /= null then
1515          if Before.Container /= Target'Unrestricted_Access then
1516             raise Program_Error with
1517               "Before cursor designates wrong container";
1518          end if;
1519
1520          pragma Assert (Vet (Before), "bad cursor in Splice");
1521       end if;
1522
1523       if Target'Address = Source'Address
1524         or else Source.Length = 0
1525       then
1526          return;
1527       end if;
1528
1529       pragma Assert (Source.First.Prev = null);
1530       pragma Assert (Source.Last.Next = null);
1531
1532       if Target.Length > Count_Type'Last - Source.Length then
1533          raise Constraint_Error with "new length exceeds maximum";
1534       end if;
1535
1536       if Target.Busy > 0 then
1537          raise Program_Error with
1538            "attempt to tamper with cursors of Target (list is busy)";
1539       end if;
1540
1541       if Source.Busy > 0 then
1542          raise Program_Error with
1543            "attempt to tamper with cursors of Source (list is busy)";
1544       end if;
1545
1546       if Target.Length = 0 then
1547          pragma Assert (Target.First = null);
1548          pragma Assert (Target.Last = null);
1549          pragma Assert (Before = No_Element);
1550
1551          Target.First := Source.First;
1552          Target.Last := Source.Last;
1553
1554       elsif Before.Node = null then
1555          pragma Assert (Target.Last.Next = null);
1556
1557          Target.Last.Next := Source.First;
1558          Source.First.Prev := Target.Last;
1559
1560          Target.Last := Source.Last;
1561
1562       elsif Before.Node = Target.First then
1563          pragma Assert (Target.First.Prev = null);
1564
1565          Source.Last.Next := Target.First;
1566          Target.First.Prev := Source.Last;
1567
1568          Target.First := Source.First;
1569
1570       else
1571          pragma Assert (Target.Length >= 2);
1572
1573          Before.Node.Prev.Next := Source.First;
1574          Source.First.Prev := Before.Node.Prev;
1575
1576          Before.Node.Prev := Source.Last;
1577          Source.Last.Next := Before.Node;
1578       end if;
1579
1580       Source.First := null;
1581       Source.Last := null;
1582
1583       Target.Length := Target.Length + Source.Length;
1584       Source.Length := 0;
1585    end Splice;
1586
1587    procedure Splice
1588      (Container : in out List;
1589       Before    : Cursor;
1590       Position  : Cursor)
1591    is
1592    begin
1593       if Before.Container /= null then
1594          if Before.Container /= Container'Unchecked_Access then
1595             raise Program_Error with
1596               "Before cursor designates wrong container";
1597          end if;
1598
1599          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1600       end if;
1601
1602       if Position.Node = null then
1603          raise Constraint_Error with "Position cursor has no element";
1604       end if;
1605
1606       if Position.Container /= Container'Unrestricted_Access then
1607          raise Program_Error with
1608            "Position cursor designates wrong container";
1609       end if;
1610
1611       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1612
1613       if Position.Node = Before.Node
1614         or else Position.Node.Next = Before.Node
1615       then
1616          return;
1617       end if;
1618
1619       pragma Assert (Container.Length >= 2);
1620
1621       if Container.Busy > 0 then
1622          raise Program_Error with
1623            "attempt to tamper with cursors (list is busy)";
1624       end if;
1625
1626       if Before.Node = null then
1627          pragma Assert (Position.Node /= Container.Last);
1628
1629          if Position.Node = Container.First then
1630             Container.First := Position.Node.Next;
1631             Container.First.Prev := null;
1632          else
1633             Position.Node.Prev.Next := Position.Node.Next;
1634             Position.Node.Next.Prev := Position.Node.Prev;
1635          end if;
1636
1637          Container.Last.Next := Position.Node;
1638          Position.Node.Prev := Container.Last;
1639
1640          Container.Last := Position.Node;
1641          Container.Last.Next := null;
1642
1643          return;
1644       end if;
1645
1646       if Before.Node = Container.First then
1647          pragma Assert (Position.Node /= Container.First);
1648
1649          if Position.Node = Container.Last then
1650             Container.Last := Position.Node.Prev;
1651             Container.Last.Next := null;
1652          else
1653             Position.Node.Prev.Next := Position.Node.Next;
1654             Position.Node.Next.Prev := Position.Node.Prev;
1655          end if;
1656
1657          Container.First.Prev := Position.Node;
1658          Position.Node.Next := Container.First;
1659
1660          Container.First := Position.Node;
1661          Container.First.Prev := null;
1662
1663          return;
1664       end if;
1665
1666       if Position.Node = Container.First then
1667          Container.First := Position.Node.Next;
1668          Container.First.Prev := null;
1669
1670       elsif Position.Node = Container.Last then
1671          Container.Last := Position.Node.Prev;
1672          Container.Last.Next := null;
1673
1674       else
1675          Position.Node.Prev.Next := Position.Node.Next;
1676          Position.Node.Next.Prev := Position.Node.Prev;
1677       end if;
1678
1679       Before.Node.Prev.Next := Position.Node;
1680       Position.Node.Prev := Before.Node.Prev;
1681
1682       Before.Node.Prev := Position.Node;
1683       Position.Node.Next := Before.Node;
1684
1685       pragma Assert (Container.First.Prev = null);
1686       pragma Assert (Container.Last.Next = null);
1687    end Splice;
1688
1689    procedure Splice
1690      (Target   : in out List;
1691       Before   : Cursor;
1692       Source   : in out List;
1693       Position : in out Cursor)
1694    is
1695    begin
1696       if Target'Address = Source'Address then
1697          Splice (Target, Before, Position);
1698          return;
1699       end if;
1700
1701       if Before.Container /= null then
1702          if Before.Container /= Target'Unrestricted_Access then
1703             raise Program_Error with
1704               "Before cursor designates wrong container";
1705          end if;
1706
1707          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1708       end if;
1709
1710       if Position.Node = null then
1711          raise Constraint_Error with "Position cursor has no element";
1712       end if;
1713
1714       if Position.Container /= Source'Unrestricted_Access then
1715          raise Program_Error with
1716            "Position cursor designates wrong container";
1717       end if;
1718
1719       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1720
1721       if Target.Length = Count_Type'Last then
1722          raise Constraint_Error with "Target is full";
1723       end if;
1724
1725       if Target.Busy > 0 then
1726          raise Program_Error with
1727            "attempt to tamper with cursors of Target (list is busy)";
1728       end if;
1729
1730       if Source.Busy > 0 then
1731          raise Program_Error with
1732            "attempt to tamper with cursors of Source (list is busy)";
1733       end if;
1734
1735       if Position.Node = Source.First then
1736          Source.First := Position.Node.Next;
1737
1738          if Position.Node = Source.Last then
1739             pragma Assert (Source.First = null);
1740             pragma Assert (Source.Length = 1);
1741             Source.Last := null;
1742
1743          else
1744             Source.First.Prev := null;
1745          end if;
1746
1747       elsif Position.Node = Source.Last then
1748          pragma Assert (Source.Length >= 2);
1749          Source.Last := Position.Node.Prev;
1750          Source.Last.Next := null;
1751
1752       else
1753          pragma Assert (Source.Length >= 3);
1754          Position.Node.Prev.Next := Position.Node.Next;
1755          Position.Node.Next.Prev := Position.Node.Prev;
1756       end if;
1757
1758       if Target.Length = 0 then
1759          pragma Assert (Target.First = null);
1760          pragma Assert (Target.Last = null);
1761          pragma Assert (Before = No_Element);
1762
1763          Target.First := Position.Node;
1764          Target.Last := Position.Node;
1765
1766          Target.First.Prev := null;
1767          Target.Last.Next := null;
1768
1769       elsif Before.Node = null then
1770          pragma Assert (Target.Last.Next = null);
1771          Target.Last.Next := Position.Node;
1772          Position.Node.Prev := Target.Last;
1773
1774          Target.Last := Position.Node;
1775          Target.Last.Next := null;
1776
1777       elsif Before.Node = Target.First then
1778          pragma Assert (Target.First.Prev = null);
1779          Target.First.Prev := Position.Node;
1780          Position.Node.Next := Target.First;
1781
1782          Target.First := Position.Node;
1783          Target.First.Prev := null;
1784
1785       else
1786          pragma Assert (Target.Length >= 2);
1787          Before.Node.Prev.Next := Position.Node;
1788          Position.Node.Prev := Before.Node.Prev;
1789
1790          Before.Node.Prev := Position.Node;
1791          Position.Node.Next := Before.Node;
1792       end if;
1793
1794       Target.Length := Target.Length + 1;
1795       Source.Length := Source.Length - 1;
1796
1797       Position.Container := Target'Unchecked_Access;
1798    end Splice;
1799
1800    ----------
1801    -- Swap --
1802    ----------
1803
1804    procedure Swap
1805      (Container : in out List;
1806       I, J      : Cursor)
1807    is
1808    begin
1809       if I.Node = null then
1810          raise Constraint_Error with "I cursor has no element";
1811       end if;
1812
1813       if J.Node = null then
1814          raise Constraint_Error with "J cursor has no element";
1815       end if;
1816
1817       if I.Container /= Container'Unchecked_Access then
1818          raise Program_Error with "I cursor designates wrong container";
1819       end if;
1820
1821       if J.Container /= Container'Unchecked_Access then
1822          raise Program_Error with "J cursor designates wrong container";
1823       end if;
1824
1825       if I.Node = J.Node then
1826          return;
1827       end if;
1828
1829       if Container.Lock > 0 then
1830          raise Program_Error with
1831            "attempt to tamper with elements (list is locked)";
1832       end if;
1833
1834       pragma Assert (Vet (I), "bad I cursor in Swap");
1835       pragma Assert (Vet (J), "bad J cursor in Swap");
1836
1837       declare
1838          EI : Element_Type renames I.Node.Element;
1839          EJ : Element_Type renames J.Node.Element;
1840
1841          EI_Copy : constant Element_Type := EI;
1842
1843       begin
1844          EI := EJ;
1845          EJ := EI_Copy;
1846       end;
1847    end Swap;
1848
1849    ----------------
1850    -- Swap_Links --
1851    ----------------
1852
1853    procedure Swap_Links
1854      (Container : in out List;
1855       I, J      : Cursor)
1856    is
1857    begin
1858       if I.Node = null then
1859          raise Constraint_Error with "I cursor has no element";
1860       end if;
1861
1862       if J.Node = null then
1863          raise Constraint_Error with "J cursor has no element";
1864       end if;
1865
1866       if I.Container /= Container'Unrestricted_Access then
1867          raise Program_Error with "I cursor designates wrong container";
1868       end if;
1869
1870       if J.Container /= Container'Unrestricted_Access then
1871          raise Program_Error with "J cursor designates wrong container";
1872       end if;
1873
1874       if I.Node = J.Node then
1875          return;
1876       end if;
1877
1878       if Container.Busy > 0 then
1879          raise Program_Error with
1880            "attempt to tamper with cursors (list is busy)";
1881       end if;
1882
1883       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1884       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1885
1886       declare
1887          I_Next : constant Cursor := Next (I);
1888
1889       begin
1890          if I_Next = J then
1891             Splice (Container, Before => I, Position => J);
1892
1893          else
1894             declare
1895                J_Next : constant Cursor := Next (J);
1896
1897             begin
1898                if J_Next = I then
1899                   Splice (Container, Before => J, Position => I);
1900
1901                else
1902                   pragma Assert (Container.Length >= 3);
1903
1904                   Splice (Container, Before => I_Next, Position => J);
1905                   Splice (Container, Before => J_Next, Position => I);
1906                end if;
1907             end;
1908          end if;
1909       end;
1910    end Swap_Links;
1911
1912    --------------------
1913    -- Update_Element --
1914    --------------------
1915
1916    procedure Update_Element
1917      (Container : in out List;
1918       Position  : Cursor;
1919       Process   : not null access procedure (Element : in out Element_Type))
1920    is
1921    begin
1922       if Position.Node = null then
1923          raise Constraint_Error with "Position cursor has no element";
1924       end if;
1925
1926       if Position.Container /= Container'Unchecked_Access then
1927          raise Program_Error with
1928            "Position cursor designates wrong container";
1929       end if;
1930
1931       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1932
1933       declare
1934          B : Natural renames Container.Busy;
1935          L : Natural renames Container.Lock;
1936
1937       begin
1938          B := B + 1;
1939          L := L + 1;
1940
1941          begin
1942             Process (Position.Node.Element);
1943          exception
1944             when others =>
1945                L := L - 1;
1946                B := B - 1;
1947                raise;
1948          end;
1949
1950          L := L - 1;
1951          B := B - 1;
1952       end;
1953    end Update_Element;
1954
1955    ---------
1956    -- Vet --
1957    ---------
1958
1959    function Vet (Position : Cursor) return Boolean is
1960    begin
1961       if Position.Node = null then
1962          return Position.Container = null;
1963       end if;
1964
1965       if Position.Container = null then
1966          return False;
1967       end if;
1968
1969       if Position.Node.Next = Position.Node then
1970          return False;
1971       end if;
1972
1973       if Position.Node.Prev = Position.Node then
1974          return False;
1975       end if;
1976
1977       declare
1978          L : List renames Position.Container.all;
1979       begin
1980          if L.Length = 0 then
1981             return False;
1982          end if;
1983
1984          if L.First = null then
1985             return False;
1986          end if;
1987
1988          if L.Last = null then
1989             return False;
1990          end if;
1991
1992          if L.First.Prev /= null then
1993             return False;
1994          end if;
1995
1996          if L.Last.Next /= null then
1997             return False;
1998          end if;
1999
2000          if Position.Node.Prev = null
2001            and then Position.Node /= L.First
2002          then
2003             return False;
2004          end if;
2005
2006          --  If we get here, we know that this disjunction is true:
2007          --  Position.Node.Prev /= null or else Position.Node = L.First
2008
2009          if Position.Node.Next = null
2010            and then Position.Node /= L.Last
2011          then
2012             return False;
2013          end if;
2014
2015          --  If we get here, we know that this disjunction is true:
2016          --  Position.Node.Next /= null or else Position.Node = L.Last
2017
2018          if L.Length = 1 then
2019             return L.First = L.Last;
2020          end if;
2021
2022          if L.First = L.Last then
2023             return False;
2024          end if;
2025
2026          if L.First.Next = null then
2027             return False;
2028          end if;
2029
2030          if L.Last.Prev = null then
2031             return False;
2032          end if;
2033
2034          if L.First.Next.Prev /= L.First then
2035             return False;
2036          end if;
2037
2038          if L.Last.Prev.Next /= L.Last then
2039             return False;
2040          end if;
2041
2042          if L.Length = 2 then
2043             if L.First.Next /= L.Last then
2044                return False;
2045             end if;
2046
2047             if L.Last.Prev /= L.First then
2048                return False;
2049             end if;
2050
2051             return True;
2052          end if;
2053
2054          if L.First.Next = L.Last then
2055             return False;
2056          end if;
2057
2058          if L.Last.Prev = L.First then
2059             return False;
2060          end if;
2061
2062          --  Eliminate earlier disjunct
2063
2064          if Position.Node = L.First then
2065             return True;
2066          end if;
2067
2068          --  If we get here, we know (disjunctive syllogism) that this
2069          --  predicate is true: Position.Node.Prev /= null
2070
2071          --  Eliminate earlier disjunct
2072
2073          if Position.Node = L.Last then
2074             return True;
2075          end if;
2076
2077          --  If we get here, we know (disjunctive syllogism) that this
2078          --  predicate is true: Position.Node.Next /= null
2079
2080          if Position.Node.Next.Prev /= Position.Node then
2081             return False;
2082          end if;
2083
2084          if Position.Node.Prev.Next /= Position.Node then
2085             return False;
2086          end if;
2087
2088          if L.Length = 3 then
2089             if L.First.Next /= Position.Node then
2090                return False;
2091             end if;
2092
2093             if L.Last.Prev /= Position.Node then
2094                return False;
2095             end if;
2096          end if;
2097
2098          return True;
2099       end;
2100    end Vet;
2101
2102    -----------
2103    -- Write --
2104    -----------
2105
2106    procedure Write
2107      (Stream : not null access Root_Stream_Type'Class;
2108       Item   : List)
2109    is
2110       Node : Node_Access := Item.First;
2111
2112    begin
2113       Count_Type'Base'Write (Stream, Item.Length);
2114
2115       while Node /= null loop
2116          Element_Type'Write (Stream, Node.Element);
2117          Node := Node.Next;
2118       end loop;
2119    end Write;
2120
2121    procedure Write
2122      (Stream : not null access Root_Stream_Type'Class;
2123       Item   : Cursor)
2124    is
2125    begin
2126       raise Program_Error with "attempt to stream list cursor";
2127    end Write;
2128
2129    procedure Write
2130      (Stream : not null access Root_Stream_Type'Class;
2131       Item   : Reference_Type)
2132    is
2133    begin
2134       raise Program_Error with "attempt to stream reference";
2135    end Write;
2136
2137    procedure Write
2138      (Stream : not null access Root_Stream_Type'Class;
2139       Item   : Constant_Reference_Type)
2140    is
2141    begin
2142       raise Program_Error with "attempt to stream reference";
2143    end Write;
2144
2145 end Ada.Containers.Doubly_Linked_Lists;