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