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