gcc/ada/a-cdlili.adb

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