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