gcc/ada/libgnat/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-2018, 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 : constant Count_Type :=
 565               (if Front = 0 then Container.First else N (Front).Next);
 566          begin
 567             if Pivot /= Back then
 568                Partition (Pivot, Back);
 569                Sort (Front, Pivot);
 570                Sort (Pivot, Back);
 571             end if;
 572          end Sort;
 573
 574       --  Start of processing for Sort
 575
 576       begin
 577          if Container.Length <= 1 then
 578             return;
 579          end if;
 580
 581          pragma Assert (N (Container.First).Prev = 0);
 582          pragma Assert (N (Container.Last).Next = 0);
 583
 584 --       if Container.Busy > 0 then
 585 --          raise Program_Error;
 586 --       end if;
 587
 588          Sort (Front => 0, Back => 0);
 589
 590          pragma Assert (N (Container.First).Prev = 0);
 591          pragma Assert (N (Container.Last).Next = 0);
 592       end Sort;
 593
 594    end Generic_Sorting;
 595
 596    -----------------
 597    -- Has_Element --
 598    -----------------
 599
 600    function Has_Element (Position : Cursor) return Boolean is
 601    begin
 602       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 603       return Position.Node /= 0;
 604    end Has_Element;
 605
 606    ------------
 607    -- Insert --
 608    ------------
 609
 610    procedure Insert
 611      (Container : in out List;
 612       Before    : Cursor;
 613       New_Item  : Element_Type;
 614       Position  : out Cursor;
 615       Count     : Count_Type := 1)
 616    is
 617       First_Node : Count_Type;
 618       New_Node   : Count_Type;
 619
 620    begin
 621       if Before.Container /= null then
 622          if Before.Container /= Container'Unrestricted_Access then
 623             raise Program_Error;
 624          end if;
 625
 626          pragma Assert (Vet (Before), "bad cursor in Insert");
 627       end if;
 628
 629       if Count = 0 then
 630          Position := Before;
 631          return;
 632       end if;
 633
 634       if Container.Length > Container.Capacity - Count then
 635          raise Constraint_Error;
 636       end if;
 637
 638 --    if Container.Busy > 0 then
 639 --       raise Program_Error;
 640 --    end if;
 641
 642       Allocate (Container, New_Item, New_Node);
 643       First_Node := New_Node;
 644       Insert_Internal (Container, Before.Node, New_Node);
 645
 646       for Index in 2 .. Count loop
 647          Allocate (Container, New_Item, New_Node);
 648          Insert_Internal (Container, Before.Node, New_Node);
 649       end loop;
 650
 651       Position := Cursor'(Container'Unrestricted_Access, First_Node);
 652    end Insert;
 653
 654    procedure Insert
 655      (Container : in out List;
 656       Before    : Cursor;
 657       New_Item  : Element_Type;
 658       Count     : Count_Type := 1)
 659    is
 660       Position : Cursor;
 661       pragma Unreferenced (Position);
 662    begin
 663       Insert (Container, Before, New_Item, Position, Count);
 664    end Insert;
 665
 666    procedure Insert
 667      (Container : in out List;
 668       Before    : Cursor;
 669       Position  : out Cursor;
 670       Count     : Count_Type := 1)
 671    is
 672       New_Item : Element_Type;  -- Do we need to reinit node ???
 673       pragma Warnings (Off, New_Item);
 674
 675    begin
 676       Insert (Container, Before, New_Item, Position, Count);
 677    end Insert;
 678
 679    ---------------------
 680    -- Insert_Internal --
 681    ---------------------
 682
 683    procedure Insert_Internal
 684      (Container : in out List'Class;
 685       Before    : Count_Type;
 686       New_Node  : Count_Type)
 687    is
 688       N : Node_Array renames Container.Nodes;
 689
 690    begin
 691       if Container.Length = 0 then
 692          pragma Assert (Before = 0);
 693          pragma Assert (Container.First = 0);
 694          pragma Assert (Container.Last = 0);
 695
 696          Container.First := New_Node;
 697          Container.Last := New_Node;
 698
 699          N (Container.First).Prev := 0;
 700          N (Container.Last).Next := 0;
 701
 702       elsif Before = 0 then
 703          pragma Assert (N (Container.Last).Next = 0);
 704
 705          N (Container.Last).Next := New_Node;
 706          N (New_Node).Prev := Container.Last;
 707
 708          Container.Last := New_Node;
 709          N (Container.Last).Next := 0;
 710
 711       elsif Before = Container.First then
 712          pragma Assert (N (Container.First).Prev = 0);
 713
 714          N (Container.First).Prev := New_Node;
 715          N (New_Node).Next := Container.First;
 716
 717          Container.First := New_Node;
 718          N (Container.First).Prev := 0;
 719
 720       else
 721          pragma Assert (N (Container.First).Prev = 0);
 722          pragma Assert (N (Container.Last).Next = 0);
 723
 724          N (New_Node).Next := Before;
 725          N (New_Node).Prev := N (Before).Prev;
 726
 727          N (N (Before).Prev).Next := New_Node;
 728          N (Before).Prev := New_Node;
 729       end if;
 730
 731       Container.Length := Container.Length + 1;
 732    end Insert_Internal;
 733
 734    --------------
 735    -- Is_Empty --
 736    --------------
 737
 738    function Is_Empty (Container : List) return Boolean is
 739    begin
 740       return Container.Length = 0;
 741    end Is_Empty;
 742
 743    -------------
 744    -- Iterate --
 745    -------------
 746
 747    procedure Iterate
 748      (Container : List;
 749       Process   : not null access procedure (Position : Cursor))
 750    is
 751       C : List renames Container'Unrestricted_Access.all;
 752       N : Node_Array renames C.Nodes;
 753 --    B : Natural renames C.Busy;
 754
 755       Node  : Count_Type := Container.First;
 756
 757       Index     : Count_Type := 0;
 758       Index_Max : constant Count_Type := Container.Length;
 759
 760    begin
 761       if Index_Max = 0 then
 762          pragma Assert (Node = 0);
 763          return;
 764       end if;
 765
 766       loop
 767          pragma Assert (Node /= 0);
 768
 769          Process (Cursor'(C'Unchecked_Access, Node));
 770          pragma Assert (Container.Length = Index_Max);
 771          pragma Assert (N (Node).Prev /= -1);
 772
 773          Node := N (Node).Next;
 774          Index := Index + 1;
 775
 776          if Index = Index_Max then
 777             pragma Assert (Node = 0);
 778             return;
 779          end if;
 780       end loop;
 781    end Iterate;
 782
 783    ----------
 784    -- Last --
 785    ----------
 786
 787    function Last (Container : List) return Cursor is
 788    begin
 789       if Container.Last = 0 then
 790          return No_Element;
 791       end if;
 792
 793       return Cursor'(Container'Unrestricted_Access, Container.Last);
 794    end Last;
 795
 796    ------------------
 797    -- Last_Element --
 798    ------------------
 799
 800    function Last_Element (Container : List) return Element_Type is
 801       N : Node_Array renames Container.Nodes;
 802
 803    begin
 804       if Container.Last = 0 then
 805          raise Constraint_Error;
 806       end if;
 807
 808       return N (Container.Last).Element;
 809    end Last_Element;
 810
 811    ------------
 812    -- Length --
 813    ------------
 814
 815    function Length (Container : List) return Count_Type is
 816    begin
 817       return Container.Length;
 818    end Length;
 819
 820    ----------
 821    -- Next --
 822    ----------
 823
 824    procedure Next (Position : in out Cursor) is
 825    begin
 826       Position := Next (Position);
 827    end Next;
 828
 829    function Next (Position : Cursor) return Cursor is
 830    begin
 831       if Position.Node = 0 then
 832          return No_Element;
 833       end if;
 834
 835       pragma Assert (Vet (Position), "bad cursor in Next");
 836
 837       declare
 838          Nodes : Node_Array renames Position.Container.Nodes;
 839          Node  : constant Count_Type := Nodes (Position.Node).Next;
 840
 841       begin
 842          if Node = 0 then
 843             return No_Element;
 844          end if;
 845
 846          return Cursor'(Position.Container, Node);
 847       end;
 848    end Next;
 849
 850    -------------
 851    -- Prepend --
 852    -------------
 853
 854    procedure Prepend
 855      (Container : in out List;
 856       New_Item  : Element_Type;
 857       Count     : Count_Type := 1)
 858    is
 859    begin
 860       Insert (Container, First (Container), New_Item, Count);
 861    end Prepend;
 862
 863    --------------
 864    -- Previous --
 865    --------------
 866
 867    procedure Previous (Position : in out Cursor) is
 868    begin
 869       Position := Previous (Position);
 870    end Previous;
 871
 872    function Previous (Position : Cursor) return Cursor is
 873    begin
 874       if Position.Node = 0 then
 875          return No_Element;
 876       end if;
 877
 878       pragma Assert (Vet (Position), "bad cursor in Previous");
 879
 880       declare
 881          Nodes : Node_Array renames Position.Container.Nodes;
 882          Node  : constant Count_Type := Nodes (Position.Node).Prev;
 883       begin
 884          if Node = 0 then
 885             return No_Element;
 886          end if;
 887
 888          return Cursor'(Position.Container, Node);
 889       end;
 890    end Previous;
 891
 892    -------------------
 893    -- Query_Element --
 894    -------------------
 895
 896    procedure Query_Element
 897      (Position : Cursor;
 898       Process  : not null access procedure (Element : Element_Type))
 899    is
 900    begin
 901       if Position.Node = 0 then
 902          raise Constraint_Error;
 903       end if;
 904
 905       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 906
 907       declare
 908          C : List renames Position.Container.all'Unrestricted_Access.all;
 909          N : Node_Type renames C.Nodes (Position.Node);
 910
 911       begin
 912          Process (N.Element);
 913          pragma Assert (N.Prev >= 0);
 914       end;
 915    end Query_Element;
 916
 917    ---------------------
 918    -- Replace_Element --
 919    ---------------------
 920
 921    procedure Replace_Element
 922      (Container : in out List;
 923       Position  : Cursor;
 924       New_Item  : Element_Type)
 925    is
 926    begin
 927       if Position.Container = null then
 928          raise Constraint_Error;
 929       end if;
 930
 931       if Position.Container /= Container'Unrestricted_Access then
 932          raise Program_Error;
 933       end if;
 934
 935 --    if Container.Lock > 0 then
 936 --       raise Program_Error;
 937 --    end if;
 938
 939       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 940
 941       declare
 942          N : Node_Array renames Container.Nodes;
 943       begin
 944          N (Position.Node).Element := New_Item;
 945       end;
 946    end Replace_Element;
 947
 948    ----------------------
 949    -- Reverse_Elements --
 950    ----------------------
 951
 952    procedure Reverse_Elements (Container : in out List) is
 953       N : Node_Array renames Container.Nodes;
 954       I : Count_Type := Container.First;
 955       J : Count_Type := Container.Last;
 956
 957       procedure Swap (L, R : Count_Type);
 958
 959       ----------
 960       -- Swap --
 961       ----------
 962
 963       procedure Swap (L, R : Count_Type) is
 964          LN : constant Count_Type := N (L).Next;
 965          LP : constant Count_Type := N (L).Prev;
 966
 967          RN : constant Count_Type := N (R).Next;
 968          RP : constant Count_Type := N (R).Prev;
 969
 970       begin
 971          if LP /= 0 then
 972             N (LP).Next := R;
 973          end if;
 974
 975          if RN /= 0 then
 976             N (RN).Prev := L;
 977          end if;
 978
 979          N (L).Next := RN;
 980          N (R).Prev := LP;
 981
 982          if LN = R then
 983             pragma Assert (RP = L);
 984
 985             N (L).Prev := R;
 986             N (R).Next := L;
 987
 988          else
 989             N (L).Prev := RP;
 990             N (RP).Next := L;
 991
 992             N (R).Next := LN;
 993             N (LN).Prev := R;
 994          end if;
 995       end Swap;
 996
 997    --  Start of processing for Reverse_Elements
 998
 999    begin
1000       if Container.Length <= 1 then
1001          return;
1002       end if;
1003
1004       pragma Assert (N (Container.First).Prev = 0);
1005       pragma Assert (N (Container.Last).Next = 0);
1006
1007 --    if Container.Busy > 0 then
1008 --       raise Program_Error;
1009 --    end if;
1010
1011       Container.First := J;
1012       Container.Last := I;
1013       loop
1014          Swap (L => I, R => J);
1015
1016          J := N (J).Next;
1017          exit when I = J;
1018
1019          I := N (I).Prev;
1020          exit when I = J;
1021
1022          Swap (L => J, R => I);
1023
1024          I := N (I).Next;
1025          exit when I = J;
1026
1027          J := N (J).Prev;
1028          exit when I = J;
1029       end loop;
1030
1031       pragma Assert (N (Container.First).Prev = 0);
1032       pragma Assert (N (Container.Last).Next = 0);
1033    end Reverse_Elements;
1034
1035    ------------------
1036    -- Reverse_Find --
1037    ------------------
1038
1039    function Reverse_Find
1040      (Container : List;
1041       Item      : Element_Type;
1042       Position  : Cursor := No_Element) return Cursor
1043    is
1044       N    : Node_Array renames Container.Nodes;
1045       Node : Count_Type := Position.Node;
1046
1047    begin
1048       if Node = 0 then
1049          Node := Container.Last;
1050
1051       else
1052          if Position.Container /= Container'Unrestricted_Access then
1053             raise Program_Error;
1054          end if;
1055
1056          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1057       end if;
1058
1059       while Node /= 0 loop
1060          if N (Node).Element = Item then
1061             return Cursor'(Container'Unrestricted_Access, Node);
1062          end if;
1063
1064          Node := N (Node).Prev;
1065       end loop;
1066
1067       return No_Element;
1068    end Reverse_Find;
1069
1070    ---------------------
1071    -- Reverse_Iterate --
1072    ---------------------
1073
1074    procedure Reverse_Iterate
1075      (Container : List;
1076       Process   : not null access procedure (Position : Cursor))
1077    is
1078       C : List renames Container'Unrestricted_Access.all;
1079       N : Node_Array renames C.Nodes;
1080 --    B : Natural renames C.Busy;
1081
1082       Node : Count_Type := Container.Last;
1083
1084       Index     : Count_Type := 0;
1085       Index_Max : constant Count_Type := Container.Length;
1086
1087    begin
1088       if Index_Max = 0 then
1089          pragma Assert (Node = 0);
1090          return;
1091       end if;
1092
1093       loop
1094          pragma Assert (Node > 0);
1095
1096          Process (Cursor'(C'Unchecked_Access, Node));
1097          pragma Assert (Container.Length = Index_Max);
1098          pragma Assert (N (Node).Prev /= -1);
1099
1100          Node := N (Node).Prev;
1101          Index := Index + 1;
1102
1103          if Index = Index_Max then
1104             pragma Assert (Node = 0);
1105             return;
1106          end if;
1107       end loop;
1108    end Reverse_Iterate;
1109
1110    ------------
1111    -- Splice --
1112    ------------
1113
1114    procedure Splice
1115      (Container : in out List;
1116       Before    : Cursor;
1117       Position  : in out Cursor)
1118    is
1119       N : Node_Array renames Container.Nodes;
1120
1121    begin
1122       if Before.Container /= null then
1123          if Before.Container /= Container'Unrestricted_Access then
1124             raise Program_Error;
1125          end if;
1126
1127          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1128       end if;
1129
1130       if Position.Node = 0 then
1131          raise Constraint_Error;
1132       end if;
1133
1134       if Position.Container /= Container'Unrestricted_Access then
1135          raise Program_Error;
1136       end if;
1137
1138       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1139
1140       if Position.Node = Before.Node
1141         or else N (Position.Node).Next = Before.Node
1142       then
1143          return;
1144       end if;
1145
1146       pragma Assert (Container.Length >= 2);
1147
1148 --    if Container.Busy > 0 then
1149 --       raise Program_Error;
1150 --    end if;
1151
1152       if Before.Node = 0 then
1153          pragma Assert (Position.Node /= Container.Last);
1154
1155          if Position.Node = Container.First then
1156             Container.First := N (Position.Node).Next;
1157             N (Container.First).Prev := 0;
1158
1159          else
1160             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1161             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1162          end if;
1163
1164          N (Container.Last).Next := Position.Node;
1165          N (Position.Node).Prev := Container.Last;
1166
1167          Container.Last := Position.Node;
1168          N (Container.Last).Next := 0;
1169
1170          return;
1171       end if;
1172
1173       if Before.Node = Container.First then
1174          pragma Assert (Position.Node /= Container.First);
1175
1176          if Position.Node = Container.Last then
1177             Container.Last := N (Position.Node).Prev;
1178             N (Container.Last).Next := 0;
1179
1180          else
1181             N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1182             N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1183          end if;
1184
1185          N (Container.First).Prev := Position.Node;
1186          N (Position.Node).Next := Container.First;
1187
1188          Container.First := Position.Node;
1189          N (Container.First).Prev := 0;
1190
1191          return;
1192       end if;
1193
1194       if Position.Node = Container.First then
1195          Container.First := N (Position.Node).Next;
1196          N (Container.First).Prev := 0;
1197
1198       elsif Position.Node = Container.Last then
1199          Container.Last := N (Position.Node).Prev;
1200          N (Container.Last).Next := 0;
1201
1202       else
1203          N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1204          N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1205       end if;
1206
1207       N (N (Before.Node).Prev).Next := Position.Node;
1208       N (Position.Node).Prev := N (Before.Node).Prev;
1209
1210       N (Before.Node).Prev := Position.Node;
1211       N (Position.Node).Next := Before.Node;
1212
1213       pragma Assert (N (Container.First).Prev = 0);
1214       pragma Assert (N (Container.Last).Next = 0);
1215    end Splice;
1216
1217    ----------
1218    -- Swap --
1219    ----------
1220
1221    procedure Swap
1222      (Container : in out List;
1223       I, J      : Cursor)
1224    is
1225    begin
1226       if I.Node = 0
1227         or else J.Node = 0
1228       then
1229          raise Constraint_Error;
1230       end if;
1231
1232       if I.Container /= Container'Unrestricted_Access
1233         or else J.Container /= Container'Unrestricted_Access
1234       then
1235          raise Program_Error;
1236       end if;
1237
1238       if I.Node = J.Node then
1239          return;
1240       end if;
1241
1242 --    if Container.Lock > 0 then
1243 --       raise Program_Error;
1244 --    end if;
1245
1246       pragma Assert (Vet (I), "bad I cursor in Swap");
1247       pragma Assert (Vet (J), "bad J cursor in Swap");
1248
1249       declare
1250          N  : Node_Array renames Container.Nodes;
1251
1252          EI : Element_Type renames N (I.Node).Element;
1253          EJ : Element_Type renames N (J.Node).Element;
1254
1255          EI_Copy : constant Element_Type := EI;
1256
1257       begin
1258          EI := EJ;
1259          EJ := EI_Copy;
1260       end;
1261    end Swap;
1262
1263    ----------------
1264    -- Swap_Links --
1265    ----------------
1266
1267    procedure Swap_Links
1268      (Container : in out List;
1269       I, J      : Cursor)
1270    is
1271    begin
1272       if I.Node = 0
1273         or else J.Node = 0
1274       then
1275          raise Constraint_Error;
1276       end if;
1277
1278       if I.Container /= Container'Unrestricted_Access
1279         or else I.Container /= J.Container
1280       then
1281          raise Program_Error;
1282       end if;
1283
1284       if I.Node = J.Node then
1285          return;
1286       end if;
1287
1288 --    if Container.Busy > 0 then
1289 --       raise Program_Error;
1290 --    end if;
1291
1292       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1293       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1294
1295       declare
1296          I_Next : constant Cursor := Next (I);
1297
1298          J_Copy : Cursor := J;
1299          pragma Warnings (Off, J_Copy);
1300
1301       begin
1302          if I_Next = J then
1303             Splice (Container, Before => I, Position => J_Copy);
1304
1305          else
1306             declare
1307                J_Next : constant Cursor := Next (J);
1308
1309                I_Copy : Cursor := I;
1310                pragma Warnings (Off, I_Copy);
1311
1312             begin
1313                if J_Next = I then
1314                   Splice (Container, Before => J, Position => I_Copy);
1315
1316                else
1317                   pragma Assert (Container.Length >= 3);
1318
1319                   Splice (Container, Before => I_Next, Position => J_Copy);
1320                   Splice (Container, Before => J_Next, Position => I_Copy);
1321                end if;
1322             end;
1323          end if;
1324       end;
1325    end Swap_Links;
1326
1327    --------------------
1328    -- Update_Element --
1329    --------------------
1330
1331    procedure Update_Element
1332      (Container : in out List;
1333       Position  : Cursor;
1334       Process   : not null access procedure (Element : in out Element_Type))
1335    is
1336    begin
1337       if Position.Node = 0 then
1338          raise Constraint_Error;
1339       end if;
1340
1341       if Position.Container /= Container'Unrestricted_Access then
1342          raise Program_Error;
1343       end if;
1344
1345       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1346
1347       declare
1348          N  : Node_Type renames Container.Nodes (Position.Node);
1349
1350       begin
1351          Process (N.Element);
1352          pragma Assert (N.Prev >= 0);
1353       end;
1354    end Update_Element;
1355
1356    ---------
1357    -- Vet --
1358    ---------
1359
1360    function Vet (Position : Cursor) return Boolean is
1361    begin
1362       if Position.Node = 0 then
1363          return Position.Container = null;
1364       end if;
1365
1366       if Position.Container = null then
1367          return False;
1368       end if;
1369
1370       declare
1371          L : List renames Position.Container.all;
1372          N : Node_Array renames L.Nodes;
1373
1374       begin
1375          if L.Length = 0 then
1376             return False;
1377          end if;
1378
1379          if L.First = 0 then
1380             return False;
1381          end if;
1382
1383          if L.Last = 0 then
1384             return False;
1385          end if;
1386
1387          if Position.Node > L.Capacity then
1388             return False;
1389          end if;
1390
1391          if N (Position.Node).Prev < 0
1392            or else N (Position.Node).Prev > L.Capacity
1393          then
1394             return False;
1395          end if;
1396
1397          if N (Position.Node).Next > L.Capacity then
1398             return False;
1399          end if;
1400
1401          if N (L.First).Prev /= 0 then
1402             return False;
1403          end if;
1404
1405          if N (L.Last).Next /= 0 then
1406             return False;
1407          end if;
1408
1409          if N (Position.Node).Prev = 0
1410            and then Position.Node /= L.First
1411          then
1412             return False;
1413          end if;
1414
1415          if N (Position.Node).Next = 0
1416            and then Position.Node /= L.Last
1417          then
1418             return False;
1419          end if;
1420
1421          if L.Length = 1 then
1422             return L.First = L.Last;
1423          end if;
1424
1425          if L.First = L.Last then
1426             return False;
1427          end if;
1428
1429          if N (L.First).Next = 0 then
1430             return False;
1431          end if;
1432
1433          if N (L.Last).Prev = 0 then
1434             return False;
1435          end if;
1436
1437          if N (N (L.First).Next).Prev /= L.First then
1438             return False;
1439          end if;
1440
1441          if N (N (L.Last).Prev).Next /= L.Last then
1442             return False;
1443          end if;
1444
1445          if L.Length = 2 then
1446             if N (L.First).Next /= L.Last then
1447                return False;
1448             end if;
1449
1450             if N (L.Last).Prev /= L.First then
1451                return False;
1452             end if;
1453
1454             return True;
1455          end if;
1456
1457          if N (L.First).Next = L.Last then
1458             return False;
1459          end if;
1460
1461          if N (L.Last).Prev = L.First then
1462             return False;
1463          end if;
1464
1465          if Position.Node = L.First then
1466             return True;
1467          end if;
1468
1469          if Position.Node = L.Last then
1470             return True;
1471          end if;
1472
1473          if N (Position.Node).Next = 0 then
1474             return False;
1475          end if;
1476
1477          if N (Position.Node).Prev = 0 then
1478             return False;
1479          end if;
1480
1481          if N (N (Position.Node).Next).Prev /= Position.Node then
1482             return False;
1483          end if;
1484
1485          if N (N (Position.Node).Prev).Next /= Position.Node then
1486             return False;
1487          end if;
1488
1489          if L.Length = 3 then
1490             if N (L.First).Next /= Position.Node then
1491                return False;
1492             end if;
1493
1494             if N (L.Last).Prev /= Position.Node then
1495                return False;
1496             end if;
1497          end if;
1498
1499          return True;
1500       end;
1501    end Vet;
1502
1503 end Ada.Containers.Restricted_Doubly_Linked_Lists;