gcc/ada/a-cdlili.adb

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