gcc/ada/a-crdlli.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --              ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with System;  use type System.Address;
  31
  32 package body Ada.Containers.Restricted_Doubly_Linked_Lists is
  33
  34    -----------------------
  35    -- Local Subprograms --
  36    -----------------------
  37
  38    procedure Allocate
  39      (Container : in out List'Class;
  40       New_Item  : Element_Type;
  41       New_Node  : out Count_Type);
  42
  43    procedure Free
  44      (Container : in out List'Class;
  45       X         : Count_Type);
  46
  47    procedure Insert_Internal
  48      (Container : in out List'Class;
  49       Before    : Count_Type;
  50       New_Node  : Count_Type);
  51
  52    function Vet (Position : Cursor) return Boolean;
  53
  54    ---------
  55    -- "=" --
  56    ---------
  57
  58    function "=" (Left, Right : List) return Boolean is
  59       LN : Node_Array renames Left.Nodes;
  60       RN : Node_Array renames Right.Nodes;
  61
  62       LI : Count_Type := Left.First;
  63       RI : Count_Type := Right.First;
  64
  65    begin
  66       if Left'Address = Right'Address then
  67          return True;
  68       end if;
  69
  70       if Left.Length /= Right.Length then
  71          return False;
  72       end if;
  73
  74       for J in 1 .. Left.Length loop
  75          if LN (LI).Element /= RN (RI).Element then
  76             return False;
  77          end if;
  78
  79          LI := LN (LI).Next;
  80          RI := RN (RI).Next;
  81       end loop;
  82
  83       return True;
  84    end "=";
  85
  86    --------------
  87    -- Allocate --
  88    --------------
  89
  90    procedure Allocate
  91      (Container : in out List'Class;
  92       New_Item  : Element_Type;
  93       New_Node  : out Count_Type)
  94    is
  95       N : Node_Array renames Container.Nodes;
  96
  97    begin
  98       if Container.Free >= 0 then
  99          New_Node := Container.Free;
 100          N (New_Node).Element := New_Item;
 101          Container.Free := N (New_Node).Next;
 102
 103       else
 104          New_Node := abs Container.Free;
 105          N (New_Node).Element := New_Item;
 106          Container.Free := Container.Free - 1;
 107       end if;
 108    end Allocate;
 109
 110    ------------
 111    -- Append --
 112    ------------
 113
 114    procedure Append
 115      (Container : in out List;
 116       New_Item  : Element_Type;
 117       Count     : Count_Type := 1)
 118    is
 119    begin
 120       Insert (Container, No_Element, New_Item, Count);
 121    end Append;
 122
 123    ------------
 124    -- Assign --
 125    ------------
 126
 127    procedure Assign (Target : in out List; Source : List) is
 128    begin
 129       if Target'Address = Source'Address then
 130          return;
 131       end if;
 132
 133       if Target.Capacity < Source.Length then
 134          raise Constraint_Error;  -- ???
 135       end if;
 136
 137       Clear (Target);
 138
 139       declare
 140          N : Node_Array renames Source.Nodes;
 141          J : Count_Type := Source.First;
 142
 143       begin
 144          while J /= 0 loop
 145             Append (Target, N (J).Element);
 146             J := N (J).Next;
 147          end loop;
 148       end;
 149    end Assign;
 150
 151    -----------
 152    -- Clear --
 153    -----------
 154
 155    procedure Clear (Container : in out List) is
 156       N : Node_Array renames Container.Nodes;
 157       X : Count_Type;
 158
 159    begin
 160       if Container.Length = 0 then
 161          pragma Assert (Container.First = 0);
 162          pragma Assert (Container.Last = 0);
 163 --       pragma Assert (Container.Busy = 0);
 164 --       pragma Assert (Container.Lock = 0);
 165          return;
 166       end if;
 167
 168       pragma Assert (Container.First >= 1);
 169       pragma Assert (Container.Last >= 1);
 170       pragma Assert (N (Container.First).Prev = 0);
 171       pragma Assert (N (Container.Last).Next = 0);
 172
 173 --    if Container.Busy > 0 then
 174 --      raise Program_Error;
 175 --    end if;
 176
 177       while Container.Length > 1 loop
 178          X := Container.First;
 179
 180          Container.First := N (X).Next;
 181          N (Container.First).Prev := 0;
 182
 183          Container.Length := Container.Length - 1;
 184
 185          Free (Container, X);
 186       end loop;
 187
 188       X := Container.First;
 189
 190       Container.First := 0;
 191       Container.Last := 0;
 192       Container.Length := 0;
 193
 194       Free (Container, X);
 195    end Clear;
 196
 197    --------------
 198    -- Contains --
 199    --------------
 200
 201    function Contains
 202      (Container : List;
 203       Item      : Element_Type) return Boolean
 204    is
 205    begin
 206       return Find (Container, Item) /= No_Element;
 207    end Contains;
 208
 209    ------------
 210    -- Delete --
 211    ------------
 212
 213    procedure Delete
 214      (Container : in out List;
 215       Position  : in out Cursor;
 216       Count     : Count_Type := 1)
 217    is
 218       N : Node_Array renames Container.Nodes;
 219       X : Count_Type;
 220
 221    begin
 222       if Position.Node = 0 then
 223          raise Constraint_Error;
 224       end if;
 225
 226       if Position.Container /= Container'Unrestricted_Access then
 227          raise Program_Error;
 228       end if;
 229
 230       pragma Assert (Vet (Position), "bad cursor in Delete");
 231
 232       if Position.Node = Container.First then
 233          Delete_First (Container, Count);
 234          Position := No_Element;
 235          return;
 236       end if;
 237
 238       if Count = 0 then
 239          Position := No_Element;
 240          return;
 241       end if;
 242
 243 --    if Container.Busy > 0 then
 244 --       raise Program_Error;
 245 --    end if;
 246
 247       pragma Assert (Container.First >= 1);
 248       pragma Assert (Container.Last >= 1);
 249       pragma Assert (N (Container.First).Prev = 0);
 250       pragma Assert (N (Container.Last).Next = 0);
 251
 252       for Index in 1 .. Count loop
 253          pragma Assert (Container.Length >= 2);
 254
 255          X := Position.Node;
 256          Container.Length := Container.Length - 1;
 257
 258          if X = Container.Last then
 259             Position := No_Element;
 260
 261             Container.Last := N (X).Prev;
 262             N (Container.Last).Next := 0;
 263
 264             Free (Container, X);
 265             return;
 266          end if;
 267
 268          Position.Node := N (X).Next;
 269
 270          N (N (X).Next).Prev := N (X).Prev;
 271          N (N (X).Prev).Next := N (X).Next;
 272
 273          Free (Container, X);
 274       end loop;
 275
 276       Position := No_Element;
 277    end Delete;
 278
 279    ------------------
 280    -- Delete_First --
 281    ------------------
 282
 283    procedure Delete_First
 284      (Container : in out List;
 285       Count     : Count_Type := 1)
 286    is
 287       N : Node_Array renames Container.Nodes;
 288       X : Count_Type;
 289
 290    begin
 291       if Count >= Container.Length then
 292          Clear (Container);
 293          return;
 294       end if;
 295
 296       if Count = 0 then
 297          return;
 298       end if;
 299
 300 --    if Container.Busy > 0 then
 301 --       raise Program_Error;
 302 --    end if;
 303
 304       for I in 1 .. Count loop
 305          X := Container.First;
 306          pragma Assert (N (N (X).Next).Prev = Container.First);
 307
 308          Container.First := N (X).Next;
 309          N (Container.First).Prev := 0;
 310
 311          Container.Length := Container.Length - 1;
 312
 313          Free (Container, X);
 314       end loop;
 315    end Delete_First;
 316
 317    -----------------
 318    -- Delete_Last --
 319    -----------------
 320
 321    procedure Delete_Last
 322      (Container : in out List;
 323       Count     : Count_Type := 1)
 324    is
 325       N : Node_Array renames Container.Nodes;
 326       X : Count_Type;
 327
 328    begin
 329       if Count >= Container.Length then
 330          Clear (Container);
 331          return;
 332       end if;
 333
 334       if Count = 0 then
 335          return;
 336       end if;
 337
 338 --    if Container.Busy > 0 then
 339 --       raise Program_Error;
 340 --    end if;
 341
 342       for I in 1 .. Count loop
 343          X := Container.Last;
 344          pragma Assert (N (N (X).Prev).Next = Container.Last);
 345
 346          Container.Last := N (X).Prev;
 347          N (Container.Last).Next := 0;
 348
 349          Container.Length := Container.Length - 1;
 350
 351          Free (Container, X);
 352       end loop;
 353    end Delete_Last;
 354
 355    -------------
 356    -- Element --
 357    -------------
 358
 359    function Element (Position : Cursor) return Element_Type is
 360    begin
 361       if Position.Node = 0 then
 362          raise Constraint_Error;
 363       end if;
 364
 365       pragma Assert (Vet (Position), "bad cursor in Element");
 366
 367       declare
 368          N : Node_Array renames Position.Container.Nodes;
 369       begin
 370          return N (Position.Node).Element;
 371       end;
 372    end Element;
 373
 374    ----------
 375    -- Find --
 376    ----------
 377
 378    function Find
 379      (Container : List;
 380       Item      : Element_Type;
 381       Position  : Cursor := No_Element) return Cursor
 382    is
 383       Nodes : Node_Array renames Container.Nodes;
 384       Node  : Count_Type := Position.Node;
 385
 386    begin
 387       if Node = 0 then
 388          Node := Container.First;
 389
 390       else
 391          if Position.Container /= Container'Unrestricted_Access then
 392             raise Program_Error;
 393          end if;
 394
 395          pragma Assert (Vet (Position), "bad cursor in Find");
 396       end if;
 397
 398       while Node /= 0 loop
 399          if Nodes (Node).Element = Item then
 400             return Cursor'(Container'Unrestricted_Access, Node);
 401          end if;
 402
 403          Node := Nodes (Node).Next;
 404       end loop;
 405
 406       return No_Element;
 407    end Find;
 408
 409    -----------
 410    -- First --
 411    -----------
 412
 413    function First (Container : List) return Cursor is
 414    begin
 415       if Container.First = 0 then
 416          return No_Element;
 417       end if;
 418
 419       return Cursor'(Container'Unrestricted_Access, Container.First);
 420    end First;
 421
 422    -------------------
 423    -- First_Element --
 424    -------------------
 425
 426    function First_Element (Container : List) return Element_Type is
 427       N : Node_Array renames Container.Nodes;
 428
 429    begin
 430       if Container.First = 0 then
 431          raise Constraint_Error;
 432       end if;
 433
 434       return N (Container.First).Element;
 435    end First_Element;
 436
 437    ----------
 438    -- Free --
 439    ----------
 440
 441    procedure Free
 442      (Container : in out List'Class;
 443       X         : Count_Type)
 444    is
 445       pragma Assert (X > 0);
 446       pragma Assert (X <= Container.Capacity);
 447
 448       N : Node_Array renames Container.Nodes;
 449
 450    begin
 451       N (X).Prev := -1;  -- Node is deallocated (not on active list)
 452
 453       if Container.Free >= 0 then
 454          N (X).Next := Container.Free;
 455          Container.Free := X;
 456
 457       elsif X + 1 = abs Container.Free then
 458          N (X).Next := 0;  -- Not strictly necessary, but marginally safer
 459          Container.Free := Container.Free + 1;
 460
 461       else
 462          Container.Free := abs Container.Free;
 463
 464          if Container.Free > Container.Capacity then
 465             Container.Free := 0;
 466
 467          else
 468             for I in Container.Free .. Container.Capacity - 1 loop
 469                N (I).Next := I + 1;
 470             end loop;
 471
 472             N (Container.Capacity).Next := 0;
 473          end if;
 474
 475          N (X).Next := Container.Free;
 476          Container.Free := X;
 477       end if;
 478    end Free;
 479
 480    ---------------------
 481    -- Generic_Sorting --
 482    ---------------------
 483
 484    package body Generic_Sorting is
 485
 486       ---------------
 487       -- Is_Sorted --
 488       ---------------
 489
 490       function Is_Sorted (Container : List) return Boolean is
 491          Nodes : Node_Array renames Container.Nodes;
 492          Node  : Count_Type := Container.First;
 493
 494       begin
 495          for I in 2 .. Container.Length loop
 496             if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
 497                return False;
 498             end if;
 499
 500             Node := Nodes (Node).Next;
 501          end loop;
 502
 503          return True;
 504       end Is_Sorted;
 505
 506       ----------
 507       -- Sort --
 508       ----------
 509
 510       procedure Sort (Container : in out List) is
 511          N : Node_Array renames Container.Nodes;
 512
 513          procedure Partition (Pivot, Back : Count_Type);
 514          procedure Sort (Front, Back : Count_Type);
 515
 516          ---------------
 517          -- Partition --
 518          ---------------
 519
 520          procedure Partition (Pivot, Back : Count_Type) is
 521             Node : Count_Type := N (Pivot).Next;
 522
 523          begin
 524             while Node /= Back loop
 525                if N (Node).Element < N (Pivot).Element then
 526                   declare
 527                      Prev : constant Count_Type := N (Node).Prev;
 528                      Next : constant Count_Type := N (Node).Next;
 529
 530                   begin
 531                      N (Prev).Next := Next;
 532
 533                      if Next = 0 then
 534                         Container.Last := Prev;
 535                      else
 536                         N (Next).Prev := Prev;
 537                      end if;
 538
 539                      N (Node).Next := Pivot;
 540                      N (Node).Prev := N (Pivot).Prev;
 541
 542                      N (Pivot).Prev := Node;
 543
 544                      if N (Node).Prev = 0 then
 545                         Container.First := Node;
 546                      else
 547                         N (N (Node).Prev).Next := Node;
 548                      end if;
 549
 550                      Node := Next;
 551                   end;
 552
 553                else
 554                   Node := N (Node).Next;
 555                end if;
 556             end loop;
 557          end Partition;
 558
 559          ----------
 560          -- Sort --
 561          ----------
 562
 563          procedure Sort (Front, Back : Count_Type) is
 564             Pivot : Count_Type;
 565
 566          begin
 567             if Front = 0 then
 568                Pivot := Container.First;
 569             else
 570                Pivot := N (Front).Next;
 571             end if;
 572
 573             if Pivot /= Back then
 574                Partition (Pivot, Back);
 575                Sort (Front, Pivot);
 576                Sort (Pivot, Back);
 577             end if;
 578          end Sort;
 579
 580       --  Start of processing for Sort
 581
 582       begin
 583          if Container.Length <= 1 then
 584             return;
 585          end if;
 586
 587          pragma Assert (N (Container.First).Prev = 0);
 588          pragma Assert (N (Container.Last).Next = 0);
 589
 590 --       if Container.Busy > 0 then
 591 --          raise Program_Error;
 592 --       end if;
 593
 594          Sort (Front => 0, Back => 0);
 595
 596          pragma Assert (N (Container.First).Prev = 0);
 597          pragma Assert (N (Container.Last).Next = 0);
 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 /= 0;
 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       J : Count_Type;
 624
 625    begin
 626       if Before.Container /= null then
 627          if Before.Container /= Container'Unrestricted_Access then
 628             raise Program_Error;
 629          end if;
 630
 631          pragma Assert (Vet (Before), "bad cursor in Insert");
 632       end if;
 633
 634       if Count = 0 then
 635          Position := Before;
 636          return;
 637       end if;
 638
 639       if Container.Length > Container.Capacity - Count then
 640          raise Constraint_Error;
 641       end if;
 642
 643 --    if Container.Busy > 0 then
 644 --       raise Program_Error;
 645 --    end if;
 646
 647       Allocate (Container, New_Item, New_Node => J);
 648       Insert_Internal (Container, Before.Node, New_Node => J);
 649       Position := Cursor'(Container'Unrestricted_Access, Node => J);
 650
 651       for Index in 2 .. Count loop
 652          Allocate (Container, New_Item, New_Node => J);
 653          Insert_Internal (Container, Before.Node, New_Node => J);
 654       end loop;
 655    end Insert;
 656
 657    procedure Insert
 658      (Container : in out List;
 659       Before    : Cursor;
 660       New_Item  : Element_Type;
 661       Count     : Count_Type := 1)
 662    is
 663       Position : Cursor;
 664       pragma Unreferenced (Position);
 665    begin
 666       Insert (Container, Before, New_Item, Position, Count);
 667    end Insert;
 668
 669    procedure Insert
 670      (Container : in out List;
 671       Before    : Cursor;
 672       Position  : out Cursor;
 673       Count     : Count_Type := 1)
 674    is
 675       New_Item : Element_Type;  -- Do we need to reinit node ???
 676       pragma Warnings (Off, New_Item);
 677
 678    begin
 679       Insert (Container, Before, New_Item, Position, Count);
 680    end Insert;
 681
 682    ---------------------
 683    -- Insert_Internal --
 684    ---------------------
 685
 686    procedure Insert_Internal
 687      (Container : in out List'Class;
 688       Before    : Count_Type;
 689       New_Node  : Count_Type)
 690    is
 691       N : Node_Array renames Container.Nodes;
 692
 693    begin
 694       if Container.Length = 0 then
 695          pragma Assert (Before = 0);
 696          pragma Assert (Container.First = 0);
 697          pragma Assert (Container.Last = 0);
 698
 699          Container.First := New_Node;
 700          Container.Last := New_Node;
 701
 702          N (Container.First).Prev := 0;
 703          N (Container.Last).Next := 0;
 704
 705       elsif Before = 0 then
 706          pragma Assert (N (Container.Last).Next = 0);
 707
 708          N (Container.Last).Next := New_Node;
 709          N (New_Node).Prev := Container.Last;
 710
 711          Container.Last := New_Node;
 712          N (Container.Last).Next := 0;
 713
 714       elsif Before = Container.First then
 715          pragma Assert (N (Container.First).Prev = 0);
 716
 717          N (Container.First).Prev := New_Node;
 718          N (New_Node).Next := Container.First;
 719
 720          Container.First := New_Node;
 721          N (Container.First).Prev := 0;
 722
 723       else
 724          pragma Assert (N (Container.First).Prev = 0);
 725          pragma Assert (N (Container.Last).Next = 0);
 726
 727          N (New_Node).Next := Before;
 728          N (New_Node).Prev := N (Before).Prev;
 729
 730          N (N (Before).Prev).Next := New_Node;
 731          N (Before).Prev := New_Node;
 732       end if;
 733
 734       Container.Length := Container.Length + 1;
 735    end Insert_Internal;
 736
 737    --------------
 738    -- Is_Empty --
 739    --------------
 740
 741    function Is_Empty (Container : List) return Boolean is
 742    begin
 743       return Container.Length = 0;
 744    end Is_Empty;
 745
 746    -------------
 747    -- Iterate --
 748    -------------
 749
 750    procedure Iterate
 751      (Container : List;
 752       Process   : not null access procedure (Position : Cursor))
 753    is
 754       C : List renames Container'Unrestricted_Access.all;
 755       N : Node_Array renames C.Nodes;
 756 --    B : Natural renames C.Busy;
 757
 758       Node  : Count_Type := Container.First;
 759
 760       Index     : Count_Type := 0;
 761       Index_Max : constant Count_Type := Container.Length;
 762
 763    begin
 764       if Index_Max = 0 then
 765          pragma Assert (Node = 0);
 766          return;
 767       end if;
 768
 769       loop
 770          pragma Assert (Node /= 0);
 771
 772          Process (Cursor'(C'Unchecked_Access, Node));
 773          pragma Assert (Container.Length = Index_Max);
 774          pragma Assert (N (Node).Prev /= -1);
 775
 776          Node := N (Node).Next;
 777          Index := Index + 1;
 778
 779          if Index = Index_Max then
 780             pragma Assert (Node = 0);
 781             return;
 782          end if;
 783       end loop;
 784    end Iterate;
 785
 786    ----------
 787    -- Last --
 788    ----------
 789
 790    function Last (Container : List) return Cursor is
 791    begin
 792       if Container.Last = 0 then
 793          return No_Element;
 794       end if;
 795
 796       return Cursor'(Container'Unrestricted_Access, Container.Last);
 797    end Last;
 798
 799    ------------------
 800    -- Last_Element --
 801    ------------------
 802
 803    function Last_Element (Container : List) return Element_Type is
 804       N : Node_Array renames Container.Nodes;
 805
 806    begin
 807       if Container.Last = 0 then
 808          raise Constraint_Error;
 809       end if;
 810
 811       return N (Container.Last).Element;
 812    end Last_Element;
 813
 814    ------------
 815    -- Length --
 816    ------------
 817
 818    function Length (Container : List) return Count_Type is
 819    begin
 820       return Container.Length;
 821    end Length;
 822
 823    ----------
 824    -- Next --
 825    ----------
 826
 827    procedure Next (Position : in out Cursor) is
 828    begin
 829       Position := Next (Position);
 830    end Next;
 831
 832    function Next (Position : Cursor) return Cursor is
 833    begin
 834       if Position.Node = 0 then
 835          return No_Element;
 836       end if;
 837
 838       pragma Assert (Vet (Position), "bad cursor in Next");
 839
 840       declare
 841          Nodes : Node_Array renames Position.Container.Nodes;
 842          Node  : constant Count_Type := Nodes (Position.Node).Next;
 843
 844       begin
 845          if Node = 0 then
 846             return No_Element;
 847          end if;
 848
 849          return Cursor'(Position.Container, Node);
 850       end;
 851    end Next;
 852
 853    -------------
 854    -- Prepend --
 855    -------------
 856
 857    procedure Prepend
 858      (Container : in out List;
 859       New_Item  : Element_Type;
 860       Count     : Count_Type := 1)
 861    is
 862    begin
 863       Insert (Container, First (Container), New_Item, Count);
 864    end Prepend;
 865
 866    --------------
 867    -- Previous --
 868    --------------
 869
 870    procedure Previous (Position : in out Cursor) is
 871    begin
 872       Position := Previous (Position);
 873    end Previous;
 874
 875    function Previous (Position : Cursor) return Cursor is
 876    begin
 877       if Position.Node = 0 then
 878          return No_Element;
 879       end if;
 880
 881       pragma Assert (Vet (Position), "bad cursor in Previous");
 882
 883       declare
 884          Nodes : Node_Array renames Position.Container.Nodes;
 885          Node  : constant Count_Type := Nodes (Position.Node).Prev;
 886       begin
 887          if Node = 0 then
 888             return No_Element;
 889          end if;
 890
 891          return Cursor'(Position.Container, Node);
 892       end;
 893    end Previous;
 894
 895    -------------------
 896    -- Query_Element --
 897    -------------------
 898
 899    procedure Query_Element
 900      (Position : Cursor;
 901       Process  : not null access procedure (Element : Element_Type))
 902    is
 903    begin
 904       if Position.Node = 0 then
 905          raise Constraint_Error;
 906       end if;
 907
 908       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 909
 910       declare
 911          C : List renames Position.Container.all'Unrestricted_Access.all;
 912          N : Node_Type renames C.Nodes (Position.Node);
 913
 914       begin
 915          Process (N.Element);
 916          pragma Assert (N.Prev >= 0);
 917       end;
 918    end Query_Element;
 919
 920    ---------------------
 921    -- Replace_Element --
 922    ---------------------
 923
 924    procedure Replace_Element
 925      (Container : in out List;
 926       Position  : Cursor;
 927       New_Item  : Element_Type)
 928    is
 929    begin
 930       if Position.Container = null then
 931          raise Constraint_Error;
 932       end if;
 933
 934       if Position.Container /= Container'Unrestricted_Access then
 935          raise Program_Error;
 936       end if;
 937
 938 --    if Container.Lock > 0 then
 939 --       raise Program_Error;
 940 --    end if;
 941
 942       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 943
 944       declare
 945          N : Node_Array renames Container.Nodes;
 946       begin
 947          N (Position.Node).Element := New_Item;
 948       end;
 949    end Replace_Element;
 950
 951    ----------------------
 952    -- Reverse_Elements --
 953    ----------------------
 954
 955    procedure Reverse_Elements (Container : in out List) is
 956       N : Node_Array renames Container.Nodes;
 957       I : Count_Type := Container.First;
 958       J : Count_Type := Container.Last;
 959
 960       procedure Swap (L, R : Count_Type);
 961
 962       ----------
 963       -- Swap --
 964       ----------
 965
 966       procedure Swap (L, R : Count_Type) is
 967          LN : constant Count_Type := N (L).Next;
 968          LP : constant Count_Type := N (L).Prev;
 969
 970          RN : constant Count_Type := N (R).Next;
 971          RP : constant Count_Type := N (R).Prev;
 972
 973       begin
 974          if LP /= 0 then
 975             N (LP).Next := R;
 976          end if;
 977
 978          if RN /= 0 then
 979             N (RN).Prev := L;
 980          end if;
 981
 982          N (L).Next := RN;
 983          N (R).Prev := LP;
 984
 985          if LN = R then
 986             pragma Assert (RP = L);
 987
 988             N (L).Prev := R;
 989             N (R).Next := L;
 990
 991          else
 992             N (L).Prev := RP;
 993             N (RP).Next := L;
 994
 995             N (R).Next := LN;
 996             N (LN).Prev := R;
 997          end if;
 998       end Swap;
 999
1000    --  Start of processing for Reverse_Elements
1001
1002    begin
1003       if Container.Length <= 1 then
1004          return;
1005       end if;
1006
1007       pragma Assert (N (Container.First).Prev = 0);
1008       pragma Assert (N (Container.Last).Next = 0);
1009
1010 --    if Container.Busy > 0 then
1011 --       raise Program_Error;
1012 --    end if;
1013
1014       Container.First := J;
1015       Container.Last := I;
1016       loop
1017          Swap (L => I, R => J);
1018
1019          J := N (J).Next;
1020          exit when I = J;
1021
1022          I := N (I).Prev;
1023          exit when I = J;
1024
1025          Swap (L => J, R => I);
1026
1027          I := N (I).Next;
1028          exit when I = J;
1029
1030          J := N (J).Prev;
1031          exit when I = J;
1032       end loop;
1033
1034       pragma Assert (N (Container.First).Prev = 0);
1035       pragma Assert (N (Container.Last).Next = 0);
1036    end Reverse_Elements;
1037
1038    ------------------
1039    -- Reverse_Find --
1040    ------------------
1041
1042    function Reverse_Find
1043      (Container : List;
1044       Item      : Element_Type;
1045       Position  : Cursor := No_Element) return Cursor
1046    is
1047       N    : Node_Array renames Container.Nodes;
1048       Node : Count_Type := Position.Node;
1049
1050    begin
1051       if Node = 0 then
1052          Node := Container.Last;
1053
1054       else
1055          if Position.Container /= Container'Unrestricted_Access then
1056             raise Program_Error;
1057          end if;
1058
1059          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1060       end if;
1061
1062       while Node /= 0 loop
1063          if N (Node).Element = Item then
1064             return Cursor'(Container'Unrestricted_Access, Node);
1065          end if;
1066
1067          Node := N (Node).Prev;
1068       end loop;
1069
1070       return No_Element;
1071    end Reverse_Find;
1072
1073    ---------------------
1074    -- Reverse_Iterate --
1075    ---------------------
1076
1077    procedure Reverse_Iterate
1078      (Container : List;
1079       Process   : not null access procedure (Position : Cursor))
1080    is
1081       C : List renames Container'Unrestricted_Access.all;
1082       N : Node_Array renames C.Nodes;
1083 --    B : Natural renames C.Busy;
1084
1085       Node : Count_Type := Container.Last;
1086
1087       Index     : Count_Type := 0;
1088       Index_Max : constant Count_Type := Container.Length;
1089
1090    begin
1091       if Index_Max = 0 then
1092          pragma Assert (Node = 0);
1093          return;
1094       end if;
1095
1096       loop
1097          pragma Assert (Node > 0);
1098
1099          Process (Cursor'(C'Unchecked_Access, Node));
1100          pragma Assert (Container.Length = Index_Max);
1101          pragma Assert (N (Node).Prev /= -1);
1102
1103          Node := N (Node).Prev;
1104          Index := Index + 1;
1105
1106          if Index = Index_Max then
1107             pragma Assert (Node = 0);
1108             return;
1109          end if;
1110       end loop;
1111    end Reverse_Iterate;
1112
1113    ------------
1114    -- Splice --
1115    ------------
1116
1117    procedure Splice
1118      (Container : in out List;
1119       Before    : Cursor;
1120       Position  : in out Cursor)
1121    is
1122       N : Node_Array renames Container.Nodes;
1123
1124    begin
1125       if Before.Container /= null then
1126          if Before.Container /= Container'Unrestricted_Access then
1127             raise Program_Error;
1128          end if;
1129
1130          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1131       end if;
1132
1133       if Position.Node = 0 then
1134          raise Constraint_Error;
1135       end if;
1136
1137       if Position.Container /= Container'Unrestricted_Access then
1138          raise Program_Error;
1139       end if;
1140
1141       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1142
1143       if Position.Node = Before.Node
1144         or else N (Position.Node).Next = Before.Node
1145       then
1146          return;
1147       end if;
1148
1149       pragma Assert (Container.Length >= 2);
1150
1151 --    if Container.Busy > 0 then
1152 --       raise Program_Error;
1153 --    end if;
1154
1155       if Before.Node = 0 then
1156          pragma Assert (Position.Node /= Container.Last);
1157
1158          if Position.Node = Container.First then
1159             Container.First := N (Position.Node).Next;
1160             N (Container.First).Prev := 0;
1161
1162          else
1163             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1164             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1165          end if;
1166
1167          N (Container.Last).Next := Position.Node;
1168          N (Position.Node).Prev := Container.Last;
1169
1170          Container.Last := Position.Node;
1171          N (Container.Last).Next := 0;
1172
1173          return;
1174       end if;
1175
1176       if Before.Node = Container.First then
1177          pragma Assert (Position.Node /= Container.First);
1178
1179          if Position.Node = Container.Last then
1180             Container.Last := N (Position.Node).Prev;
1181             N (Container.Last).Next := 0;
1182
1183          else
1184             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1185             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1186          end if;
1187
1188          N (Container.First).Prev := Position.Node;
1189          N (Position.Node).Next := Container.First;
1190
1191          Container.First := Position.Node;
1192          N (Container.First).Prev := 0;
1193
1194          return;
1195       end if;
1196
1197       if Position.Node = Container.First then
1198          Container.First := N (Position.Node).Next;
1199          N (Container.First).Prev := 0;
1200
1201       elsif Position.Node = Container.Last then
1202          Container.Last := N (Position.Node).Prev;
1203          N (Container.Last).Next := 0;
1204
1205       else
1206          N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1207          N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1208       end if;
1209
1210       N (N (Before.Node).Prev).Next := Position.Node;
1211       N (Position.Node).Prev := N (Before.Node).Prev;
1212
1213       N (Before.Node).Prev := Position.Node;
1214       N (Position.Node).Next := Before.Node;
1215
1216       pragma Assert (N (Container.First).Prev = 0);
1217       pragma Assert (N (Container.Last).Next = 0);
1218    end Splice;
1219
1220    ----------
1221    -- Swap --
1222    ----------
1223
1224    procedure Swap
1225      (Container : in out List;
1226       I, J      : Cursor)
1227    is
1228    begin
1229       if I.Node = 0
1230         or else J.Node = 0
1231       then
1232          raise Constraint_Error;
1233       end if;
1234
1235       if I.Container /= Container'Unrestricted_Access
1236         or else J.Container /= Container'Unrestricted_Access
1237       then
1238          raise Program_Error;
1239       end if;
1240
1241       if I.Node = J.Node then
1242          return;
1243       end if;
1244
1245 --    if Container.Lock > 0 then
1246 --       raise Program_Error;
1247 --    end if;
1248
1249       pragma Assert (Vet (I), "bad I cursor in Swap");
1250       pragma Assert (Vet (J), "bad J cursor in Swap");
1251
1252       declare
1253          N  : Node_Array renames Container.Nodes;
1254
1255          EI : Element_Type renames N (I.Node).Element;
1256          EJ : Element_Type renames N (J.Node).Element;
1257
1258          EI_Copy : constant Element_Type := EI;
1259
1260       begin
1261          EI := EJ;
1262          EJ := EI_Copy;
1263       end;
1264    end Swap;
1265
1266    ----------------
1267    -- Swap_Links --
1268    ----------------
1269
1270    procedure Swap_Links
1271      (Container : in out List;
1272       I, J      : Cursor)
1273    is
1274    begin
1275       if I.Node = 0
1276         or else J.Node = 0
1277       then
1278          raise Constraint_Error;
1279       end if;
1280
1281       if I.Container /= Container'Unrestricted_Access
1282         or else I.Container /= J.Container
1283       then
1284          raise Program_Error;
1285       end if;
1286
1287       if I.Node = J.Node then
1288          return;
1289       end if;
1290
1291 --    if Container.Busy > 0 then
1292 --       raise Program_Error;
1293 --    end if;
1294
1295       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1296       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1297
1298       declare
1299          I_Next : constant Cursor := Next (I);
1300
1301          J_Copy : Cursor := J;
1302          pragma Warnings (Off, J_Copy);
1303
1304       begin
1305          if I_Next = J then
1306             Splice (Container, Before => I, Position => J_Copy);
1307
1308          else
1309             declare
1310                J_Next : constant Cursor := Next (J);
1311
1312                I_Copy : Cursor := I;
1313                pragma Warnings (Off, I_Copy);
1314
1315             begin
1316                if J_Next = I then
1317                   Splice (Container, Before => J, Position => I_Copy);
1318
1319                else
1320                   pragma Assert (Container.Length >= 3);
1321
1322                   Splice (Container, Before => I_Next, Position => J_Copy);
1323                   Splice (Container, Before => J_Next, Position => I_Copy);
1324                end if;
1325             end;
1326          end if;
1327       end;
1328    end Swap_Links;
1329
1330    --------------------
1331    -- Update_Element --
1332    --------------------
1333
1334    procedure Update_Element
1335      (Container : in out List;
1336       Position  : Cursor;
1337       Process   : not null access procedure (Element : in out Element_Type))
1338    is
1339    begin
1340       if Position.Node = 0 then
1341          raise Constraint_Error;
1342       end if;
1343
1344       if Position.Container /= Container'Unrestricted_Access then
1345          raise Program_Error;
1346       end if;
1347
1348       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1349
1350       declare
1351          N  : Node_Type renames Container.Nodes (Position.Node);
1352
1353       begin
1354          Process (N.Element);
1355          pragma Assert (N.Prev >= 0);
1356       end;
1357    end Update_Element;
1358
1359    ---------
1360    -- Vet --
1361    ---------
1362
1363    function Vet (Position : Cursor) return Boolean is
1364    begin
1365       if Position.Node = 0 then
1366          return Position.Container = null;
1367       end if;
1368
1369       if Position.Container = null then
1370          return False;
1371       end if;
1372
1373       declare
1374          L : List renames Position.Container.all;
1375          N : Node_Array renames L.Nodes;
1376
1377       begin
1378          if L.Length = 0 then
1379             return False;
1380          end if;
1381
1382          if L.First = 0 then
1383             return False;
1384          end if;
1385
1386          if L.Last = 0 then
1387             return False;
1388          end if;
1389
1390          if Position.Node > L.Capacity then
1391             return False;
1392          end if;
1393
1394          if N (Position.Node).Prev < 0
1395            or else N (Position.Node).Prev > L.Capacity
1396          then
1397             return False;
1398          end if;
1399
1400          if N (Position.Node).Next > L.Capacity then
1401             return False;
1402          end if;
1403
1404          if N (L.First).Prev /= 0 then
1405             return False;
1406          end if;
1407
1408          if N (L.Last).Next /= 0 then
1409             return False;
1410          end if;
1411
1412          if N (Position.Node).Prev = 0
1413            and then Position.Node /= L.First
1414          then
1415             return False;
1416          end if;
1417
1418          if N (Position.Node).Next = 0
1419            and then Position.Node /= L.Last
1420          then
1421             return False;
1422          end if;
1423
1424          if L.Length = 1 then
1425             return L.First = L.Last;
1426          end if;
1427
1428          if L.First = L.Last then
1429             return False;
1430          end if;
1431
1432          if N (L.First).Next = 0 then
1433             return False;
1434          end if;
1435
1436          if N (L.Last).Prev = 0 then
1437             return False;
1438          end if;
1439
1440          if N (N (L.First).Next).Prev /= L.First then
1441             return False;
1442          end if;
1443
1444          if N (N (L.Last).Prev).Next /= L.Last then
1445             return False;
1446          end if;
1447
1448          if L.Length = 2 then
1449             if N (L.First).Next /= L.Last then
1450                return False;
1451             end if;
1452
1453             if N (L.Last).Prev /= L.First then
1454                return False;
1455             end if;
1456
1457             return True;
1458          end if;
1459
1460          if N (L.First).Next = L.Last then
1461             return False;
1462          end if;
1463
1464          if N (L.Last).Prev = L.First then
1465             return False;
1466          end if;
1467
1468          if Position.Node = L.First then
1469             return True;
1470          end if;
1471
1472          if Position.Node = L.Last then
1473             return True;
1474          end if;
1475
1476          if N (Position.Node).Next = 0 then
1477             return False;
1478          end if;
1479
1480          if N (Position.Node).Prev = 0 then
1481             return False;
1482          end if;
1483
1484          if N (N (Position.Node).Next).Prev /= Position.Node then
1485             return False;
1486          end if;
1487
1488          if N (N (Position.Node).Prev).Next /= Position.Node then
1489             return False;
1490          end if;
1491
1492          if L.Length = 3 then
1493             if N (L.First).Next /= Position.Node then
1494                return False;
1495             end if;
1496
1497             if N (L.Last).Prev /= Position.Node then
1498                return False;
1499             end if;
1500          end if;
1501
1502          return True;
1503       end;
1504    end Vet;
1505
1506 end Ada.Containers.Restricted_Doubly_Linked_Lists;