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