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