gcc/ada/a-cdlili.adb

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