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-2006, 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 (Pivot : Node_Access; Back : Node_Access);
 503
 504          procedure Sort (Front, Back : Node_Access);
 505
 506          ---------------
 507          -- Partition --
 508          ---------------
 509
 510          procedure Partition (Pivot : Node_Access; Back : Node_Access) is
 511             Node : Node_Access := Pivot.Next;
 512
 513          begin
 514             while Node /= Back loop
 515                if Node.Element < Pivot.Element then
 516                   declare
 517                      Prev : constant Node_Access := Node.Prev;
 518                      Next : constant Node_Access := Node.Next;
 519
 520                   begin
 521                      Prev.Next := Next;
 522
 523                      if Next = null then
 524                         Container.Last := Prev;
 525                      else
 526                         Next.Prev := Prev;
 527                      end if;
 528
 529                      Node.Next := Pivot;
 530                      Node.Prev := Pivot.Prev;
 531
 532                      Pivot.Prev := Node;
 533
 534                      if Node.Prev = null then
 535                         Container.First := Node;
 536                      else
 537                         Node.Prev.Next := Node;
 538                      end if;
 539
 540                      Node := Next;
 541                   end;
 542
 543                else
 544                   Node := Node.Next;
 545                end if;
 546             end loop;
 547          end Partition;
 548
 549          ----------
 550          -- Sort --
 551          ----------
 552
 553          procedure Sort (Front, Back : Node_Access) is
 554             Pivot : Node_Access;
 555
 556          begin
 557             if Front = null then
 558                Pivot := Container.First;
 559             else
 560                Pivot := Front.Next;
 561             end if;
 562
 563             if Pivot /= Back then
 564                Partition (Pivot, Back);
 565                Sort (Front, Pivot);
 566                Sort (Pivot, Back);
 567             end if;
 568          end Sort;
 569
 570       --  Start of processing for Sort
 571
 572       begin
 573          if Container.Length <= 1 then
 574             return;
 575          end if;
 576
 577          pragma Assert (Container.First.Prev = null);
 578          pragma Assert (Container.Last.Next = null);
 579
 580          if Container.Busy > 0 then
 581             raise Program_Error;
 582          end if;
 583
 584          Sort (Front => null, Back => null);
 585
 586          pragma Assert (Container.First.Prev = null);
 587          pragma Assert (Container.Last.Next = null);
 588       end Sort;
 589
 590    end Generic_Sorting;
 591
 592    -----------------
 593    -- Has_Element --
 594    -----------------
 595
 596    function Has_Element (Position : Cursor) return Boolean is
 597    begin
 598       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 599       return Position.Node /= null;
 600    end Has_Element;
 601
 602    ------------
 603    -- Insert --
 604    ------------
 605
 606    procedure Insert
 607      (Container : in out List;
 608       Before    : Cursor;
 609       New_Item  : Element_Type;
 610       Position  : out Cursor;
 611       Count     : Count_Type := 1)
 612    is
 613       New_Node : Node_Access;
 614
 615    begin
 616       if Before.Container /= null then
 617          if Before.Container /= Container'Unrestricted_Access then
 618             raise Program_Error;
 619          end if;
 620
 621          pragma Assert (Vet (Before), "bad cursor in Insert");
 622       end if;
 623
 624       if Count = 0 then
 625          Position := Before;
 626          return;
 627       end if;
 628
 629       if Container.Length > Count_Type'Last - Count then
 630          raise Constraint_Error;
 631       end if;
 632
 633       if Container.Busy > 0 then
 634          raise Program_Error;
 635       end if;
 636
 637       New_Node := new Node_Type'(New_Item, null, null);
 638       Insert_Internal (Container, Before.Node, New_Node);
 639
 640       Position := Cursor'(Container'Unchecked_Access, New_Node);
 641
 642       for J in Count_Type'(2) .. Count loop
 643          New_Node := new Node_Type'(New_Item, null, null);
 644          Insert_Internal (Container, Before.Node, New_Node);
 645       end loop;
 646    end Insert;
 647
 648    procedure Insert
 649      (Container : in out List;
 650       Before    : Cursor;
 651       New_Item  : Element_Type;
 652       Count     : Count_Type := 1)
 653    is
 654       Position : Cursor;
 655    begin
 656       Insert (Container, Before, New_Item, Position, Count);
 657    end Insert;
 658
 659    procedure Insert
 660      (Container : in out List;
 661       Before    : Cursor;
 662       Position  : out Cursor;
 663       Count     : Count_Type := 1)
 664    is
 665       New_Node : Node_Access;
 666
 667    begin
 668       if Before.Container /= null then
 669          if Before.Container /= Container'Unrestricted_Access 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       New_Node := new Node_Type;
 690       Insert_Internal (Container, Before.Node, New_Node);
 691
 692       Position := Cursor'(Container'Unchecked_Access, New_Node);
 693
 694       for J in Count_Type'(2) .. Count loop
 695          New_Node := new Node_Type;
 696          Insert_Internal (Container, Before.Node, New_Node);
 697       end loop;
 698    end Insert;
 699
 700    ---------------------
 701    -- Insert_Internal --
 702    ---------------------
 703
 704    procedure Insert_Internal
 705      (Container : in out List;
 706       Before    : Node_Access;
 707       New_Node  : Node_Access)
 708    is
 709    begin
 710       if Container.Length = 0 then
 711          pragma Assert (Before = null);
 712          pragma Assert (Container.First = null);
 713          pragma Assert (Container.Last = null);
 714
 715          Container.First := New_Node;
 716          Container.Last := New_Node;
 717
 718       elsif Before = null then
 719          pragma Assert (Container.Last.Next = null);
 720
 721          Container.Last.Next := New_Node;
 722          New_Node.Prev := Container.Last;
 723
 724          Container.Last := New_Node;
 725
 726       elsif Before = Container.First then
 727          pragma Assert (Container.First.Prev = null);
 728
 729          Container.First.Prev := New_Node;
 730          New_Node.Next := Container.First;
 731
 732          Container.First := New_Node;
 733
 734       else
 735          pragma Assert (Container.First.Prev = null);
 736          pragma Assert (Container.Last.Next = null);
 737
 738          New_Node.Next := Before;
 739          New_Node.Prev := Before.Prev;
 740
 741          Before.Prev.Next := New_Node;
 742          Before.Prev := New_Node;
 743       end if;
 744
 745       Container.Length := Container.Length + 1;
 746    end Insert_Internal;
 747
 748    --------------
 749    -- Is_Empty --
 750    --------------
 751
 752    function Is_Empty (Container : List) return Boolean is
 753    begin
 754       return Container.Length = 0;
 755    end Is_Empty;
 756
 757    -------------
 758    -- Iterate --
 759    -------------
 760
 761    procedure Iterate
 762      (Container : List;
 763       Process   : not null access procedure (Position : Cursor))
 764    is
 765       C : List renames Container'Unrestricted_Access.all;
 766       B : Natural renames C.Busy;
 767
 768       Node : Node_Access := Container.First;
 769
 770    begin
 771       B := B + 1;
 772
 773       begin
 774          while Node /= null loop
 775             Process (Cursor'(Container'Unchecked_Access, Node));
 776             Node := Node.Next;
 777          end loop;
 778       exception
 779          when others =>
 780             B := B - 1;
 781             raise;
 782       end;
 783
 784       B := B - 1;
 785    end Iterate;
 786
 787    ----------
 788    -- Last --
 789    ----------
 790
 791    function Last (Container : List) return Cursor is
 792    begin
 793       if Container.Last = null then
 794          return No_Element;
 795       end if;
 796
 797       return Cursor'(Container'Unchecked_Access, Container.Last);
 798    end Last;
 799
 800    ------------------
 801    -- Last_Element --
 802    ------------------
 803
 804    function Last_Element (Container : List) return Element_Type is
 805    begin
 806       if Container.Last = null then
 807          raise Constraint_Error;
 808       end if;
 809
 810       return Container.Last.Element;
 811    end Last_Element;
 812
 813    ------------
 814    -- Length --
 815    ------------
 816
 817    function Length (Container : List) return Count_Type is
 818    begin
 819       return Container.Length;
 820    end Length;
 821
 822    ----------
 823    -- Move --
 824    ----------
 825
 826    procedure Move
 827      (Target : in out List;
 828       Source : in out List)
 829    is
 830    begin
 831       if Target'Address = Source'Address then
 832          return;
 833       end if;
 834
 835       if Source.Busy > 0 then
 836          raise Program_Error;
 837       end if;
 838
 839       Clear (Target);
 840
 841       Target.First := Source.First;
 842       Source.First := null;
 843
 844       Target.Last := Source.Last;
 845       Source.Last := null;
 846
 847       Target.Length := Source.Length;
 848       Source.Length := 0;
 849    end Move;
 850
 851    ----------
 852    -- Next --
 853    ----------
 854
 855    procedure Next (Position : in out Cursor) is
 856    begin
 857       pragma Assert (Vet (Position), "bad cursor in procedure Next");
 858
 859       if Position.Node = null then
 860          return;
 861       end if;
 862
 863       Position.Node := Position.Node.Next;
 864
 865       if Position.Node = null then
 866          Position.Container := null;
 867       end if;
 868    end Next;
 869
 870    function Next (Position : Cursor) return Cursor is
 871    begin
 872       pragma Assert (Vet (Position), "bad cursor in function Next");
 873
 874       if Position.Node = null then
 875          return No_Element;
 876       end if;
 877
 878       declare
 879          Next_Node : constant Node_Access := Position.Node.Next;
 880       begin
 881          if Next_Node = null then
 882             return No_Element;
 883          end if;
 884
 885          return Cursor'(Position.Container, Next_Node);
 886       end;
 887    end Next;
 888
 889    -------------
 890    -- Prepend --
 891    -------------
 892
 893    procedure Prepend
 894      (Container : in out List;
 895       New_Item  : Element_Type;
 896       Count     : Count_Type := 1)
 897    is
 898    begin
 899       Insert (Container, First (Container), New_Item, Count);
 900    end Prepend;
 901
 902    --------------
 903    -- Previous --
 904    --------------
 905
 906    procedure Previous (Position : in out Cursor) is
 907    begin
 908       pragma Assert (Vet (Position), "bad cursor in procedure Previous");
 909
 910       if Position.Node = null then
 911          return;
 912       end if;
 913
 914       Position.Node := Position.Node.Prev;
 915
 916       if Position.Node = null then
 917          Position.Container := null;
 918       end if;
 919    end Previous;
 920
 921    function Previous (Position : Cursor) return Cursor is
 922    begin
 923       pragma Assert (Vet (Position), "bad cursor in function Previous");
 924
 925       if Position.Node = null then
 926          return No_Element;
 927       end if;
 928
 929       declare
 930          Prev_Node : constant Node_Access := Position.Node.Prev;
 931       begin
 932          if Prev_Node = null then
 933             return No_Element;
 934          end if;
 935
 936          return Cursor'(Position.Container, Prev_Node);
 937       end;
 938    end Previous;
 939
 940    -------------------
 941    -- Query_Element --
 942    -------------------
 943
 944    procedure Query_Element
 945      (Position : Cursor;
 946       Process  : not null access procedure (Element : Element_Type))
 947    is
 948    begin
 949       if Position.Node = null then
 950          raise Constraint_Error;
 951       end if;
 952
 953       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 954
 955       declare
 956          C : List renames Position.Container.all'Unrestricted_Access.all;
 957          B : Natural renames C.Busy;
 958          L : Natural renames C.Lock;
 959
 960       begin
 961          B := B + 1;
 962          L := L + 1;
 963
 964          begin
 965             Process (Position.Node.Element);
 966          exception
 967             when others =>
 968                L := L - 1;
 969                B := B - 1;
 970                raise;
 971          end;
 972
 973          L := L - 1;
 974          B := B - 1;
 975       end;
 976    end Query_Element;
 977
 978    ----------
 979    -- Read --
 980    ----------
 981
 982    procedure Read
 983      (Stream : access Root_Stream_Type'Class;
 984       Item   : out List)
 985    is
 986       N : Count_Type'Base;
 987       X : Node_Access;
 988
 989    begin
 990       Clear (Item);
 991       Count_Type'Base'Read (Stream, N);
 992
 993       if N = 0 then
 994          return;
 995       end if;
 996
 997       X := new Node_Type;
 998
 999       begin
1000          Element_Type'Read (Stream, X.Element);
1001       exception
1002          when others =>
1003             Free (X);
1004             raise;
1005       end;
1006
1007       Item.First := X;
1008       Item.Last := X;
1009
1010       loop
1011          Item.Length := Item.Length + 1;
1012          exit when Item.Length = N;
1013
1014          X := new Node_Type;
1015
1016          begin
1017             Element_Type'Read (Stream, X.Element);
1018          exception
1019             when others =>
1020                Free (X);
1021                raise;
1022          end;
1023
1024          X.Prev := Item.Last;
1025          Item.Last.Next := X;
1026          Item.Last := X;
1027       end loop;
1028    end Read;
1029
1030    procedure Read
1031      (Stream : access Root_Stream_Type'Class;
1032       Item   : out Cursor)
1033    is
1034    begin
1035       raise Program_Error;
1036    end Read;
1037
1038    ---------------------
1039    -- Replace_Element --
1040    ---------------------
1041
1042    procedure Replace_Element
1043      (Container : in out List;
1044       Position  : Cursor;
1045       New_Item  : Element_Type)
1046    is
1047    begin
1048       if Position.Container = null then
1049          raise Constraint_Error;
1050       end if;
1051
1052       if Position.Container /= Container'Unchecked_Access then
1053          raise Program_Error;
1054       end if;
1055
1056       if Container.Lock > 0 then
1057          raise Program_Error;
1058       end if;
1059
1060       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1061
1062       Position.Node.Element := New_Item;
1063    end Replace_Element;
1064
1065    ----------------------
1066    -- Reverse_Elements --
1067    ----------------------
1068
1069    procedure Reverse_Elements (Container : in out List) is
1070       I : Node_Access := Container.First;
1071       J : Node_Access := Container.Last;
1072
1073       procedure Swap (L, R : Node_Access);
1074
1075       ----------
1076       -- Swap --
1077       ----------
1078
1079       procedure Swap (L, R : Node_Access) is
1080          LN : constant Node_Access := L.Next;
1081          LP : constant Node_Access := L.Prev;
1082
1083          RN : constant Node_Access := R.Next;
1084          RP : constant Node_Access := R.Prev;
1085
1086       begin
1087          if LP /= null then
1088             LP.Next := R;
1089          end if;
1090
1091          if RN /= null then
1092             RN.Prev := L;
1093          end if;
1094
1095          L.Next := RN;
1096          R.Prev := LP;
1097
1098          if LN = R then
1099             pragma Assert (RP = L);
1100
1101             L.Prev := R;
1102             R.Next := L;
1103
1104          else
1105             L.Prev := RP;
1106             RP.Next := L;
1107
1108             R.Next := LN;
1109             LN.Prev := R;
1110          end if;
1111       end Swap;
1112
1113    --  Start of processing for Reverse_Elements
1114
1115    begin
1116       if Container.Length <= 1 then
1117          return;
1118       end if;
1119
1120       pragma Assert (Container.First.Prev = null);
1121       pragma Assert (Container.Last.Next = null);
1122
1123       if Container.Busy > 0 then
1124          raise Program_Error;
1125       end if;
1126
1127       Container.First := J;
1128       Container.Last := I;
1129       loop
1130          Swap (L => I, R => J);
1131
1132          J := J.Next;
1133          exit when I = J;
1134
1135          I := I.Prev;
1136          exit when I = J;
1137
1138          Swap (L => J, R => I);
1139
1140          I := I.Next;
1141          exit when I = J;
1142
1143          J := J.Prev;
1144          exit when I = J;
1145       end loop;
1146
1147       pragma Assert (Container.First.Prev = null);
1148       pragma Assert (Container.Last.Next = null);
1149    end Reverse_Elements;
1150
1151    ------------------
1152    -- Reverse_Find --
1153    ------------------
1154
1155    function Reverse_Find
1156      (Container : List;
1157       Item      : Element_Type;
1158       Position  : Cursor := No_Element) return Cursor
1159    is
1160       Node : Node_Access := Position.Node;
1161
1162    begin
1163       if Node = null then
1164          Node := Container.Last;
1165
1166       else
1167          if Position.Container /= Container'Unrestricted_Access then
1168             raise Program_Error;
1169          end if;
1170
1171          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1172       end if;
1173
1174       while Node /= null loop
1175          if Node.Element = Item then
1176             return Cursor'(Container'Unchecked_Access, Node);
1177          end if;
1178
1179          Node := Node.Prev;
1180       end loop;
1181
1182       return No_Element;
1183    end Reverse_Find;
1184
1185    ---------------------
1186    -- Reverse_Iterate --
1187    ---------------------
1188
1189    procedure Reverse_Iterate
1190      (Container : List;
1191       Process   : not null access procedure (Position : Cursor))
1192    is
1193       C : List renames Container'Unrestricted_Access.all;
1194       B : Natural renames C.Busy;
1195
1196       Node : Node_Access := Container.Last;
1197
1198    begin
1199       B := B + 1;
1200
1201       begin
1202          while Node /= null loop
1203             Process (Cursor'(Container'Unchecked_Access, Node));
1204             Node := Node.Prev;
1205          end loop;
1206
1207       exception
1208          when others =>
1209             B := B - 1;
1210             raise;
1211       end;
1212
1213       B := B - 1;
1214    end Reverse_Iterate;
1215
1216    ------------
1217    -- Splice --
1218    ------------
1219
1220    procedure Splice
1221      (Target : in out List;
1222       Before : Cursor;
1223       Source : in out List)
1224    is
1225    begin
1226       if Before.Container /= null then
1227          if Before.Container /= Target'Unrestricted_Access then
1228             raise Program_Error;
1229          end if;
1230
1231          pragma Assert (Vet (Before), "bad cursor in Splice");
1232       end if;
1233
1234       if Target'Address = Source'Address
1235         or else Source.Length = 0
1236       then
1237          return;
1238       end if;
1239
1240       pragma Assert (Source.First.Prev = null);
1241       pragma Assert (Source.Last.Next = null);
1242
1243       if Target.Length > Count_Type'Last - Source.Length then
1244          raise Constraint_Error;
1245       end if;
1246
1247       if Target.Busy > 0
1248         or else Source.Busy > 0
1249       then
1250          raise Program_Error;
1251       end if;
1252
1253       if Target.Length = 0 then
1254          pragma Assert (Target.First = null);
1255          pragma Assert (Target.Last = null);
1256          pragma Assert (Before = No_Element);
1257
1258          Target.First := Source.First;
1259          Target.Last := Source.Last;
1260
1261       elsif Before.Node = null then
1262          pragma Assert (Target.Last.Next = null);
1263
1264          Target.Last.Next := Source.First;
1265          Source.First.Prev := Target.Last;
1266
1267          Target.Last := Source.Last;
1268
1269       elsif Before.Node = Target.First then
1270          pragma Assert (Target.First.Prev = null);
1271
1272          Source.Last.Next := Target.First;
1273          Target.First.Prev := Source.Last;
1274
1275          Target.First := Source.First;
1276
1277       else
1278          pragma Assert (Target.Length >= 2);
1279
1280          Before.Node.Prev.Next := Source.First;
1281          Source.First.Prev := Before.Node.Prev;
1282
1283          Before.Node.Prev := Source.Last;
1284          Source.Last.Next := Before.Node;
1285       end if;
1286
1287       Source.First := null;
1288       Source.Last := null;
1289
1290       Target.Length := Target.Length + Source.Length;
1291       Source.Length := 0;
1292    end Splice;
1293
1294    procedure Splice
1295      (Container : in out List;
1296       Before    : Cursor;
1297       Position  : in out Cursor)
1298    is
1299    begin
1300       if Before.Container /= null then
1301          if Before.Container /= Container'Unchecked_Access then
1302             raise Program_Error;
1303          end if;
1304
1305          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1306       end if;
1307
1308       if Position.Node = null then
1309          raise Constraint_Error;
1310       end if;
1311
1312       if Position.Container /= Container'Unrestricted_Access then
1313          raise Program_Error;
1314       end if;
1315
1316       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1317
1318       if Position.Node = Before.Node
1319         or else Position.Node.Next = Before.Node
1320       then
1321          return;
1322       end if;
1323
1324       pragma Assert (Container.Length >= 2);
1325
1326       if Container.Busy > 0 then
1327          raise Program_Error;
1328       end if;
1329
1330       if Before.Node = null then
1331          pragma Assert (Position.Node /= Container.Last);
1332
1333          if Position.Node = Container.First then
1334             Container.First := Position.Node.Next;
1335             Container.First.Prev := null;
1336          else
1337             Position.Node.Prev.Next := Position.Node.Next;
1338             Position.Node.Next.Prev := Position.Node.Prev;
1339          end if;
1340
1341          Container.Last.Next := Position.Node;
1342          Position.Node.Prev := Container.Last;
1343
1344          Container.Last := Position.Node;
1345          Container.Last.Next := null;
1346
1347          return;
1348       end if;
1349
1350       if Before.Node = Container.First then
1351          pragma Assert (Position.Node /= Container.First);
1352
1353          if Position.Node = Container.Last then
1354             Container.Last := Position.Node.Prev;
1355             Container.Last.Next := null;
1356          else
1357             Position.Node.Prev.Next := Position.Node.Next;
1358             Position.Node.Next.Prev := Position.Node.Prev;
1359          end if;
1360
1361          Container.First.Prev := Position.Node;
1362          Position.Node.Next := Container.First;
1363
1364          Container.First := Position.Node;
1365          Container.First.Prev := null;
1366
1367          return;
1368       end if;
1369
1370       if Position.Node = Container.First then
1371          Container.First := Position.Node.Next;
1372          Container.First.Prev := null;
1373
1374       elsif Position.Node = Container.Last then
1375          Container.Last := Position.Node.Prev;
1376          Container.Last.Next := null;
1377
1378       else
1379          Position.Node.Prev.Next := Position.Node.Next;
1380          Position.Node.Next.Prev := Position.Node.Prev;
1381       end if;
1382
1383       Before.Node.Prev.Next := Position.Node;
1384       Position.Node.Prev := Before.Node.Prev;
1385
1386       Before.Node.Prev := Position.Node;
1387       Position.Node.Next := Before.Node;
1388
1389       pragma Assert (Container.First.Prev = null);
1390       pragma Assert (Container.Last.Next = null);
1391    end Splice;
1392
1393    procedure Splice
1394      (Target   : in out List;
1395       Before   : Cursor;
1396       Source   : in out List;
1397       Position : in out Cursor)
1398    is
1399    begin
1400       if Target'Address = Source'Address then
1401          Splice (Target, Before, Position);
1402          return;
1403       end if;
1404
1405       if Before.Container /= null then
1406          if Before.Container /= Target'Unrestricted_Access then
1407             raise Program_Error;
1408          end if;
1409
1410          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1411       end if;
1412
1413       if Position.Node = null then
1414          raise Constraint_Error;
1415       end if;
1416
1417       if Position.Container /= Source'Unrestricted_Access then
1418          raise Program_Error;
1419       end if;
1420
1421       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1422
1423       if Target.Length = Count_Type'Last then
1424          raise Constraint_Error;
1425       end if;
1426
1427       if Target.Busy > 0
1428         or else Source.Busy > 0
1429       then
1430          raise Program_Error;
1431       end if;
1432
1433       if Position.Node = Source.First then
1434          Source.First := Position.Node.Next;
1435
1436          if Position.Node = Source.Last then
1437             pragma Assert (Source.First = null);
1438             pragma Assert (Source.Length = 1);
1439             Source.Last := null;
1440
1441          else
1442             Source.First.Prev := null;
1443          end if;
1444
1445       elsif Position.Node = Source.Last then
1446          pragma Assert (Source.Length >= 2);
1447          Source.Last := Position.Node.Prev;
1448          Source.Last.Next := null;
1449
1450       else
1451          pragma Assert (Source.Length >= 3);
1452          Position.Node.Prev.Next := Position.Node.Next;
1453          Position.Node.Next.Prev := Position.Node.Prev;
1454       end if;
1455
1456       if Target.Length = 0 then
1457          pragma Assert (Target.First = null);
1458          pragma Assert (Target.Last = null);
1459          pragma Assert (Before = No_Element);
1460
1461          Target.First := Position.Node;
1462          Target.Last := Position.Node;
1463
1464          Target.First.Prev := null;
1465          Target.Last.Next := null;
1466
1467       elsif Before.Node = null then
1468          pragma Assert (Target.Last.Next = null);
1469          Target.Last.Next := Position.Node;
1470          Position.Node.Prev := Target.Last;
1471
1472          Target.Last := Position.Node;
1473          Target.Last.Next := null;
1474
1475       elsif Before.Node = Target.First then
1476          pragma Assert (Target.First.Prev = null);
1477          Target.First.Prev := Position.Node;
1478          Position.Node.Next := Target.First;
1479
1480          Target.First := Position.Node;
1481          Target.First.Prev := null;
1482
1483       else
1484          pragma Assert (Target.Length >= 2);
1485          Before.Node.Prev.Next := Position.Node;
1486          Position.Node.Prev := Before.Node.Prev;
1487
1488          Before.Node.Prev := Position.Node;
1489          Position.Node.Next := Before.Node;
1490       end if;
1491
1492       Target.Length := Target.Length + 1;
1493       Source.Length := Source.Length - 1;
1494
1495       Position.Container := Target'Unchecked_Access;
1496    end Splice;
1497
1498    ----------
1499    -- Swap --
1500    ----------
1501
1502    procedure Swap
1503      (Container : in out List;
1504       I, J      : Cursor)
1505    is
1506    begin
1507       if I.Node = null
1508         or else J.Node = null
1509       then
1510          raise Constraint_Error;
1511       end if;
1512
1513       if I.Container /= Container'Unchecked_Access
1514         or else J.Container /= Container'Unchecked_Access
1515       then
1516          raise Program_Error;
1517       end if;
1518
1519       if I.Node = J.Node then
1520          return;
1521       end if;
1522
1523       if Container.Lock > 0 then
1524          raise Program_Error;
1525       end if;
1526
1527       pragma Assert (Vet (I), "bad I cursor in Swap");
1528       pragma Assert (Vet (J), "bad J cursor in Swap");
1529
1530       declare
1531          EI : Element_Type renames I.Node.Element;
1532          EJ : Element_Type renames J.Node.Element;
1533
1534          EI_Copy : constant Element_Type := EI;
1535
1536       begin
1537          EI := EJ;
1538          EJ := EI_Copy;
1539       end;
1540    end Swap;
1541
1542    ----------------
1543    -- Swap_Links --
1544    ----------------
1545
1546    procedure Swap_Links
1547      (Container : in out List;
1548       I, J      : Cursor)
1549    is
1550    begin
1551       if I.Node = null
1552         or else J.Node = null
1553       then
1554          raise Constraint_Error;
1555       end if;
1556
1557       if I.Container /= Container'Unrestricted_Access
1558         or else I.Container /= J.Container
1559       then
1560          raise Program_Error;
1561       end if;
1562
1563       if I.Node = J.Node then
1564          return;
1565       end if;
1566
1567       if Container.Busy > 0 then
1568          raise Program_Error;
1569       end if;
1570
1571       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1572       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1573
1574       declare
1575          I_Next : constant Cursor := Next (I);
1576          J_Copy : Cursor := J;
1577
1578       begin
1579          if I_Next = J then
1580             Splice (Container, Before => I, Position => J_Copy);
1581
1582          else
1583             declare
1584                J_Next : constant Cursor := Next (J);
1585                I_Copy : Cursor := I;
1586
1587             begin
1588                if J_Next = I then
1589                   Splice (Container, Before => J, Position => I_Copy);
1590
1591                else
1592                   pragma Assert (Container.Length >= 3);
1593
1594                   Splice (Container, Before => I_Next, Position => J_Copy);
1595                   Splice (Container, Before => J_Next, Position => I_Copy);
1596                end if;
1597             end;
1598          end if;
1599       end;
1600    end Swap_Links;
1601
1602    --------------------
1603    -- Update_Element --
1604    --------------------
1605
1606    procedure Update_Element
1607      (Container : in out List;
1608       Position  : Cursor;
1609       Process   : not null access procedure (Element : in out Element_Type))
1610    is
1611    begin
1612       if Position.Node = null then
1613          raise Constraint_Error;
1614       end if;
1615
1616       if Position.Container /= Container'Unchecked_Access then
1617          raise Program_Error;
1618       end if;
1619
1620       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1621
1622       declare
1623          B : Natural renames Container.Busy;
1624          L : Natural renames Container.Lock;
1625
1626       begin
1627          B := B + 1;
1628          L := L + 1;
1629
1630          begin
1631             Process (Position.Node.Element);
1632          exception
1633             when others =>
1634                L := L - 1;
1635                B := B - 1;
1636                raise;
1637          end;
1638
1639          L := L - 1;
1640          B := B - 1;
1641       end;
1642    end Update_Element;
1643
1644    ---------
1645    -- Vet --
1646    ---------
1647
1648    function Vet (Position : Cursor) return Boolean is
1649    begin
1650       if Position.Node = null then
1651          return Position.Container = null;
1652       end if;
1653
1654       if Position.Container = null then
1655          return False;
1656       end if;
1657
1658       if Position.Node.Next = Position.Node then
1659          return False;
1660       end if;
1661
1662       if Position.Node.Prev = Position.Node then
1663          return False;
1664       end if;
1665
1666       declare
1667          L : List renames Position.Container.all;
1668       begin
1669          if L.Length = 0 then
1670             return False;
1671          end if;
1672
1673          if L.First = null then
1674             return False;
1675          end if;
1676
1677          if L.Last = null then
1678             return False;
1679          end if;
1680
1681          if L.First.Prev /= null then
1682             return False;
1683          end if;
1684
1685          if L.Last.Next /= null then
1686             return False;
1687          end if;
1688
1689          if Position.Node.Prev = null
1690            and then Position.Node /= L.First
1691          then
1692             return False;
1693          end if;
1694
1695          if Position.Node.Next = null
1696            and then Position.Node /= L.Last
1697          then
1698             return False;
1699          end if;
1700
1701          if L.Length = 1 then
1702             return L.First = L.Last;
1703          end if;
1704
1705          if L.First = L.Last then
1706             return False;
1707          end if;
1708
1709          if L.First.Next = null then
1710             return False;
1711          end if;
1712
1713          if L.Last.Prev = null then
1714             return False;
1715          end if;
1716
1717          if L.First.Next.Prev /= L.First then
1718             return False;
1719          end if;
1720
1721          if L.Last.Prev.Next /= L.Last then
1722             return False;
1723          end if;
1724
1725          if L.Length = 2 then
1726             if L.First.Next /= L.Last then
1727                return False;
1728             end if;
1729
1730             if L.Last.Prev /= L.First then
1731                return False;
1732             end if;
1733
1734             return True;
1735          end if;
1736
1737          if L.First.Next = L.Last then
1738             return False;
1739          end if;
1740
1741          if L.Last.Prev = L.First then
1742             return False;
1743          end if;
1744
1745          if Position.Node = L.First then
1746             return True;
1747          end if;
1748
1749          if Position.Node = L.Last then
1750             return True;
1751          end if;
1752
1753          if Position.Node.Next = null then
1754             return False;
1755          end if;
1756
1757          if Position.Node.Prev = null then
1758             return False;
1759          end if;
1760
1761          if Position.Node.Next.Prev /= Position.Node then
1762             return False;
1763          end if;
1764
1765          if Position.Node.Prev.Next /= Position.Node then
1766             return False;
1767          end if;
1768
1769          if L.Length = 3 then
1770             if L.First.Next /= Position.Node then
1771                return False;
1772             end if;
1773
1774             if L.Last.Prev /= Position.Node then
1775                return False;
1776             end if;
1777          end if;
1778
1779          return True;
1780       end;
1781    end Vet;
1782
1783    -----------
1784    -- Write --
1785    -----------
1786
1787    procedure Write
1788      (Stream : access Root_Stream_Type'Class;
1789       Item   : List)
1790    is
1791       Node : Node_Access := Item.First;
1792
1793    begin
1794       Count_Type'Base'Write (Stream, Item.Length);
1795
1796       while Node /= null loop
1797          Element_Type'Write (Stream, Node.Element);
1798          Node := Node.Next;
1799       end loop;
1800    end Write;
1801
1802    procedure Write
1803      (Stream : access Root_Stream_Type'Class;
1804       Item   : Cursor)
1805    is
1806    begin
1807       raise Program_Error;
1808    end Write;
1809
1810 end Ada.Containers.Doubly_Linked_Lists;