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