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