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