gcc/ada/a-cidlli.adb

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