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