gcc/ada/a-cidlli.adb

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