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