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