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