gcc/ada/a-cidlli.adb

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