gcc/ada/a-cidlli.adb

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