gcc/ada/a-cidlli.adb

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