gcc/ada/a-cdlili.adb

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