gcc/ada/a-cidlli.adb

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