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