gcc/ada/a-cdlili.adb

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