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