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          --  The element allocator may need an accessibility check in the case
 892          --  the actual type is class-wide or has access discriminants (see
 893          --  RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
 894          --  allocator in the loop below, because the one in this block would
 895          --  have failed already.
 896
 897          pragma Unsuppress (Accessibility_Check);
 898
 899          Element : Element_Access := new Element_Type'(New_Item);
 900
 901       begin
 902          New_Node := new Node_Type'(Element, null, null);
 903
 904       exception
 905          when others =>
 906             Free (Element);
 907             raise;
 908       end;
 909
 910       Insert_Internal (Container, Before.Node, New_Node);
 911       Position := Cursor'(Container'Unchecked_Access, New_Node);
 912
 913       for J in Count_Type'(2) .. Count loop
 914
 915          declare
 916             Element : Element_Access := new Element_Type'(New_Item);
 917          begin
 918             New_Node := new Node_Type'(Element, null, null);
 919          exception
 920             when others =>
 921                Free (Element);
 922                raise;
 923          end;
 924
 925          Insert_Internal (Container, Before.Node, New_Node);
 926       end loop;
 927    end Insert;
 928
 929    procedure Insert
 930      (Container : in out List;
 931       Before    : Cursor;
 932       New_Item  : Element_Type;
 933       Count     : Count_Type := 1)
 934    is
 935       Position : Cursor;
 936       pragma Unreferenced (Position);
 937    begin
 938       Insert (Container, Before, New_Item, Position, Count);
 939    end Insert;
 940
 941    ---------------------
 942    -- Insert_Internal --
 943    ---------------------
 944
 945    procedure Insert_Internal
 946      (Container : in out List;
 947       Before    : Node_Access;
 948       New_Node  : Node_Access)
 949    is
 950    begin
 951       if Container.Length = 0 then
 952          pragma Assert (Before = null);
 953          pragma Assert (Container.First = null);
 954          pragma Assert (Container.Last = null);
 955
 956          Container.First := New_Node;
 957          Container.Last := New_Node;
 958
 959       elsif Before = null then
 960          pragma Assert (Container.Last.Next = null);
 961
 962          Container.Last.Next := New_Node;
 963          New_Node.Prev := Container.Last;
 964
 965          Container.Last := New_Node;
 966
 967       elsif Before = Container.First then
 968          pragma Assert (Container.First.Prev = null);
 969
 970          Container.First.Prev := New_Node;
 971          New_Node.Next := Container.First;
 972
 973          Container.First := New_Node;
 974
 975       else
 976          pragma Assert (Container.First.Prev = null);
 977          pragma Assert (Container.Last.Next = null);
 978
 979          New_Node.Next := Before;
 980          New_Node.Prev := Before.Prev;
 981
 982          Before.Prev.Next := New_Node;
 983          Before.Prev := New_Node;
 984       end if;
 985
 986       Container.Length := Container.Length + 1;
 987    end Insert_Internal;
 988
 989    --------------
 990    -- Is_Empty --
 991    --------------
 992
 993    function Is_Empty (Container : List) return Boolean is
 994    begin
 995       return Container.Length = 0;
 996    end Is_Empty;
 997
 998    -------------
 999    -- Iterate --
1000    -------------
1001
1002    procedure Iterate
1003      (Container : List;
1004       Process   : not null access procedure (Position : Cursor))
1005    is
1006       B    : Natural renames Container'Unrestricted_Access.all.Busy;
1007       Node : Node_Access := Container.First;
1008
1009    begin
1010       B := B + 1;
1011
1012       begin
1013          while Node /= null loop
1014             Process (Cursor'(Container'Unrestricted_Access, Node));
1015             Node := Node.Next;
1016          end loop;
1017       exception
1018          when others =>
1019             B := B - 1;
1020             raise;
1021       end;
1022
1023       B := B - 1;
1024    end Iterate;
1025
1026    function Iterate
1027      (Container : List)
1028       return List_Iterator_Interfaces.Reversible_Iterator'class
1029    is
1030       B : Natural renames Container'Unrestricted_Access.all.Busy;
1031
1032    begin
1033       --  The value of the Node component influences the behavior of the First
1034       --  and Last selector functions of the iterator object. When the Node
1035       --  component is null (as is the case here), this means the iterator
1036       --  object was constructed without a start expression. This is a
1037       --  complete iterator, meaning that the iteration starts from the
1038       --  (logical) beginning of the sequence of items.
1039
1040       --  Note: For a forward iterator, Container.First is the beginning, and
1041       --  for a reverse iterator, Container.Last is the beginning.
1042
1043       return It : constant Iterator :=
1044                     Iterator'(Limited_Controlled with
1045                                 Container => Container'Unrestricted_Access,
1046                                 Node      => null)
1047       do
1048          B := B + 1;
1049       end return;
1050    end Iterate;
1051
1052    function Iterate
1053      (Container : List;
1054       Start     : Cursor)
1055       return List_Iterator_Interfaces.Reversible_Iterator'Class
1056    is
1057       B  : Natural renames Container'Unrestricted_Access.all.Busy;
1058
1059    begin
1060       --  It was formerly the case that when Start = No_Element, the partial
1061       --  iterator was defined to behave the same as for a complete iterator,
1062       --  and iterate over the entire sequence of items. However, those
1063       --  semantics were unintuitive and arguably error-prone (it is too easy
1064       --  to accidentally create an endless loop), and so they were changed,
1065       --  per the ARG meeting in Denver on 2011/11. However, there was no
1066       --  consensus about what positive meaning this corner case should have,
1067       --  and so it was decided to simply raise an exception. This does imply,
1068       --  however, that it is not possible to use a partial iterator to specify
1069       --  an empty sequence of items.
1070
1071       if Start = No_Element then
1072          raise Constraint_Error with
1073            "Start position for iterator equals No_Element";
1074       end if;
1075
1076       if Start.Container /= Container'Unrestricted_Access then
1077          raise Program_Error with
1078            "Start cursor of Iterate designates wrong list";
1079       end if;
1080
1081       pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1082
1083       --  The value of the Node component influences the behavior of the First
1084       --  and Last selector functions of the iterator object. When the Node
1085       --  component is non-null (as is the case here), it means that this
1086       --  is a partial iteration, over a subset of the complete sequence of
1087       --  items. The iterator object was constructed with a start expression,
1088       --  indicating the position from which the iteration begins. Note that
1089       --  the start position has the same value irrespective of whether this
1090       --  is a forward or reverse iteration.
1091
1092       return It : constant Iterator :=
1093                     Iterator'(Limited_Controlled with
1094                                 Container => Container'Unrestricted_Access,
1095                                 Node      => Start.Node)
1096       do
1097          B := B + 1;
1098       end return;
1099    end Iterate;
1100
1101    ----------
1102    -- Last --
1103    ----------
1104
1105    function Last (Container : List) return Cursor is
1106    begin
1107       if Container.Last = null then
1108          return No_Element;
1109       end if;
1110
1111       return Cursor'(Container'Unrestricted_Access, Container.Last);
1112    end Last;
1113
1114    function Last (Object : Iterator) return Cursor is
1115    begin
1116       --  The value of the iterator object's Node component influences the
1117       --  behavior of the Last (and First) selector function.
1118
1119       --  When the Node component is null, this means the iterator object was
1120       --  constructed without a start expression, in which case the (reverse)
1121       --  iteration starts from the (logical) beginning of the entire sequence
1122       --  (corresponding to Container.Last, for a reverse iterator).
1123
1124       --  Otherwise, this is iteration over a partial sequence of items. When
1125       --  the Node component is non-null, the iterator object was constructed
1126       --  with a start expression, that specifies the position from which the
1127       --  (reverse) partial iteration begins.
1128
1129       if Object.Node = null then
1130          return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all);
1131       else
1132          return Cursor'(Object.Container, Object.Node);
1133       end if;
1134    end Last;
1135
1136    ------------------
1137    -- Last_Element --
1138    ------------------
1139
1140    function Last_Element (Container : List) return Element_Type is
1141    begin
1142       if Container.Last = null then
1143          raise Constraint_Error with "list is empty";
1144       end if;
1145
1146       return Container.Last.Element.all;
1147    end Last_Element;
1148
1149    ------------
1150    -- Length --
1151    ------------
1152
1153    function Length (Container : List) return Count_Type is
1154    begin
1155       return Container.Length;
1156    end Length;
1157
1158    ----------
1159    -- Move --
1160    ----------
1161
1162    procedure Move (Target : in out List; Source : in out List) is
1163    begin
1164       if Target'Address = Source'Address then
1165          return;
1166       end if;
1167
1168       if Source.Busy > 0 then
1169          raise Program_Error with
1170            "attempt to tamper with cursors of Source (list is busy)";
1171       end if;
1172
1173       Clear (Target);
1174
1175       Target.First := Source.First;
1176       Source.First := null;
1177
1178       Target.Last := Source.Last;
1179       Source.Last := null;
1180
1181       Target.Length := Source.Length;
1182       Source.Length := 0;
1183    end Move;
1184
1185    ----------
1186    -- Next --
1187    ----------
1188
1189    procedure Next (Position : in out Cursor) is
1190    begin
1191       Position := Next (Position);
1192    end Next;
1193
1194    function Next (Position : Cursor) return Cursor is
1195    begin
1196       if Position.Node = null then
1197          return No_Element;
1198       end if;
1199
1200       pragma Assert (Vet (Position), "bad cursor in Next");
1201
1202       declare
1203          Next_Node : constant Node_Access := Position.Node.Next;
1204       begin
1205          if Next_Node = null then
1206             return No_Element;
1207          end if;
1208
1209          return Cursor'(Position.Container, Next_Node);
1210       end;
1211    end Next;
1212
1213    function Next (Object : Iterator; Position : Cursor) return Cursor is
1214    begin
1215       if Position.Container = null then
1216          return No_Element;
1217       end if;
1218
1219       if Position.Container /= Object.Container then
1220          raise Program_Error with
1221            "Position cursor of Next designates wrong list";
1222       end if;
1223
1224       return Next (Position);
1225    end Next;
1226
1227    -------------
1228    -- Prepend --
1229    -------------
1230
1231    procedure Prepend
1232      (Container : in out List;
1233       New_Item  : Element_Type;
1234       Count     : Count_Type := 1)
1235    is
1236    begin
1237       Insert (Container, First (Container), New_Item, Count);
1238    end Prepend;
1239
1240    --------------
1241    -- Previous --
1242    --------------
1243
1244    procedure Previous (Position : in out Cursor) is
1245    begin
1246       Position := Previous (Position);
1247    end Previous;
1248
1249    function Previous (Position : Cursor) return Cursor is
1250    begin
1251       if Position.Node = null then
1252          return No_Element;
1253       end if;
1254
1255       pragma Assert (Vet (Position), "bad cursor in Previous");
1256
1257       declare
1258          Prev_Node : constant Node_Access := Position.Node.Prev;
1259       begin
1260          if Prev_Node = null then
1261             return No_Element;
1262          end if;
1263
1264          return Cursor'(Position.Container, Prev_Node);
1265       end;
1266    end Previous;
1267
1268    function Previous (Object : Iterator; Position : Cursor) return Cursor is
1269    begin
1270       if Position.Container = null then
1271          return No_Element;
1272       end if;
1273
1274       if Position.Container /= Object.Container then
1275          raise Program_Error with
1276            "Position cursor of Previous designates wrong list";
1277       end if;
1278
1279       return Previous (Position);
1280    end Previous;
1281
1282    -------------------
1283    -- Query_Element --
1284    -------------------
1285
1286    procedure Query_Element
1287      (Position : Cursor;
1288       Process  : not null access procedure (Element : Element_Type))
1289    is
1290    begin
1291       if Position.Node = null then
1292          raise Constraint_Error with
1293            "Position cursor has no element";
1294       end if;
1295
1296       if Position.Node.Element = null then
1297          raise Program_Error with
1298            "Position cursor has no element";
1299       end if;
1300
1301       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1302
1303       declare
1304          C : List renames Position.Container.all'Unrestricted_Access.all;
1305          B : Natural renames C.Busy;
1306          L : Natural renames C.Lock;
1307
1308       begin
1309          B := B + 1;
1310          L := L + 1;
1311
1312          begin
1313             Process (Position.Node.Element.all);
1314          exception
1315             when others =>
1316                L := L - 1;
1317                B := B - 1;
1318                raise;
1319          end;
1320
1321          L := L - 1;
1322          B := B - 1;
1323       end;
1324    end Query_Element;
1325
1326    ----------
1327    -- Read --
1328    ----------
1329
1330    procedure Read
1331      (Stream : not null access Root_Stream_Type'Class;
1332       Item   : out List)
1333    is
1334       N   : Count_Type'Base;
1335       Dst : Node_Access;
1336
1337    begin
1338       Clear (Item);
1339
1340       Count_Type'Base'Read (Stream, N);
1341
1342       if N = 0 then
1343          return;
1344       end if;
1345
1346       declare
1347          Element : Element_Access :=
1348                      new Element_Type'(Element_Type'Input (Stream));
1349       begin
1350          Dst := new Node_Type'(Element, null, null);
1351       exception
1352          when others =>
1353             Free (Element);
1354             raise;
1355       end;
1356
1357       Item.First := Dst;
1358       Item.Last := Dst;
1359       Item.Length := 1;
1360
1361       while Item.Length < N loop
1362          declare
1363             Element : Element_Access :=
1364                         new Element_Type'(Element_Type'Input (Stream));
1365          begin
1366             Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1367          exception
1368             when others =>
1369                Free (Element);
1370                raise;
1371          end;
1372
1373          Item.Last.Next := Dst;
1374          Item.Last := Dst;
1375          Item.Length := Item.Length + 1;
1376       end loop;
1377    end Read;
1378
1379    procedure Read
1380      (Stream : not null access Root_Stream_Type'Class;
1381       Item   : out Cursor)
1382    is
1383    begin
1384       raise Program_Error with "attempt to stream list cursor";
1385    end Read;
1386
1387    procedure Read
1388      (Stream : not null access Root_Stream_Type'Class;
1389       Item   : out Reference_Type)
1390    is
1391    begin
1392       raise Program_Error with "attempt to stream reference";
1393    end Read;
1394
1395    procedure Read
1396      (Stream : not null access Root_Stream_Type'Class;
1397       Item   : out Constant_Reference_Type)
1398    is
1399    begin
1400       raise Program_Error with "attempt to stream reference";
1401    end Read;
1402
1403    ---------------
1404    -- Reference --
1405    ---------------
1406
1407    function Reference
1408      (Container : aliased in out List;
1409       Position  : Cursor) return Reference_Type
1410    is
1411    begin
1412       if Position.Container = null then
1413          raise Constraint_Error with "Position cursor has no element";
1414       end if;
1415
1416       if Position.Container /= Container'Unrestricted_Access then
1417          raise Program_Error with
1418            "Position cursor designates wrong container";
1419       end if;
1420
1421       if Position.Node.Element = null then
1422          raise Program_Error with "Node has no element";
1423       end if;
1424
1425       pragma Assert (Vet (Position), "bad cursor in function Reference");
1426
1427       declare
1428          C : List renames Position.Container.all;
1429          B : Natural renames C.Busy;
1430          L : Natural renames C.Lock;
1431       begin
1432          return R : constant Reference_Type :=
1433                       (Element => Position.Node.Element.all'Access,
1434                        Control => (Controlled with Position.Container))
1435          do
1436             B := B + 1;
1437             L := L + 1;
1438          end return;
1439       end;
1440    end Reference;
1441
1442    ---------------------
1443    -- Replace_Element --
1444    ---------------------
1445
1446    procedure Replace_Element
1447      (Container : in out List;
1448       Position  : Cursor;
1449       New_Item  : Element_Type)
1450    is
1451    begin
1452       if Position.Container = null then
1453          raise Constraint_Error with "Position cursor has no element";
1454       end if;
1455
1456       if Position.Container /= Container'Unchecked_Access then
1457          raise Program_Error with
1458            "Position cursor designates wrong container";
1459       end if;
1460
1461       if Container.Lock > 0 then
1462          raise Program_Error with
1463            "attempt to tamper with elements (list is locked)";
1464       end if;
1465
1466       if Position.Node.Element = null then
1467          raise Program_Error with
1468            "Position cursor has no element";
1469       end if;
1470
1471       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1472
1473       declare
1474          --  The element allocator may need an accessibility check in the case
1475          --  the actual type is class-wide or has access discriminants (see
1476          --  RM 4.8(10.1) and AI12-0035).
1477
1478          pragma Unsuppress (Accessibility_Check);
1479
1480          X : Element_Access := Position.Node.Element;
1481
1482       begin
1483          Position.Node.Element := new Element_Type'(New_Item);
1484          Free (X);
1485       end;
1486    end Replace_Element;
1487
1488    ----------------------
1489    -- Reverse_Elements --
1490    ----------------------
1491
1492    procedure Reverse_Elements (Container : in out List) is
1493       I : Node_Access := Container.First;
1494       J : Node_Access := Container.Last;
1495
1496       procedure Swap (L, R : Node_Access);
1497
1498       ----------
1499       -- Swap --
1500       ----------
1501
1502       procedure Swap (L, R : Node_Access) is
1503          LN : constant Node_Access := L.Next;
1504          LP : constant Node_Access := L.Prev;
1505
1506          RN : constant Node_Access := R.Next;
1507          RP : constant Node_Access := R.Prev;
1508
1509       begin
1510          if LP /= null then
1511             LP.Next := R;
1512          end if;
1513
1514          if RN /= null then
1515             RN.Prev := L;
1516          end if;
1517
1518          L.Next := RN;
1519          R.Prev := LP;
1520
1521          if LN = R then
1522             pragma Assert (RP = L);
1523
1524             L.Prev := R;
1525             R.Next := L;
1526
1527          else
1528             L.Prev := RP;
1529             RP.Next := L;
1530
1531             R.Next := LN;
1532             LN.Prev := R;
1533          end if;
1534       end Swap;
1535
1536    --  Start of processing for Reverse_Elements
1537
1538    begin
1539       if Container.Length <= 1 then
1540          return;
1541       end if;
1542
1543       pragma Assert (Container.First.Prev = null);
1544       pragma Assert (Container.Last.Next = null);
1545
1546       if Container.Busy > 0 then
1547          raise Program_Error with
1548            "attempt to tamper with cursors (list is busy)";
1549       end if;
1550
1551       Container.First := J;
1552       Container.Last := I;
1553       loop
1554          Swap (L => I, R => J);
1555
1556          J := J.Next;
1557          exit when I = J;
1558
1559          I := I.Prev;
1560          exit when I = J;
1561
1562          Swap (L => J, R => I);
1563
1564          I := I.Next;
1565          exit when I = J;
1566
1567          J := J.Prev;
1568          exit when I = J;
1569       end loop;
1570
1571       pragma Assert (Container.First.Prev = null);
1572       pragma Assert (Container.Last.Next = null);
1573    end Reverse_Elements;
1574
1575    ------------------
1576    -- Reverse_Find --
1577    ------------------
1578
1579    function Reverse_Find
1580      (Container : List;
1581       Item      : Element_Type;
1582       Position  : Cursor := No_Element) return Cursor
1583    is
1584       Node : Node_Access := Position.Node;
1585
1586    begin
1587       if Node = null then
1588          Node := Container.Last;
1589
1590       else
1591          if Node.Element = null then
1592             raise Program_Error with "Position cursor has no element";
1593          end if;
1594
1595          if Position.Container /= Container'Unrestricted_Access then
1596             raise Program_Error with
1597               "Position cursor designates wrong container";
1598          end if;
1599
1600          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1601       end if;
1602
1603       while Node /= null loop
1604          if Node.Element.all = Item then
1605             return Cursor'(Container'Unrestricted_Access, Node);
1606          end if;
1607
1608          Node := Node.Prev;
1609       end loop;
1610
1611       return No_Element;
1612    end Reverse_Find;
1613
1614    ---------------------
1615    -- Reverse_Iterate --
1616    ---------------------
1617
1618    procedure Reverse_Iterate
1619      (Container : List;
1620       Process   : not null access procedure (Position : Cursor))
1621    is
1622       C : List renames Container'Unrestricted_Access.all;
1623       B : Natural renames C.Busy;
1624
1625       Node : Node_Access := Container.Last;
1626
1627    begin
1628       B := B + 1;
1629
1630       begin
1631          while Node /= null loop
1632             Process (Cursor'(Container'Unrestricted_Access, Node));
1633             Node := Node.Prev;
1634          end loop;
1635       exception
1636          when others =>
1637             B := B - 1;
1638             raise;
1639       end;
1640
1641       B := B - 1;
1642    end Reverse_Iterate;
1643
1644    ------------
1645    -- Splice --
1646    ------------
1647
1648    procedure Splice
1649      (Target : in out List;
1650       Before : Cursor;
1651       Source : in out List)
1652    is
1653    begin
1654       if Before.Container /= null then
1655          if Before.Container /= Target'Unrestricted_Access then
1656             raise Program_Error with
1657               "Before cursor designates wrong container";
1658          end if;
1659
1660          if Before.Node = null
1661            or else Before.Node.Element = null
1662          then
1663             raise Program_Error with
1664               "Before cursor has no element";
1665          end if;
1666
1667          pragma Assert (Vet (Before), "bad cursor in Splice");
1668       end if;
1669
1670       if Target'Address = Source'Address
1671         or else Source.Length = 0
1672       then
1673          return;
1674       end if;
1675
1676       pragma Assert (Source.First.Prev = null);
1677       pragma Assert (Source.Last.Next = null);
1678
1679       if Target.Length > Count_Type'Last - Source.Length then
1680          raise Constraint_Error with "new length exceeds maximum";
1681       end if;
1682
1683       if Target.Busy > 0 then
1684          raise Program_Error with
1685            "attempt to tamper with cursors of Target (list is busy)";
1686       end if;
1687
1688       if Source.Busy > 0 then
1689          raise Program_Error with
1690            "attempt to tamper with cursors of Source (list is busy)";
1691       end if;
1692
1693       if Target.Length = 0 then
1694          pragma Assert (Before = No_Element);
1695          pragma Assert (Target.First = null);
1696          pragma Assert (Target.Last = null);
1697
1698          Target.First := Source.First;
1699          Target.Last := Source.Last;
1700
1701       elsif Before.Node = null then
1702          pragma Assert (Target.Last.Next = null);
1703
1704          Target.Last.Next := Source.First;
1705          Source.First.Prev := Target.Last;
1706
1707          Target.Last := Source.Last;
1708
1709       elsif Before.Node = Target.First then
1710          pragma Assert (Target.First.Prev = null);
1711
1712          Source.Last.Next := Target.First;
1713          Target.First.Prev := Source.Last;
1714
1715          Target.First := Source.First;
1716
1717       else
1718          pragma Assert (Target.Length >= 2);
1719          Before.Node.Prev.Next := Source.First;
1720          Source.First.Prev := Before.Node.Prev;
1721
1722          Before.Node.Prev := Source.Last;
1723          Source.Last.Next := Before.Node;
1724       end if;
1725
1726       Source.First := null;
1727       Source.Last := null;
1728
1729       Target.Length := Target.Length + Source.Length;
1730       Source.Length := 0;
1731    end Splice;
1732
1733    procedure Splice
1734      (Container : in out List;
1735       Before    : Cursor;
1736       Position  : Cursor)
1737    is
1738    begin
1739       if Before.Container /= null then
1740          if Before.Container /= Container'Unchecked_Access then
1741             raise Program_Error with
1742               "Before cursor designates wrong container";
1743          end if;
1744
1745          if Before.Node = null
1746            or else Before.Node.Element = null
1747          then
1748             raise Program_Error with
1749               "Before cursor has no element";
1750          end if;
1751
1752          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1753       end if;
1754
1755       if Position.Node = null then
1756          raise Constraint_Error with "Position cursor has no element";
1757       end if;
1758
1759       if Position.Node.Element = null then
1760          raise Program_Error with "Position cursor has no element";
1761       end if;
1762
1763       if Position.Container /= Container'Unrestricted_Access then
1764          raise Program_Error with
1765            "Position cursor designates wrong container";
1766       end if;
1767
1768       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1769
1770       if Position.Node = Before.Node
1771         or else Position.Node.Next = Before.Node
1772       then
1773          return;
1774       end if;
1775
1776       pragma Assert (Container.Length >= 2);
1777
1778       if Container.Busy > 0 then
1779          raise Program_Error with
1780            "attempt to tamper with cursors (list is busy)";
1781       end if;
1782
1783       if Before.Node = null then
1784          pragma Assert (Position.Node /= Container.Last);
1785
1786          if Position.Node = Container.First then
1787             Container.First := Position.Node.Next;
1788             Container.First.Prev := null;
1789          else
1790             Position.Node.Prev.Next := Position.Node.Next;
1791             Position.Node.Next.Prev := Position.Node.Prev;
1792          end if;
1793
1794          Container.Last.Next := Position.Node;
1795          Position.Node.Prev := Container.Last;
1796
1797          Container.Last := Position.Node;
1798          Container.Last.Next := null;
1799
1800          return;
1801       end if;
1802
1803       if Before.Node = Container.First then
1804          pragma Assert (Position.Node /= Container.First);
1805
1806          if Position.Node = Container.Last then
1807             Container.Last := Position.Node.Prev;
1808             Container.Last.Next := null;
1809          else
1810             Position.Node.Prev.Next := Position.Node.Next;
1811             Position.Node.Next.Prev := Position.Node.Prev;
1812          end if;
1813
1814          Container.First.Prev := Position.Node;
1815          Position.Node.Next := Container.First;
1816
1817          Container.First := Position.Node;
1818          Container.First.Prev := null;
1819
1820          return;
1821       end if;
1822
1823       if Position.Node = Container.First then
1824          Container.First := Position.Node.Next;
1825          Container.First.Prev := null;
1826
1827       elsif Position.Node = Container.Last then
1828          Container.Last := Position.Node.Prev;
1829          Container.Last.Next := null;
1830
1831       else
1832          Position.Node.Prev.Next := Position.Node.Next;
1833          Position.Node.Next.Prev := Position.Node.Prev;
1834       end if;
1835
1836       Before.Node.Prev.Next := Position.Node;
1837       Position.Node.Prev := Before.Node.Prev;
1838
1839       Before.Node.Prev := Position.Node;
1840       Position.Node.Next := Before.Node;
1841
1842       pragma Assert (Container.First.Prev = null);
1843       pragma Assert (Container.Last.Next = null);
1844    end Splice;
1845
1846    procedure Splice
1847      (Target   : in out List;
1848       Before   : Cursor;
1849       Source   : in out List;
1850       Position : in out Cursor)
1851    is
1852    begin
1853       if Target'Address = Source'Address then
1854          Splice (Target, Before, Position);
1855          return;
1856       end if;
1857
1858       if Before.Container /= null then
1859          if Before.Container /= Target'Unrestricted_Access then
1860             raise Program_Error with
1861               "Before cursor designates wrong container";
1862          end if;
1863
1864          if Before.Node = null
1865            or else Before.Node.Element = null
1866          then
1867             raise Program_Error with
1868               "Before cursor has no element";
1869          end if;
1870
1871          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1872       end if;
1873
1874       if Position.Node = null then
1875          raise Constraint_Error with "Position cursor has no element";
1876       end if;
1877
1878       if Position.Node.Element = null then
1879          raise Program_Error with
1880            "Position cursor has no element";
1881       end if;
1882
1883       if Position.Container /= Source'Unrestricted_Access then
1884          raise Program_Error with
1885            "Position cursor designates wrong container";
1886       end if;
1887
1888       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1889
1890       if Target.Length = Count_Type'Last then
1891          raise Constraint_Error with "Target is full";
1892       end if;
1893
1894       if Target.Busy > 0 then
1895          raise Program_Error with
1896            "attempt to tamper with cursors of Target (list is busy)";
1897       end if;
1898
1899       if Source.Busy > 0 then
1900          raise Program_Error with
1901            "attempt to tamper with cursors of Source (list is busy)";
1902       end if;
1903
1904       if Position.Node = Source.First then
1905          Source.First := Position.Node.Next;
1906
1907          if Position.Node = Source.Last then
1908             pragma Assert (Source.First = null);
1909             pragma Assert (Source.Length = 1);
1910             Source.Last := null;
1911
1912          else
1913             Source.First.Prev := null;
1914          end if;
1915
1916       elsif Position.Node = Source.Last then
1917          pragma Assert (Source.Length >= 2);
1918          Source.Last := Position.Node.Prev;
1919          Source.Last.Next := null;
1920
1921       else
1922          pragma Assert (Source.Length >= 3);
1923          Position.Node.Prev.Next := Position.Node.Next;
1924          Position.Node.Next.Prev := Position.Node.Prev;
1925       end if;
1926
1927       if Target.Length = 0 then
1928          pragma Assert (Before = No_Element);
1929          pragma Assert (Target.First = null);
1930          pragma Assert (Target.Last = null);
1931
1932          Target.First := Position.Node;
1933          Target.Last := Position.Node;
1934
1935          Target.First.Prev := null;
1936          Target.Last.Next := null;
1937
1938       elsif Before.Node = null then
1939          pragma Assert (Target.Last.Next = null);
1940          Target.Last.Next := Position.Node;
1941          Position.Node.Prev := Target.Last;
1942
1943          Target.Last := Position.Node;
1944          Target.Last.Next := null;
1945
1946       elsif Before.Node = Target.First then
1947          pragma Assert (Target.First.Prev = null);
1948          Target.First.Prev := Position.Node;
1949          Position.Node.Next := Target.First;
1950
1951          Target.First := Position.Node;
1952          Target.First.Prev := null;
1953
1954       else
1955          pragma Assert (Target.Length >= 2);
1956          Before.Node.Prev.Next := Position.Node;
1957          Position.Node.Prev := Before.Node.Prev;
1958
1959          Before.Node.Prev := Position.Node;
1960          Position.Node.Next := Before.Node;
1961       end if;
1962
1963       Target.Length := Target.Length + 1;
1964       Source.Length := Source.Length - 1;
1965
1966       Position.Container := Target'Unchecked_Access;
1967    end Splice;
1968
1969    ----------
1970    -- Swap --
1971    ----------
1972
1973    procedure Swap
1974      (Container : in out List;
1975       I, J      : Cursor)
1976    is
1977    begin
1978       if I.Node = null then
1979          raise Constraint_Error with "I cursor has no element";
1980       end if;
1981
1982       if J.Node = null then
1983          raise Constraint_Error with "J cursor has no element";
1984       end if;
1985
1986       if I.Container /= Container'Unchecked_Access then
1987          raise Program_Error with "I cursor designates wrong container";
1988       end if;
1989
1990       if J.Container /= Container'Unchecked_Access then
1991          raise Program_Error with "J cursor designates wrong container";
1992       end if;
1993
1994       if I.Node = J.Node then
1995          return;
1996       end if;
1997
1998       if Container.Lock > 0 then
1999          raise Program_Error with
2000            "attempt to tamper with elements (list is locked)";
2001       end if;
2002
2003       pragma Assert (Vet (I), "bad I cursor in Swap");
2004       pragma Assert (Vet (J), "bad J cursor in Swap");
2005
2006       declare
2007          EI_Copy : constant Element_Access := I.Node.Element;
2008
2009       begin
2010          I.Node.Element := J.Node.Element;
2011          J.Node.Element := EI_Copy;
2012       end;
2013    end Swap;
2014
2015    ----------------
2016    -- Swap_Links --
2017    ----------------
2018
2019    procedure Swap_Links
2020      (Container : in out List;
2021       I, J      : Cursor)
2022    is
2023    begin
2024       if I.Node = null then
2025          raise Constraint_Error with "I cursor has no element";
2026       end if;
2027
2028       if J.Node = null then
2029          raise Constraint_Error with "J cursor has no element";
2030       end if;
2031
2032       if I.Container /= Container'Unrestricted_Access then
2033          raise Program_Error with "I cursor designates wrong container";
2034       end if;
2035
2036       if J.Container /= Container'Unrestricted_Access then
2037          raise Program_Error with "J cursor designates wrong container";
2038       end if;
2039
2040       if I.Node = J.Node then
2041          return;
2042       end if;
2043
2044       if Container.Busy > 0 then
2045          raise Program_Error with
2046            "attempt to tamper with cursors (list is busy)";
2047       end if;
2048
2049       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2050       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2051
2052       declare
2053          I_Next : constant Cursor := Next (I);
2054
2055       begin
2056          if I_Next = J then
2057             Splice (Container, Before => I, Position => J);
2058
2059          else
2060             declare
2061                J_Next : constant Cursor := Next (J);
2062
2063             begin
2064                if J_Next = I then
2065                   Splice (Container, Before => J, Position => I);
2066
2067                else
2068                   pragma Assert (Container.Length >= 3);
2069
2070                   Splice (Container, Before => I_Next, Position => J);
2071                   Splice (Container, Before => J_Next, Position => I);
2072                end if;
2073             end;
2074          end if;
2075       end;
2076
2077       pragma Assert (Container.First.Prev = null);
2078       pragma Assert (Container.Last.Next = null);
2079    end Swap_Links;
2080
2081    --------------------
2082    -- Update_Element --
2083    --------------------
2084
2085    procedure Update_Element
2086      (Container : in out List;
2087       Position  : Cursor;
2088       Process   : not null access procedure (Element : in out Element_Type))
2089    is
2090    begin
2091       if Position.Node = null then
2092          raise Constraint_Error with "Position cursor has no element";
2093       end if;
2094
2095       if Position.Node.Element = null then
2096          raise Program_Error with
2097            "Position cursor has no element";
2098       end if;
2099
2100       if Position.Container /= Container'Unchecked_Access then
2101          raise Program_Error with
2102            "Position cursor designates wrong container";
2103       end if;
2104
2105       pragma Assert (Vet (Position), "bad cursor in Update_Element");
2106
2107       declare
2108          B : Natural renames Container.Busy;
2109          L : Natural renames Container.Lock;
2110
2111       begin
2112          B := B + 1;
2113          L := L + 1;
2114
2115          begin
2116             Process (Position.Node.Element.all);
2117          exception
2118             when others =>
2119                L := L - 1;
2120                B := B - 1;
2121                raise;
2122          end;
2123
2124          L := L - 1;
2125          B := B - 1;
2126       end;
2127    end Update_Element;
2128
2129    ---------
2130    -- Vet --
2131    ---------
2132
2133    function Vet (Position : Cursor) return Boolean is
2134    begin
2135       if Position.Node = null then
2136          return Position.Container = null;
2137       end if;
2138
2139       if Position.Container = null then
2140          return False;
2141       end if;
2142
2143       --  An invariant of a node is that its Previous and Next components can
2144       --  be null, or designate a different node. Also, its element access
2145       --  value must be non-null. Operation Free sets the node access value
2146       --  components of the node to designate the node itself, and the element
2147       --  access value to null, before actually deallocating the node, thus
2148       --  deliberately violating the node invariant. This gives us a simple way
2149       --  to detect a dangling reference to a node.
2150
2151       if Position.Node.Next = Position.Node then
2152          return False;
2153       end if;
2154
2155       if Position.Node.Prev = Position.Node then
2156          return False;
2157       end if;
2158
2159       if Position.Node.Element = null then
2160          return False;
2161       end if;
2162
2163       --  In practice the tests above will detect most instances of a dangling
2164       --  reference. If we get here, it means that the invariants of the
2165       --  designated node are satisfied (they at least appear to be satisfied),
2166       --  so we perform some more tests, to determine whether invariants of the
2167       --  designated list are satisfied too.
2168
2169       declare
2170          L : List renames Position.Container.all;
2171
2172       begin
2173          if L.Length = 0 then
2174             return False;
2175          end if;
2176
2177          if L.First = null then
2178             return False;
2179          end if;
2180
2181          if L.Last = null then
2182             return False;
2183          end if;
2184
2185          if L.First.Prev /= null then
2186             return False;
2187          end if;
2188
2189          if L.Last.Next /= null then
2190             return False;
2191          end if;
2192
2193          if Position.Node.Prev = null and then Position.Node /= L.First then
2194             return False;
2195          end if;
2196
2197          if Position.Node.Next = null and then Position.Node /= L.Last then
2198             return False;
2199          end if;
2200
2201          if L.Length = 1 then
2202             return L.First = L.Last;
2203          end if;
2204
2205          if L.First = L.Last then
2206             return False;
2207          end if;
2208
2209          if L.First.Next = null then
2210             return False;
2211          end if;
2212
2213          if L.Last.Prev = null then
2214             return False;
2215          end if;
2216
2217          if L.First.Next.Prev /= L.First then
2218             return False;
2219          end if;
2220
2221          if L.Last.Prev.Next /= L.Last then
2222             return False;
2223          end if;
2224
2225          if L.Length = 2 then
2226             if L.First.Next /= L.Last then
2227                return False;
2228             end if;
2229
2230             if L.Last.Prev /= L.First then
2231                return False;
2232             end if;
2233
2234             return True;
2235          end if;
2236
2237          if L.First.Next = L.Last then
2238             return False;
2239          end if;
2240
2241          if L.Last.Prev = L.First then
2242             return False;
2243          end if;
2244
2245          if Position.Node = L.First then
2246             return True;
2247          end if;
2248
2249          if Position.Node = L.Last then
2250             return True;
2251          end if;
2252
2253          if Position.Node.Next = null then
2254             return False;
2255          end if;
2256
2257          if Position.Node.Prev = null then
2258             return False;
2259          end if;
2260
2261          if Position.Node.Next.Prev /= Position.Node then
2262             return False;
2263          end if;
2264
2265          if Position.Node.Prev.Next /= Position.Node then
2266             return False;
2267          end if;
2268
2269          if L.Length = 3 then
2270             if L.First.Next /= Position.Node then
2271                return False;
2272             end if;
2273
2274             if L.Last.Prev /= Position.Node then
2275                return False;
2276             end if;
2277          end if;
2278
2279          return True;
2280       end;
2281    end Vet;
2282
2283    -----------
2284    -- Write --
2285    -----------
2286
2287    procedure Write
2288      (Stream : not null access Root_Stream_Type'Class;
2289       Item   : List)
2290    is
2291       Node : Node_Access := Item.First;
2292
2293    begin
2294       Count_Type'Base'Write (Stream, Item.Length);
2295
2296       while Node /= null loop
2297          Element_Type'Output (Stream, Node.Element.all);
2298          Node := Node.Next;
2299       end loop;
2300    end Write;
2301
2302    procedure Write
2303      (Stream : not null access Root_Stream_Type'Class;
2304       Item   : Cursor)
2305    is
2306    begin
2307       raise Program_Error with "attempt to stream list cursor";
2308    end Write;
2309
2310    procedure Write
2311      (Stream : not null access Root_Stream_Type'Class;
2312       Item   : Reference_Type)
2313    is
2314    begin
2315       raise Program_Error with "attempt to stream reference";
2316    end Write;
2317
2318    procedure Write
2319      (Stream : not null access Root_Stream_Type'Class;
2320       Item   : Constant_Reference_Type)
2321    is
2322    begin
2323       raise Program_Error with "attempt to stream reference";
2324    end Write;
2325
2326 end Ada.Containers.Indefinite_Doubly_Linked_Lists;