gcc/ada/a-cdlili.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                    ADA.CONTAINERS.DOUBLY_LINKED_LISTS                    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 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,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, 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 Delete_Node
  49      (Container : in out List;
  50       Node      : in out Node_Access);
  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 := Left.First;
  63       R : Node_Access := Right.First;
  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       for J in 1 .. Left.Length loop
  75          if L.Element /= R.Element then
  76             return False;
  77          end if;
  78
  79          L := L.Next;
  80          R := R.Next;
  81       end loop;
  82
  83       return True;
  84    end "=";
  85
  86    ------------
  87    -- Adjust --
  88    ------------
  89
  90    procedure Adjust (Container : in out List) is
  91       Src    : Node_Access := Container.First;
  92       Length : constant Count_Type := Container.Length;
  93
  94    begin
  95       if Src = null then
  96          pragma Assert (Container.Last = null);
  97          pragma Assert (Length = 0);
  98          return;
  99       end if;
 100
 101       pragma Assert (Container.First.Prev = null);
 102       pragma Assert (Container.Last.Next = null);
 103       pragma Assert (Length > 0);
 104
 105       Container.First := null;
 106       Container.Last := null;
 107       Container.Length := 0;
 108
 109       Container.First := new Node_Type'(Src.Element, null, null);
 110
 111       Container.Last := Container.First;
 112       loop
 113          Container.Length := Container.Length + 1;
 114          Src := Src.Next;
 115          exit when Src = null;
 116          Container.Last.Next := new Node_Type'(Element => Src.Element,
 117                                                Prev    => Container.Last,
 118                                                Next    => null);
 119          Container.Last := Container.Last.Next;
 120       end loop;
 121
 122       pragma Assert (Container.Length = Length);
 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)
 133    is
 134    begin
 135       Insert (Container, No_Element, New_Item, Count);
 136    end Append;
 137
 138    -----------
 139    -- Clear --
 140    -----------
 141
 142    procedure Clear (Container : in out List) is
 143    begin
 144       Delete_Last (Container, Count => Container.Length);
 145    end Clear;
 146
 147    --------------
 148    -- Continue --
 149    --------------
 150
 151    function Contains
 152      (Container : List;
 153       Item      : Element_Type) return Boolean
 154    is
 155    begin
 156       return Find (Container, Item) /= No_Element;
 157    end Contains;
 158
 159    ------------
 160    -- Delete --
 161    ------------
 162
 163    procedure Delete
 164      (Container : in out List;
 165       Position  : in out Cursor;
 166       Count     : Count_Type := 1)
 167    is
 168    begin
 169       if Position = No_Element then
 170          return;
 171       end if;
 172
 173       if Position.Container /= List_Access'(Container'Unchecked_Access) then
 174          raise Program_Error;
 175       end if;
 176
 177       for Index in 1 .. Count loop
 178          Delete_Node (Container, Position.Node);
 179
 180          if Position.Node = null then
 181             Position.Container := null;
 182             return;
 183          end if;
 184       end loop;
 185    end Delete;
 186
 187    ------------------
 188    -- Delete_First --
 189    ------------------
 190
 191    procedure Delete_First
 192      (Container : in out List;
 193       Count     : Count_Type := 1)
 194    is
 195       Node : Node_Access := Container.First;
 196    begin
 197       for J in 1 .. Count_Type'Min (Count, Container.Length) loop
 198          Delete_Node (Container, Node);
 199       end loop;
 200    end Delete_First;
 201
 202    -----------------
 203    -- Delete_Last --
 204    -----------------
 205
 206    procedure Delete_Last
 207      (Container : in out List;
 208       Count     : Count_Type := 1)
 209    is
 210       Node : Node_Access;
 211    begin
 212       for J in 1 .. Count_Type'Min (Count, Container.Length) loop
 213          Node := Container.Last;
 214          Delete_Node (Container, Node);
 215       end loop;
 216    end Delete_Last;
 217
 218    -----------------
 219    -- Delete_Node --
 220    -----------------
 221
 222    procedure Delete_Node
 223      (Container : in out List;
 224       Node      : in out Node_Access)
 225    is
 226       X : Node_Access := Node;
 227
 228    begin
 229       Node := X.Next;
 230       Container.Length := Container.Length - 1;
 231
 232       if X = Container.First then
 233          Container.First := X.Next;
 234
 235          if X = Container.Last then
 236             pragma Assert (Container.First = null);
 237             pragma Assert (Container.Length = 0);
 238             Container.Last := null;
 239          else
 240             pragma Assert (Container.Length > 0);
 241             Container.First.Prev := null;
 242          end if;
 243
 244       elsif X = Container.Last then
 245          pragma Assert (Container.Length > 0);
 246
 247          Container.Last := X.Prev;
 248          Container.Last.Next := null;
 249
 250       else
 251          pragma Assert (Container.Length > 0);
 252
 253          X.Next.Prev := X.Prev;
 254          X.Prev.Next := X.Next;
 255       end if;
 256
 257       Free (X);
 258    end Delete_Node;
 259
 260    -------------
 261    -- Element --
 262    -------------
 263
 264    function Element (Position : Cursor) return Element_Type is
 265    begin
 266       return Position.Node.Element;
 267    end Element;
 268
 269    ----------
 270    -- Find --
 271    ----------
 272
 273    function Find
 274      (Container : List;
 275       Item      : Element_Type;
 276       Position  : Cursor := No_Element) return Cursor
 277    is
 278       Node : Node_Access := Position.Node;
 279
 280    begin
 281       if Node = null then
 282          Node := Container.First;
 283       elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
 284          raise Program_Error;
 285       end if;
 286
 287       while Node /= null loop
 288          if Node.Element = Item then
 289             return Cursor'(Container'Unchecked_Access, Node);
 290          end if;
 291
 292          Node := Node.Next;
 293       end loop;
 294
 295       return No_Element;
 296    end Find;
 297
 298    -----------
 299    -- First --
 300    -----------
 301
 302    function First (Container : List) return Cursor is
 303    begin
 304       if Container.First = null then
 305          return No_Element;
 306       end if;
 307
 308       return Cursor'(Container'Unchecked_Access, Container.First);
 309    end First;
 310
 311    -------------------
 312    -- First_Element --
 313    -------------------
 314
 315    function First_Element (Container : List) return Element_Type is
 316    begin
 317       return Container.First.Element;
 318    end First_Element;
 319
 320    -------------------
 321    -- Generic_Merge --
 322    -------------------
 323
 324    procedure Generic_Merge
 325      (Target : in out List;
 326       Source : in out List)
 327    is
 328       LI : Cursor := First (Target);
 329       RI : Cursor := First (Source);
 330
 331    begin
 332       if Target'Address = Source'Address then
 333          return;
 334       end if;
 335
 336       while RI.Node /= null loop
 337          if LI.Node = null then
 338             Splice (Target, No_Element, Source);
 339             return;
 340          end if;
 341
 342          if RI.Node.Element < LI.Node.Element then
 343             declare
 344                RJ : constant Cursor := RI;
 345             begin
 346                RI.Node := RI.Node.Next;
 347                Splice (Target, LI, Source, RJ);
 348             end;
 349
 350          else
 351             LI.Node := LI.Node.Next;
 352          end if;
 353       end loop;
 354    end Generic_Merge;
 355
 356    ------------------
 357    -- Generic_Sort --
 358    ------------------
 359
 360    procedure Generic_Sort (Container : in out List) is
 361
 362       procedure Partition
 363         (Pivot : in Node_Access;
 364          Back  : in Node_Access);
 365
 366       procedure Sort (Front, Back : Node_Access);
 367
 368       ---------------
 369       -- Partition --
 370       ---------------
 371
 372       procedure Partition
 373         (Pivot : Node_Access;
 374          Back  : Node_Access)
 375       is
 376          Node : Node_Access := Pivot.Next;
 377
 378       begin
 379          while Node /= Back loop
 380             if Node.Element < Pivot.Element then
 381                declare
 382                   Prev : constant Node_Access := Node.Prev;
 383                   Next : constant Node_Access := Node.Next;
 384
 385                begin
 386                   Prev.Next := Next;
 387
 388                   if Next = null then
 389                      Container.Last := Prev;
 390                   else
 391                      Next.Prev := Prev;
 392                   end if;
 393
 394                   Node.Next := Pivot;
 395                   Node.Prev := Pivot.Prev;
 396
 397                   Pivot.Prev := Node;
 398
 399                   if Node.Prev = null then
 400                      Container.First := Node;
 401                   else
 402                      Node.Prev.Next := Node;
 403                   end if;
 404
 405                   Node := Next;
 406                end;
 407
 408             else
 409                Node := Node.Next;
 410             end if;
 411          end loop;
 412       end Partition;
 413
 414       ----------
 415       -- Sort --
 416       ----------
 417
 418       procedure Sort (Front, Back : Node_Access) is
 419          Pivot : Node_Access;
 420
 421       begin
 422          if Front = null then
 423             Pivot := Container.First;
 424          else
 425             Pivot := Front.Next;
 426          end if;
 427
 428          if Pivot /= Back then
 429             Partition (Pivot, Back);
 430             Sort (Front, Pivot);
 431             Sort (Pivot, Back);
 432          end if;
 433       end Sort;
 434
 435    --  Start of processing for Generic_Sort
 436
 437    begin
 438       Sort (Front => null, Back => null);
 439
 440       pragma Assert (Container.Length = 0
 441                        or else
 442                          (Container.First.Prev = null
 443                             and then Container.Last.Next = null));
 444    end Generic_Sort;
 445
 446    -----------------
 447    -- Has_Element --
 448    -----------------
 449
 450    function Has_Element (Position : Cursor) return Boolean is
 451    begin
 452       return Position.Container /= null and then Position.Node /= null;
 453    end Has_Element;
 454
 455    ------------
 456    -- Insert --
 457    ------------
 458
 459    procedure Insert
 460      (Container : in out List;
 461       Before    : Cursor;
 462       New_Item  : Element_Type;
 463       Position  : out Cursor;
 464       Count     : Count_Type := 1)
 465    is
 466       New_Node : Node_Access;
 467
 468    begin
 469       if Before.Container /= null
 470         and then Before.Container /= List_Access'(Container'Unchecked_Access)
 471       then
 472          raise Program_Error;
 473       end if;
 474
 475       if Count = 0 then
 476          Position := Before;
 477          return;
 478       end if;
 479
 480       New_Node := new Node_Type'(New_Item, null, null);
 481       Insert_Internal (Container, Before.Node, New_Node);
 482
 483       Position := Cursor'(Before.Container, New_Node);
 484
 485       for J in Count_Type'(2) .. Count loop
 486          New_Node := new Node_Type'(New_Item, null, null);
 487          Insert_Internal (Container, Before.Node, New_Node);
 488       end loop;
 489    end Insert;
 490
 491    procedure Insert
 492      (Container : in out List;
 493       Before    : Cursor;
 494       New_Item  : Element_Type;
 495       Count     : Count_Type := 1)
 496    is
 497       Position : Cursor;
 498    begin
 499       Insert (Container, Before, New_Item, Position, Count);
 500    end Insert;
 501
 502    procedure Insert
 503      (Container : in out List;
 504       Before    : Cursor;
 505       Position  : out Cursor;
 506       Count     : Count_Type := 1)
 507    is
 508       New_Node : Node_Access;
 509
 510    begin
 511       if Before.Container /= null
 512         and then Before.Container /= List_Access'(Container'Unchecked_Access)
 513       then
 514          raise Program_Error;
 515       end if;
 516
 517       if Count = 0 then
 518          Position := Before;
 519          return;
 520       end if;
 521
 522       New_Node := new Node_Type;
 523       Insert_Internal (Container, Before.Node, New_Node);
 524
 525       Position := Cursor'(Before.Container, New_Node);
 526
 527       for J in Count_Type'(2) .. Count loop
 528          New_Node := new Node_Type;
 529          Insert_Internal (Container, Before.Node, New_Node);
 530       end loop;
 531    end Insert;
 532
 533    ---------------------
 534    -- Insert_Internal --
 535    ---------------------
 536
 537    procedure Insert_Internal
 538      (Container : in out List;
 539       Before    : Node_Access;
 540       New_Node  : Node_Access)
 541    is
 542    begin
 543       if Container.Length = 0 then
 544          pragma Assert (Before = null);
 545          pragma Assert (Container.First = null);
 546          pragma Assert (Container.Last = null);
 547
 548          Container.First := New_Node;
 549          Container.Last := New_Node;
 550
 551       elsif Before = null then
 552          pragma Assert (Container.Last.Next = null);
 553
 554          Container.Last.Next := New_Node;
 555          New_Node.Prev := Container.Last;
 556
 557          Container.Last := New_Node;
 558
 559       elsif Before = Container.First then
 560          pragma Assert (Container.First.Prev = null);
 561
 562          Container.First.Prev := New_Node;
 563          New_Node.Next := Container.First;
 564
 565          Container.First := New_Node;
 566
 567       else
 568          pragma Assert (Container.First.Prev = null);
 569          pragma Assert (Container.Last.Next = null);
 570
 571          New_Node.Next := Before;
 572          New_Node.Prev := Before.Prev;
 573
 574          Before.Prev.Next := New_Node;
 575          Before.Prev := New_Node;
 576       end if;
 577
 578       Container.Length := Container.Length + 1;
 579    end Insert_Internal;
 580
 581    --------------
 582    -- Is_Empty --
 583    --------------
 584
 585    function Is_Empty (Container : List) return Boolean is
 586    begin
 587       return Container.Length = 0;
 588    end Is_Empty;
 589
 590    -------------
 591    -- Iterate --
 592    -------------
 593
 594    procedure Iterate
 595      (Container : List;
 596       Process   : not null access procedure (Position : Cursor))
 597    is
 598       Node : Node_Access := Container.First;
 599    begin
 600       while Node /= null loop
 601          Process (Cursor'(Container'Unchecked_Access, Node));
 602          Node := Node.Next;
 603       end loop;
 604    end Iterate;
 605
 606    ----------
 607    -- Last --
 608    ----------
 609
 610    function Last (Container : List) return Cursor is
 611    begin
 612       if Container.Last = null then
 613          return No_Element;
 614       end if;
 615
 616       return Cursor'(Container'Unchecked_Access, Container.Last);
 617    end Last;
 618
 619    ------------------
 620    -- Last_Element --
 621    ------------------
 622
 623    function Last_Element (Container : List) return Element_Type is
 624    begin
 625       return Container.Last.Element;
 626    end Last_Element;
 627
 628    ------------
 629    -- Length --
 630    ------------
 631
 632    function Length (Container : List) return Count_Type is
 633    begin
 634       return Container.Length;
 635    end Length;
 636
 637    ----------
 638    -- Move --
 639    ----------
 640
 641    procedure Move
 642      (Target : in out List;
 643       Source : in out List)
 644    is
 645    begin
 646       if Target'Address = Source'Address then
 647          return;
 648       end if;
 649
 650       if Target.Length > 0 then
 651          raise Constraint_Error;
 652       end if;
 653
 654       Target.First := Source.First;
 655       Source.First := null;
 656
 657       Target.Last := Source.Last;
 658       Source.Last := null;
 659
 660       Target.Length := Source.Length;
 661       Source.Length := 0;
 662    end Move;
 663
 664    ----------
 665    -- Next --
 666    ----------
 667
 668    procedure Next (Position : in out Cursor) is
 669    begin
 670       if Position.Node = null then
 671          return;
 672       end if;
 673
 674       Position.Node := Position.Node.Next;
 675
 676       if Position.Node = null then
 677          Position.Container := null;
 678       end if;
 679    end Next;
 680
 681    function Next (Position : Cursor) return Cursor is
 682    begin
 683       if Position.Node = null then
 684          return No_Element;
 685       end if;
 686
 687       declare
 688          Next_Node : constant Node_Access := Position.Node.Next;
 689       begin
 690          if Next_Node = null then
 691             return No_Element;
 692          end if;
 693
 694          return Cursor'(Position.Container, Next_Node);
 695       end;
 696    end Next;
 697
 698    -------------
 699    -- Prepend --
 700    -------------
 701
 702    procedure Prepend
 703      (Container : in out List;
 704       New_Item  : Element_Type;
 705       Count     : Count_Type := 1)
 706    is
 707    begin
 708       Insert (Container, First (Container), New_Item, Count);
 709    end Prepend;
 710
 711    --------------
 712    -- Previous --
 713    --------------
 714
 715    procedure Previous (Position : in out Cursor) is
 716    begin
 717       if Position.Node = null then
 718          return;
 719       end if;
 720
 721       Position.Node := Position.Node.Prev;
 722
 723       if Position.Node = null then
 724          Position.Container := null;
 725       end if;
 726    end Previous;
 727
 728    function Previous (Position : Cursor) return Cursor is
 729    begin
 730       if Position.Node = null then
 731          return No_Element;
 732       end if;
 733
 734       declare
 735          Prev_Node : constant Node_Access := Position.Node.Prev;
 736       begin
 737          if Prev_Node = null then
 738             return No_Element;
 739          end if;
 740
 741          return Cursor'(Position.Container, Prev_Node);
 742       end;
 743    end Previous;
 744
 745    -------------------
 746    -- Query_Element --
 747    -------------------
 748
 749    procedure Query_Element
 750      (Position : Cursor;
 751       Process  : not null access procedure (Element : in Element_Type))
 752    is
 753    begin
 754       Process (Position.Node.Element);
 755    end Query_Element;
 756
 757    ----------
 758    -- Read --
 759    ----------
 760
 761    procedure Read
 762      (Stream : access Root_Stream_Type'Class;
 763       Item   : out List)
 764    is
 765       N : Count_Type'Base;
 766       X : Node_Access;
 767
 768    begin
 769       Clear (Item);  --  ???
 770       Count_Type'Base'Read (Stream, N);
 771
 772       if N = 0 then
 773          return;
 774       end if;
 775
 776       X := new Node_Type;
 777
 778       begin
 779          Element_Type'Read (Stream, X.Element);
 780       exception
 781          when others =>
 782             Free (X);
 783             raise;
 784       end;
 785
 786       Item.First := X;
 787       Item.Last := X;
 788
 789       loop
 790          Item.Length := Item.Length + 1;
 791          exit when Item.Length = N;
 792
 793          X := new Node_Type;
 794
 795          begin
 796             Element_Type'Read (Stream, X.Element);
 797          exception
 798             when others =>
 799                Free (X);
 800                raise;
 801          end;
 802
 803          X.Prev := Item.Last;
 804          Item.Last.Next := X;
 805          Item.Last := X;
 806       end loop;
 807    end Read;
 808
 809    ---------------------
 810    -- Replace_Element --
 811    ---------------------
 812
 813    procedure Replace_Element
 814      (Position : Cursor;
 815       By       : Element_Type)
 816    is
 817    begin
 818       Position.Node.Element := By;
 819    end Replace_Element;
 820
 821    ------------------
 822    -- Reverse_Find --
 823    ------------------
 824
 825    function Reverse_Find
 826      (Container : List;
 827       Item      : Element_Type;
 828       Position  : Cursor := No_Element) return Cursor
 829    is
 830       Node : Node_Access := Position.Node;
 831
 832    begin
 833       if Node = null then
 834          Node := Container.Last;
 835       elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
 836          raise Program_Error;
 837       end if;
 838
 839       while Node /= null loop
 840          if Node.Element = Item then
 841             return Cursor'(Container'Unchecked_Access, Node);
 842          end if;
 843
 844          Node := Node.Prev;
 845       end loop;
 846
 847       return No_Element;
 848    end Reverse_Find;
 849
 850    ---------------------
 851    -- Reverse_Iterate --
 852    ---------------------
 853
 854    procedure Reverse_Iterate
 855      (Container : List;
 856       Process   : not null access procedure (Position : Cursor))
 857    is
 858       Node : Node_Access := Container.Last;
 859    begin
 860       while Node /= null loop
 861          Process (Cursor'(Container'Unchecked_Access, Node));
 862          Node := Node.Prev;
 863       end loop;
 864    end Reverse_Iterate;
 865
 866    ------------------
 867    -- Reverse_List --
 868    ------------------
 869
 870    procedure Reverse_List (Container : in out List) is
 871       I : Node_Access := Container.First;
 872       J : Node_Access := Container.Last;
 873
 874       procedure Swap (L, R : Node_Access);
 875
 876       ----------
 877       -- Swap --
 878       ----------
 879
 880       procedure Swap (L, R : Node_Access) is
 881          LN : constant Node_Access := L.Next;
 882          LP : constant Node_Access := L.Prev;
 883
 884          RN : constant Node_Access := R.Next;
 885          RP : constant Node_Access := R.Prev;
 886
 887       begin
 888          if LP /= null then
 889             LP.Next := R;
 890          end if;
 891
 892          if RN /= null then
 893             RN.Prev := L;
 894          end if;
 895
 896          L.Next := RN;
 897          R.Prev := LP;
 898
 899          if LN = R then
 900             pragma Assert (RP = L);
 901
 902             L.Prev := R;
 903             R.Next := L;
 904
 905          else
 906             L.Prev := RP;
 907             RP.Next := L;
 908
 909             R.Next := LN;
 910             LN.Prev := R;
 911          end if;
 912       end Swap;
 913
 914    --  Start of processing for Reverse_List
 915
 916    begin
 917       if Container.Length <= 1 then
 918          return;
 919       end if;
 920
 921       Container.First := J;
 922       Container.Last := I;
 923       loop
 924          Swap (L => I, R => J);
 925
 926          J := J.Next;
 927          exit when I = J;
 928
 929          I := I.Prev;
 930          exit when I = J;
 931
 932          Swap (L => J, R => I);
 933
 934          I := I.Next;
 935          exit when I = J;
 936
 937          J := J.Prev;
 938          exit when I = J;
 939       end loop;
 940
 941       pragma Assert (Container.First.Prev = null);
 942       pragma Assert (Container.Last.Next = null);
 943    end Reverse_List;
 944
 945    ------------
 946    -- Splice --
 947    ------------
 948
 949    procedure Splice
 950      (Target : in out List;
 951       Before : Cursor;
 952       Source : in out List)
 953    is
 954    begin
 955       if Before.Container /= null
 956         and then Before.Container /= List_Access'(Target'Unchecked_Access)
 957       then
 958          raise Program_Error;
 959       end if;
 960
 961       if Target'Address = Source'Address
 962         or else Source.Length = 0
 963       then
 964          return;
 965       end if;
 966
 967       if Target.Length = 0 then
 968          pragma Assert (Before = No_Element);
 969
 970          Target.First := Source.First;
 971          Target.Last := Source.Last;
 972
 973       elsif Before.Node = null then
 974          pragma Assert (Target.Last.Next = null);
 975
 976          Target.Last.Next := Source.First;
 977          Source.First.Prev := Target.Last;
 978
 979          Target.Last := Source.Last;
 980
 981       elsif Before.Node = Target.First then
 982          pragma Assert (Target.First.Prev = null);
 983
 984          Source.Last.Next := Target.First;
 985          Target.First.Prev := Source.Last;
 986
 987          Target.First := Source.First;
 988
 989       else
 990          Before.Node.Prev.Next := Source.First;
 991          Source.First.Prev := Before.Node.Prev;
 992
 993          Before.Node.Prev := Source.Last;
 994          Source.Last.Next := Before.Node;
 995       end if;
 996
 997       Source.First := null;
 998       Source.Last := null;
 999
1000       Target.Length := Target.Length + Source.Length;
1001       Source.Length := 0;
1002    end Splice;
1003
1004    procedure Splice
1005      (Target   : in out List;
1006       Before   : Cursor;
1007       Position : Cursor)
1008    is
1009       X : Node_Access := Position.Node;
1010
1011    begin
1012       if Before.Container /= null
1013         and then Before.Container /= List_Access'(Target'Unchecked_Access)
1014       then
1015          raise Program_Error;
1016       end if;
1017
1018       if Position.Container /= null
1019         and then Position.Container /= List_Access'(Target'Unchecked_Access)
1020       then
1021          raise Program_Error;
1022       end if;
1023
1024       if X = null
1025         or else X = Before.Node
1026         or else X.Next = Before.Node
1027       then
1028          return;
1029       end if;
1030
1031       pragma Assert (Target.Length > 0);
1032
1033       if Before.Node = null then
1034          pragma Assert (X /= Target.Last);
1035
1036          if X = Target.First then
1037             Target.First := X.Next;
1038             Target.First.Prev := null;
1039          else
1040             X.Prev.Next := X.Next;
1041             X.Next.Prev := X.Prev;
1042          end if;
1043
1044          Target.Last.Next := X;
1045          X.Prev := Target.Last;
1046
1047          Target.Last := X;
1048          Target.Last.Next := null;
1049
1050          return;
1051       end if;
1052
1053       if Before.Node = Target.First then
1054          pragma Assert (X /= Target.First);
1055
1056          if X = Target.Last then
1057             Target.Last := X.Prev;
1058             Target.Last.Next := null;
1059          else
1060             X.Prev.Next := X.Next;
1061             X.Next.Prev := X.Prev;
1062          end if;
1063
1064          Target.First.Prev := X;
1065          X.Next := Target.First;
1066
1067          Target.First := X;
1068          Target.First.Prev := null;
1069
1070          return;
1071       end if;
1072
1073       if X = Target.First then
1074          Target.First := X.Next;
1075          Target.First.Prev := null;
1076
1077       elsif X = Target.Last then
1078          Target.Last := X.Prev;
1079          Target.Last.Next := null;
1080
1081       else
1082          X.Prev.Next := X.Next;
1083          X.Next.Prev := X.Prev;
1084       end if;
1085
1086       Before.Node.Prev.Next := X;
1087       X.Prev := Before.Node.Prev;
1088
1089       Before.Node.Prev := X;
1090       X.Next := Before.Node;
1091    end Splice;
1092
1093    procedure Splice
1094      (Target   : in out List;
1095       Before   : Cursor;
1096       Source   : in out List;
1097       Position : Cursor)
1098    is
1099       X : Node_Access := Position.Node;
1100
1101    begin
1102       if Target'Address = Source'Address then
1103          Splice (Target, Before, Position);
1104          return;
1105       end if;
1106
1107       if Before.Container /= null
1108         and then Before.Container /= List_Access'(Target'Unchecked_Access)
1109       then
1110          raise Program_Error;
1111       end if;
1112
1113       if Position.Container /= null
1114         and then Position.Container /= List_Access'(Source'Unchecked_Access)
1115       then
1116          raise Program_Error;
1117       end if;
1118
1119       if X = null then
1120          return;
1121       end if;
1122
1123       pragma Assert (Source.Length > 0);
1124       pragma Assert (Source.First.Prev = null);
1125       pragma Assert (Source.Last.Next = null);
1126
1127       if X = Source.First then
1128          Source.First := X.Next;
1129          Source.First.Prev := null;
1130
1131          if X = Source.Last then
1132             pragma Assert (Source.First = null);
1133             pragma Assert (Source.Length = 1);
1134             Source.Last := null;
1135          end if;
1136
1137       elsif X = Source.Last then
1138          Source.Last := X.Prev;
1139          Source.Last.Next := null;
1140
1141       else
1142          X.Prev.Next := X.Next;
1143          X.Next.Prev := X.Prev;
1144       end if;
1145
1146       if Target.Length = 0 then
1147          pragma Assert (Before = No_Element);
1148          pragma Assert (Target.First = null);
1149          pragma Assert (Target.Last = null);
1150
1151          Target.First := X;
1152          Target.Last := X;
1153
1154       elsif Before.Node = null then
1155          Target.Last.Next := X;
1156          X.Next := Target.Last;
1157
1158          Target.Last := X;
1159          Target.Last.Next := null;
1160
1161       elsif Before.Node = Target.First then
1162          Target.First.Prev := X;
1163          X.Next := Target.First;
1164
1165          Target.First := X;
1166          Target.First.Prev := null;
1167
1168       else
1169          Before.Node.Prev.Next := X;
1170          X.Prev := Before.Node.Prev;
1171
1172          Before.Node.Prev := X;
1173          X.Next := Before.Node;
1174       end if;
1175
1176       Target.Length := Target.Length + 1;
1177       Source.Length := Source.Length - 1;
1178    end Splice;
1179
1180    ----------
1181    -- Swap --
1182    ----------
1183
1184    --  Is this defined when I and J designate elements in different containers,
1185    --  or should it raise an exception (Program_Error)???
1186
1187    procedure Swap (I, J : in Cursor) is
1188       EI : constant Element_Type := I.Node.Element;
1189    begin
1190       I.Node.Element := J.Node.Element;
1191       J.Node.Element := EI;
1192    end Swap;
1193
1194    ----------------
1195    -- Swap_Links --
1196    ----------------
1197
1198    procedure Swap_Links
1199      (Container : in out List;
1200       I, J      : Cursor)
1201    is
1202    begin
1203       if I = No_Element
1204         or else J = No_Element
1205       then
1206          raise Constraint_Error;
1207       end if;
1208
1209       if I.Container /= List_Access'(Container'Unchecked_Access) then
1210          raise Program_Error;
1211       end if;
1212
1213       if J.Container /= I.Container then
1214          raise Program_Error;
1215       end if;
1216
1217       pragma Assert (Container.Length >= 1);
1218
1219       if I.Node = J.Node then
1220          return;
1221       end if;
1222
1223       pragma Assert (Container.Length >= 2);
1224
1225       declare
1226          I_Next : constant Cursor := Next (I);
1227
1228       begin
1229          if I_Next = J then
1230             Splice (Container, Before => I, Position => J);
1231
1232          else
1233             declare
1234                J_Next : constant Cursor := Next (J);
1235
1236             begin
1237                if J_Next = I then
1238                   Splice (Container, Before => J, Position => I);
1239
1240                else
1241                   pragma Assert (Container.Length >= 3);
1242
1243                   Splice (Container, Before => I_Next, Position => J);
1244                   Splice (Container, Before => J_Next, Position => I);
1245                end if;
1246             end;
1247          end if;
1248       end;
1249    end Swap_Links;
1250
1251    --------------------
1252    -- Update_Element --
1253    --------------------
1254
1255    procedure Update_Element
1256      (Position : Cursor;
1257       Process  : not null access procedure (Element : in out Element_Type)) is
1258    begin
1259       Process (Position.Node.Element);
1260    end Update_Element;
1261
1262    -----------
1263    -- Write --
1264    -----------
1265
1266    procedure Write
1267      (Stream : access Root_Stream_Type'Class;
1268       Item   : List)
1269    is
1270       Node : Node_Access := Item.First;
1271
1272    begin
1273       Count_Type'Base'Write (Stream, Item.Length);
1274
1275       while Node /= null loop
1276          Element_Type'Write (Stream, Node.Element);
1277          Node := Node.Next;
1278       end loop;
1279    end Write;
1280
1281 end Ada.Containers.Doubly_Linked_Lists;
1282