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