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