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