gcc/ada/a-cidlli.adb

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