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