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