gcc/ada/a-cidlli.adb

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