gcc/ada/a-cfdlli.adb

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