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