gcc/ada/a-cbdlli.adb

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