gcc/ada/a-cdlili.adb

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