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