File : a-cidlli.adb


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