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-2010, 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 cursors (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 cursors (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 cursors (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 cursors (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 cursors 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 cursors 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 : constant Node_Access :=
 609                       (if Front = null then Container.First else Front.Next);
 610          begin
 611             if Pivot /= Back then
 612                Partition (Pivot, Back);
 613                Sort (Front, Pivot);
 614                Sort (Pivot, Back);
 615             end if;
 616          end Sort;
 617
 618       --  Start of processing for Sort
 619
 620       begin
 621          if Container.Length <= 1 then
 622             return;
 623          end if;
 624
 625          pragma Assert (Container.First.Prev = null);
 626          pragma Assert (Container.Last.Next = null);
 627
 628          if Container.Busy > 0 then
 629             raise Program_Error with
 630               "attempt to tamper with cursors (list is busy)";
 631          end if;
 632
 633          Sort (Front => null, Back => null);
 634
 635          pragma Assert (Container.First.Prev = null);
 636          pragma Assert (Container.Last.Next = null);
 637       end Sort;
 638
 639    end Generic_Sorting;
 640
 641    -----------------
 642    -- Has_Element --
 643    -----------------
 644
 645    function Has_Element (Position : Cursor) return Boolean is
 646    begin
 647       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 648       return Position.Node /= null;
 649    end Has_Element;
 650
 651    ------------
 652    -- Insert --
 653    ------------
 654
 655    procedure Insert
 656      (Container : in out List;
 657       Before    : Cursor;
 658       New_Item  : Element_Type;
 659       Position  : out Cursor;
 660       Count     : Count_Type := 1)
 661    is
 662       New_Node : Node_Access;
 663
 664    begin
 665       if Before.Container /= null then
 666          if Before.Container /= Container'Unrestricted_Access then
 667             raise Program_Error with
 668               "attempt to tamper with cursors (list is busy)";
 669          end if;
 670
 671          if Before.Node = null
 672            or else Before.Node.Element = null
 673          then
 674             raise Program_Error with
 675               "Before cursor has no element";
 676          end if;
 677
 678          pragma Assert (Vet (Before), "bad cursor in Insert");
 679       end if;
 680
 681       if Count = 0 then
 682          Position := Before;
 683          return;
 684       end if;
 685
 686       if Container.Length > Count_Type'Last - Count then
 687          raise Constraint_Error with "new length exceeds maximum";
 688       end if;
 689
 690       if Container.Busy > 0 then
 691          raise Program_Error with
 692            "attempt to tamper with cursors (list is busy)";
 693       end if;
 694
 695       declare
 696          Element : Element_Access := new Element_Type'(New_Item);
 697       begin
 698          New_Node := new Node_Type'(Element, null, null);
 699       exception
 700          when others =>
 701             Free (Element);
 702             raise;
 703       end;
 704
 705       Insert_Internal (Container, Before.Node, New_Node);
 706       Position := Cursor'(Container'Unchecked_Access, New_Node);
 707
 708       for J in Count_Type'(2) .. Count loop
 709
 710          declare
 711             Element : Element_Access := new Element_Type'(New_Item);
 712          begin
 713             New_Node := new Node_Type'(Element, null, null);
 714          exception
 715             when others =>
 716                Free (Element);
 717                raise;
 718          end;
 719
 720          Insert_Internal (Container, Before.Node, New_Node);
 721       end loop;
 722    end Insert;
 723
 724    procedure Insert
 725      (Container : in out List;
 726       Before    : Cursor;
 727       New_Item  : Element_Type;
 728       Count     : Count_Type := 1)
 729    is
 730       Position : Cursor;
 731       pragma Unreferenced (Position);
 732    begin
 733       Insert (Container, Before, New_Item, Position, Count);
 734    end Insert;
 735
 736    ---------------------
 737    -- Insert_Internal --
 738    ---------------------
 739
 740    procedure Insert_Internal
 741      (Container : in out List;
 742       Before    : Node_Access;
 743       New_Node  : Node_Access)
 744    is
 745    begin
 746       if Container.Length = 0 then
 747          pragma Assert (Before = null);
 748          pragma Assert (Container.First = null);
 749          pragma Assert (Container.Last = null);
 750
 751          Container.First := New_Node;
 752          Container.Last := New_Node;
 753
 754       elsif Before = null then
 755          pragma Assert (Container.Last.Next = null);
 756
 757          Container.Last.Next := New_Node;
 758          New_Node.Prev := Container.Last;
 759
 760          Container.Last := New_Node;
 761
 762       elsif Before = Container.First then
 763          pragma Assert (Container.First.Prev = null);
 764
 765          Container.First.Prev := New_Node;
 766          New_Node.Next := Container.First;
 767
 768          Container.First := New_Node;
 769
 770       else
 771          pragma Assert (Container.First.Prev = null);
 772          pragma Assert (Container.Last.Next = null);
 773
 774          New_Node.Next := Before;
 775          New_Node.Prev := Before.Prev;
 776
 777          Before.Prev.Next := New_Node;
 778          Before.Prev := New_Node;
 779       end if;
 780
 781       Container.Length := Container.Length + 1;
 782    end Insert_Internal;
 783
 784    --------------
 785    -- Is_Empty --
 786    --------------
 787
 788    function Is_Empty (Container : List) return Boolean is
 789    begin
 790       return Container.Length = 0;
 791    end Is_Empty;
 792
 793    -------------
 794    -- Iterate --
 795    -------------
 796
 797    procedure Iterate
 798      (Container : List;
 799       Process   : not null access procedure (Position : Cursor))
 800    is
 801       C : List renames Container'Unrestricted_Access.all;
 802       B : Natural renames C.Busy;
 803
 804       Node : Node_Access := Container.First;
 805
 806    begin
 807       B := B + 1;
 808
 809       begin
 810          while Node /= null loop
 811             Process (Cursor'(Container'Unchecked_Access, Node));
 812             Node := Node.Next;
 813          end loop;
 814       exception
 815          when others =>
 816             B := B - 1;
 817             raise;
 818       end;
 819
 820       B := B - 1;
 821    end Iterate;
 822
 823    ----------
 824    -- Last --
 825    ----------
 826
 827    function Last (Container : List) return Cursor is
 828    begin
 829       if Container.Last = null then
 830          return No_Element;
 831       end if;
 832
 833       return Cursor'(Container'Unchecked_Access, Container.Last);
 834    end Last;
 835
 836    ------------------
 837    -- Last_Element --
 838    ------------------
 839
 840    function Last_Element (Container : List) return Element_Type is
 841    begin
 842       if Container.Last = null then
 843          raise Constraint_Error with "list is empty";
 844       end if;
 845
 846       return Container.Last.Element.all;
 847    end Last_Element;
 848
 849    ------------
 850    -- Length --
 851    ------------
 852
 853    function Length (Container : List) return Count_Type is
 854    begin
 855       return Container.Length;
 856    end Length;
 857
 858    ----------
 859    -- Move --
 860    ----------
 861
 862    procedure Move (Target : in out List; Source : in out List) is
 863    begin
 864       if Target'Address = Source'Address then
 865          return;
 866       end if;
 867
 868       if Source.Busy > 0 then
 869          raise Program_Error with
 870            "attempt to tamper with cursors of Source (list is busy)";
 871       end if;
 872
 873       Clear (Target);
 874
 875       Target.First := Source.First;
 876       Source.First := null;
 877
 878       Target.Last := Source.Last;
 879       Source.Last := null;
 880
 881       Target.Length := Source.Length;
 882       Source.Length := 0;
 883    end Move;
 884
 885    ----------
 886    -- Next --
 887    ----------
 888
 889    procedure Next (Position : in out Cursor) is
 890    begin
 891       Position := Next (Position);
 892    end Next;
 893
 894    function Next (Position : Cursor) return Cursor is
 895    begin
 896       if Position.Node = null then
 897          return No_Element;
 898       end if;
 899
 900       pragma Assert (Vet (Position), "bad cursor in Next");
 901
 902       declare
 903          Next_Node : constant Node_Access := Position.Node.Next;
 904       begin
 905          if Next_Node = null then
 906             return No_Element;
 907          end if;
 908
 909          return Cursor'(Position.Container, Next_Node);
 910       end;
 911    end Next;
 912
 913    -------------
 914    -- Prepend --
 915    -------------
 916
 917    procedure Prepend
 918      (Container : in out List;
 919       New_Item  : Element_Type;
 920       Count     : Count_Type := 1)
 921    is
 922    begin
 923       Insert (Container, First (Container), New_Item, Count);
 924    end Prepend;
 925
 926    --------------
 927    -- Previous --
 928    --------------
 929
 930    procedure Previous (Position : in out Cursor) is
 931    begin
 932       Position := Previous (Position);
 933    end Previous;
 934
 935    function Previous (Position : Cursor) return Cursor is
 936    begin
 937       if Position.Node = null then
 938          return No_Element;
 939       end if;
 940
 941       pragma Assert (Vet (Position), "bad cursor in Previous");
 942
 943       declare
 944          Prev_Node : constant Node_Access := Position.Node.Prev;
 945       begin
 946          if Prev_Node = null then
 947             return No_Element;
 948          end if;
 949
 950          return Cursor'(Position.Container, Prev_Node);
 951       end;
 952    end Previous;
 953
 954    -------------------
 955    -- Query_Element --
 956    -------------------
 957
 958    procedure Query_Element
 959      (Position : Cursor;
 960       Process  : not null access procedure (Element : Element_Type))
 961    is
 962    begin
 963       if Position.Node = null then
 964          raise Constraint_Error with
 965            "Position cursor has no element";
 966       end if;
 967
 968       if Position.Node.Element = null then
 969          raise Program_Error with
 970            "Position cursor has no element";
 971       end if;
 972
 973       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 974
 975       declare
 976          C : List renames Position.Container.all'Unrestricted_Access.all;
 977          B : Natural renames C.Busy;
 978          L : Natural renames C.Lock;
 979
 980       begin
 981          B := B + 1;
 982          L := L + 1;
 983
 984          begin
 985             Process (Position.Node.Element.all);
 986          exception
 987             when others =>
 988                L := L - 1;
 989                B := B - 1;
 990                raise;
 991          end;
 992
 993          L := L - 1;
 994          B := B - 1;
 995       end;
 996    end Query_Element;
 997
 998    ----------
 999    -- Read --
1000    ----------
1001
1002    procedure Read
1003      (Stream : not null access Root_Stream_Type'Class;
1004       Item   : out List)
1005    is
1006       N   : Count_Type'Base;
1007       Dst : Node_Access;
1008
1009    begin
1010       Clear (Item);
1011
1012       Count_Type'Base'Read (Stream, N);
1013
1014       if N = 0 then
1015          return;
1016       end if;
1017
1018       declare
1019          Element : Element_Access :=
1020                      new Element_Type'(Element_Type'Input (Stream));
1021       begin
1022          Dst := new Node_Type'(Element, null, null);
1023       exception
1024          when others =>
1025             Free (Element);
1026             raise;
1027       end;
1028
1029       Item.First := Dst;
1030       Item.Last := Dst;
1031       Item.Length := 1;
1032
1033       while Item.Length < N loop
1034          declare
1035             Element : Element_Access :=
1036                         new Element_Type'(Element_Type'Input (Stream));
1037          begin
1038             Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1039          exception
1040             when others =>
1041                Free (Element);
1042                raise;
1043          end;
1044
1045          Item.Last.Next := Dst;
1046          Item.Last := Dst;
1047          Item.Length := Item.Length + 1;
1048       end loop;
1049    end Read;
1050
1051    procedure Read
1052      (Stream : not null access Root_Stream_Type'Class;
1053       Item   : out Cursor)
1054    is
1055    begin
1056       raise Program_Error with "attempt to stream list cursor";
1057    end Read;
1058
1059    ---------------------
1060    -- Replace_Element --
1061    ---------------------
1062
1063    procedure Replace_Element
1064      (Container : in out List;
1065       Position  : Cursor;
1066       New_Item  : Element_Type)
1067    is
1068    begin
1069       if Position.Container = null then
1070          raise Constraint_Error with "Position cursor has no element";
1071       end if;
1072
1073       if Position.Container /= Container'Unchecked_Access then
1074          raise Program_Error with
1075            "Position cursor designates wrong container";
1076       end if;
1077
1078       if Container.Lock > 0 then
1079          raise Program_Error with
1080            "attempt to tamper with elements (list is locked)";
1081       end if;
1082
1083       if Position.Node.Element = null then
1084          raise Program_Error with
1085            "Position cursor has no element";
1086       end if;
1087
1088       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1089
1090       declare
1091          X : Element_Access := Position.Node.Element;
1092
1093       begin
1094          Position.Node.Element := new Element_Type'(New_Item);
1095          Free (X);
1096       end;
1097    end Replace_Element;
1098
1099    ----------------------
1100    -- Reverse_Elements --
1101    ----------------------
1102
1103    procedure Reverse_Elements (Container : in out List) is
1104       I : Node_Access := Container.First;
1105       J : Node_Access := Container.Last;
1106
1107       procedure Swap (L, R : Node_Access);
1108
1109       ----------
1110       -- Swap --
1111       ----------
1112
1113       procedure Swap (L, R : Node_Access) is
1114          LN : constant Node_Access := L.Next;
1115          LP : constant Node_Access := L.Prev;
1116
1117          RN : constant Node_Access := R.Next;
1118          RP : constant Node_Access := R.Prev;
1119
1120       begin
1121          if LP /= null then
1122             LP.Next := R;
1123          end if;
1124
1125          if RN /= null then
1126             RN.Prev := L;
1127          end if;
1128
1129          L.Next := RN;
1130          R.Prev := LP;
1131
1132          if LN = R then
1133             pragma Assert (RP = L);
1134
1135             L.Prev := R;
1136             R.Next := L;
1137
1138          else
1139             L.Prev := RP;
1140             RP.Next := L;
1141
1142             R.Next := LN;
1143             LN.Prev := R;
1144          end if;
1145       end Swap;
1146
1147    --  Start of processing for Reverse_Elements
1148
1149    begin
1150       if Container.Length <= 1 then
1151          return;
1152       end if;
1153
1154       pragma Assert (Container.First.Prev = null);
1155       pragma Assert (Container.Last.Next = null);
1156
1157       if Container.Busy > 0 then
1158          raise Program_Error with
1159            "attempt to tamper with cursors (list is busy)";
1160       end if;
1161
1162       Container.First := J;
1163       Container.Last := I;
1164       loop
1165          Swap (L => I, R => J);
1166
1167          J := J.Next;
1168          exit when I = J;
1169
1170          I := I.Prev;
1171          exit when I = J;
1172
1173          Swap (L => J, R => I);
1174
1175          I := I.Next;
1176          exit when I = J;
1177
1178          J := J.Prev;
1179          exit when I = J;
1180       end loop;
1181
1182       pragma Assert (Container.First.Prev = null);
1183       pragma Assert (Container.Last.Next = null);
1184    end Reverse_Elements;
1185
1186    ------------------
1187    -- Reverse_Find --
1188    ------------------
1189
1190    function Reverse_Find
1191      (Container : List;
1192       Item      : Element_Type;
1193       Position  : Cursor := No_Element) return Cursor
1194    is
1195       Node : Node_Access := Position.Node;
1196
1197    begin
1198       if Node = null then
1199          Node := Container.Last;
1200
1201       else
1202          if Node.Element = null then
1203             raise Program_Error with "Position cursor has no element";
1204          end if;
1205
1206          if Position.Container /= Container'Unrestricted_Access then
1207             raise Program_Error with
1208               "Position cursor designates wrong container";
1209          end if;
1210
1211          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1212       end if;
1213
1214       while Node /= null loop
1215          if Node.Element.all = Item then
1216             return Cursor'(Container'Unchecked_Access, Node);
1217          end if;
1218
1219          Node := Node.Prev;
1220       end loop;
1221
1222       return No_Element;
1223    end Reverse_Find;
1224
1225    ---------------------
1226    -- Reverse_Iterate --
1227    ---------------------
1228
1229    procedure Reverse_Iterate
1230      (Container : List;
1231       Process   : not null access procedure (Position : Cursor))
1232    is
1233       C : List renames Container'Unrestricted_Access.all;
1234       B : Natural renames C.Busy;
1235
1236       Node : Node_Access := Container.Last;
1237
1238    begin
1239       B := B + 1;
1240
1241       begin
1242          while Node /= null loop
1243             Process (Cursor'(Container'Unchecked_Access, Node));
1244             Node := Node.Prev;
1245          end loop;
1246       exception
1247          when others =>
1248             B := B - 1;
1249             raise;
1250       end;
1251
1252       B := B - 1;
1253    end Reverse_Iterate;
1254
1255    ------------
1256    -- Splice --
1257    ------------
1258
1259    procedure Splice
1260      (Target : in out List;
1261       Before : Cursor;
1262       Source : in out List)
1263    is
1264    begin
1265       if Before.Container /= null then
1266          if Before.Container /= Target'Unrestricted_Access then
1267             raise Program_Error with
1268               "Before cursor designates wrong container";
1269          end if;
1270
1271          if Before.Node = null
1272            or else Before.Node.Element = null
1273          then
1274             raise Program_Error with
1275               "Before cursor has no element";
1276          end if;
1277
1278          pragma Assert (Vet (Before), "bad cursor in Splice");
1279       end if;
1280
1281       if Target'Address = Source'Address
1282         or else Source.Length = 0
1283       then
1284          return;
1285       end if;
1286
1287       pragma Assert (Source.First.Prev = null);
1288       pragma Assert (Source.Last.Next = null);
1289
1290       if Target.Length > Count_Type'Last - Source.Length then
1291          raise Constraint_Error with "new length exceeds maximum";
1292       end if;
1293
1294       if Target.Busy > 0 then
1295          raise Program_Error with
1296            "attempt to tamper with cursors of Target (list is busy)";
1297       end if;
1298
1299       if Source.Busy > 0 then
1300          raise Program_Error with
1301            "attempt to tamper with cursors of Source (list is busy)";
1302       end if;
1303
1304       if Target.Length = 0 then
1305          pragma Assert (Before = No_Element);
1306          pragma Assert (Target.First = null);
1307          pragma Assert (Target.Last = null);
1308
1309          Target.First := Source.First;
1310          Target.Last := Source.Last;
1311
1312       elsif Before.Node = null then
1313          pragma Assert (Target.Last.Next = null);
1314
1315          Target.Last.Next := Source.First;
1316          Source.First.Prev := Target.Last;
1317
1318          Target.Last := Source.Last;
1319
1320       elsif Before.Node = Target.First then
1321          pragma Assert (Target.First.Prev = null);
1322
1323          Source.Last.Next := Target.First;
1324          Target.First.Prev := Source.Last;
1325
1326          Target.First := Source.First;
1327
1328       else
1329          pragma Assert (Target.Length >= 2);
1330          Before.Node.Prev.Next := Source.First;
1331          Source.First.Prev := Before.Node.Prev;
1332
1333          Before.Node.Prev := Source.Last;
1334          Source.Last.Next := Before.Node;
1335       end if;
1336
1337       Source.First := null;
1338       Source.Last := null;
1339
1340       Target.Length := Target.Length + Source.Length;
1341       Source.Length := 0;
1342    end Splice;
1343
1344    procedure Splice
1345      (Container : in out List;
1346       Before    : Cursor;
1347       Position  : Cursor)
1348    is
1349    begin
1350       if Before.Container /= null then
1351          if Before.Container /= Container'Unchecked_Access then
1352             raise Program_Error with
1353               "Before cursor designates wrong container";
1354          end if;
1355
1356          if Before.Node = null
1357            or else Before.Node.Element = null
1358          then
1359             raise Program_Error with
1360               "Before cursor has no element";
1361          end if;
1362
1363          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1364       end if;
1365
1366       if Position.Node = null then
1367          raise Constraint_Error with "Position cursor has no element";
1368       end if;
1369
1370       if Position.Node.Element = null then
1371          raise Program_Error with "Position cursor has no element";
1372       end if;
1373
1374       if Position.Container /= Container'Unrestricted_Access then
1375          raise Program_Error with
1376            "Position cursor designates wrong container";
1377       end if;
1378
1379       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1380
1381       if Position.Node = Before.Node
1382         or else Position.Node.Next = Before.Node
1383       then
1384          return;
1385       end if;
1386
1387       pragma Assert (Container.Length >= 2);
1388
1389       if Container.Busy > 0 then
1390          raise Program_Error with
1391            "attempt to tamper with cursors (list is busy)";
1392       end if;
1393
1394       if Before.Node = null then
1395          pragma Assert (Position.Node /= Container.Last);
1396
1397          if Position.Node = Container.First then
1398             Container.First := Position.Node.Next;
1399             Container.First.Prev := null;
1400          else
1401             Position.Node.Prev.Next := Position.Node.Next;
1402             Position.Node.Next.Prev := Position.Node.Prev;
1403          end if;
1404
1405          Container.Last.Next := Position.Node;
1406          Position.Node.Prev := Container.Last;
1407
1408          Container.Last := Position.Node;
1409          Container.Last.Next := null;
1410
1411          return;
1412       end if;
1413
1414       if Before.Node = Container.First then
1415          pragma Assert (Position.Node /= Container.First);
1416
1417          if Position.Node = Container.Last then
1418             Container.Last := Position.Node.Prev;
1419             Container.Last.Next := null;
1420          else
1421             Position.Node.Prev.Next := Position.Node.Next;
1422             Position.Node.Next.Prev := Position.Node.Prev;
1423          end if;
1424
1425          Container.First.Prev := Position.Node;
1426          Position.Node.Next := Container.First;
1427
1428          Container.First := Position.Node;
1429          Container.First.Prev := null;
1430
1431          return;
1432       end if;
1433
1434       if Position.Node = Container.First then
1435          Container.First := Position.Node.Next;
1436          Container.First.Prev := null;
1437
1438       elsif Position.Node = Container.Last then
1439          Container.Last := Position.Node.Prev;
1440          Container.Last.Next := null;
1441
1442       else
1443          Position.Node.Prev.Next := Position.Node.Next;
1444          Position.Node.Next.Prev := Position.Node.Prev;
1445       end if;
1446
1447       Before.Node.Prev.Next := Position.Node;
1448       Position.Node.Prev := Before.Node.Prev;
1449
1450       Before.Node.Prev := Position.Node;
1451       Position.Node.Next := Before.Node;
1452
1453       pragma Assert (Container.First.Prev = null);
1454       pragma Assert (Container.Last.Next = null);
1455    end Splice;
1456
1457    procedure Splice
1458      (Target   : in out List;
1459       Before   : Cursor;
1460       Source   : in out List;
1461       Position : in out Cursor)
1462    is
1463    begin
1464       if Target'Address = Source'Address then
1465          Splice (Target, Before, Position);
1466          return;
1467       end if;
1468
1469       if Before.Container /= null then
1470          if Before.Container /= Target'Unrestricted_Access then
1471             raise Program_Error with
1472               "Before cursor designates wrong container";
1473          end if;
1474
1475          if Before.Node = null
1476            or else Before.Node.Element = null
1477          then
1478             raise Program_Error with
1479               "Before cursor has no element";
1480          end if;
1481
1482          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1483       end if;
1484
1485       if Position.Node = null then
1486          raise Constraint_Error with "Position cursor has no element";
1487       end if;
1488
1489       if Position.Node.Element = null then
1490          raise Program_Error with
1491            "Position cursor has no element";
1492       end if;
1493
1494       if Position.Container /= Source'Unrestricted_Access then
1495          raise Program_Error with
1496            "Position cursor designates wrong container";
1497       end if;
1498
1499       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1500
1501       if Target.Length = Count_Type'Last then
1502          raise Constraint_Error with "Target is full";
1503       end if;
1504
1505       if Target.Busy > 0 then
1506          raise Program_Error with
1507            "attempt to tamper with cursors of Target (list is busy)";
1508       end if;
1509
1510       if Source.Busy > 0 then
1511          raise Program_Error with
1512            "attempt to tamper with cursors of Source (list is busy)";
1513       end if;
1514
1515       if Position.Node = Source.First then
1516          Source.First := Position.Node.Next;
1517
1518          if Position.Node = Source.Last then
1519             pragma Assert (Source.First = null);
1520             pragma Assert (Source.Length = 1);
1521             Source.Last := null;
1522
1523          else
1524             Source.First.Prev := null;
1525          end if;
1526
1527       elsif Position.Node = Source.Last then
1528          pragma Assert (Source.Length >= 2);
1529          Source.Last := Position.Node.Prev;
1530          Source.Last.Next := null;
1531
1532       else
1533          pragma Assert (Source.Length >= 3);
1534          Position.Node.Prev.Next := Position.Node.Next;
1535          Position.Node.Next.Prev := Position.Node.Prev;
1536       end if;
1537
1538       if Target.Length = 0 then
1539          pragma Assert (Before = No_Element);
1540          pragma Assert (Target.First = null);
1541          pragma Assert (Target.Last = null);
1542
1543          Target.First := Position.Node;
1544          Target.Last := Position.Node;
1545
1546          Target.First.Prev := null;
1547          Target.Last.Next := null;
1548
1549       elsif Before.Node = null then
1550          pragma Assert (Target.Last.Next = null);
1551          Target.Last.Next := Position.Node;
1552          Position.Node.Prev := Target.Last;
1553
1554          Target.Last := Position.Node;
1555          Target.Last.Next := null;
1556
1557       elsif Before.Node = Target.First then
1558          pragma Assert (Target.First.Prev = null);
1559          Target.First.Prev := Position.Node;
1560          Position.Node.Next := Target.First;
1561
1562          Target.First := Position.Node;
1563          Target.First.Prev := null;
1564
1565       else
1566          pragma Assert (Target.Length >= 2);
1567          Before.Node.Prev.Next := Position.Node;
1568          Position.Node.Prev := Before.Node.Prev;
1569
1570          Before.Node.Prev := Position.Node;
1571          Position.Node.Next := Before.Node;
1572       end if;
1573
1574       Target.Length := Target.Length + 1;
1575       Source.Length := Source.Length - 1;
1576
1577       Position.Container := Target'Unchecked_Access;
1578    end Splice;
1579
1580    ----------
1581    -- Swap --
1582    ----------
1583
1584    procedure Swap
1585      (Container : in out List;
1586       I, J      : Cursor)
1587    is
1588    begin
1589       if I.Node = null then
1590          raise Constraint_Error with "I cursor has no element";
1591       end if;
1592
1593       if J.Node = null then
1594          raise Constraint_Error with "J cursor has no element";
1595       end if;
1596
1597       if I.Container /= Container'Unchecked_Access then
1598          raise Program_Error with "I cursor designates wrong container";
1599       end if;
1600
1601       if J.Container /= Container'Unchecked_Access then
1602          raise Program_Error with "J cursor designates wrong container";
1603       end if;
1604
1605       if I.Node = J.Node then
1606          return;
1607       end if;
1608
1609       if Container.Lock > 0 then
1610          raise Program_Error with
1611            "attempt to tamper with elements (list is locked)";
1612       end if;
1613
1614       pragma Assert (Vet (I), "bad I cursor in Swap");
1615       pragma Assert (Vet (J), "bad J cursor in Swap");
1616
1617       declare
1618          EI_Copy : constant Element_Access := I.Node.Element;
1619
1620       begin
1621          I.Node.Element := J.Node.Element;
1622          J.Node.Element := EI_Copy;
1623       end;
1624    end Swap;
1625
1626    ----------------
1627    -- Swap_Links --
1628    ----------------
1629
1630    procedure Swap_Links
1631      (Container : in out List;
1632       I, J      : Cursor)
1633    is
1634    begin
1635       if I.Node = null then
1636          raise Constraint_Error with "I cursor has no element";
1637       end if;
1638
1639       if J.Node = null then
1640          raise Constraint_Error with "J cursor has no element";
1641       end if;
1642
1643       if I.Container /= Container'Unrestricted_Access then
1644          raise Program_Error with "I cursor designates wrong container";
1645       end if;
1646
1647       if J.Container /= Container'Unrestricted_Access then
1648          raise Program_Error with "J cursor designates wrong container";
1649       end if;
1650
1651       if I.Node = J.Node then
1652          return;
1653       end if;
1654
1655       if Container.Busy > 0 then
1656          raise Program_Error with
1657            "attempt to tamper with cursors (list is busy)";
1658       end if;
1659
1660       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1661       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1662
1663       declare
1664          I_Next : constant Cursor := Next (I);
1665
1666       begin
1667          if I_Next = J then
1668             Splice (Container, Before => I, Position => J);
1669
1670          else
1671             declare
1672                J_Next : constant Cursor := Next (J);
1673
1674             begin
1675                if J_Next = I then
1676                   Splice (Container, Before => J, Position => I);
1677
1678                else
1679                   pragma Assert (Container.Length >= 3);
1680
1681                   Splice (Container, Before => I_Next, Position => J);
1682                   Splice (Container, Before => J_Next, Position => I);
1683                end if;
1684             end;
1685          end if;
1686       end;
1687
1688       pragma Assert (Container.First.Prev = null);
1689       pragma Assert (Container.Last.Next = null);
1690    end Swap_Links;
1691
1692    --------------------
1693    -- Update_Element --
1694    --------------------
1695
1696    procedure Update_Element
1697      (Container : in out List;
1698       Position  : Cursor;
1699       Process   : not null access procedure (Element : in out Element_Type))
1700    is
1701    begin
1702       if Position.Node = null then
1703          raise Constraint_Error with "Position cursor has no element";
1704       end if;
1705
1706       if Position.Node.Element = null then
1707          raise Program_Error with
1708            "Position cursor has no element";
1709       end if;
1710
1711       if Position.Container /= Container'Unchecked_Access then
1712          raise Program_Error with
1713            "Position cursor designates wrong container";
1714       end if;
1715
1716       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1717
1718       declare
1719          B : Natural renames Container.Busy;
1720          L : Natural renames Container.Lock;
1721
1722       begin
1723          B := B + 1;
1724          L := L + 1;
1725
1726          begin
1727             Process (Position.Node.Element.all);
1728          exception
1729             when others =>
1730                L := L - 1;
1731                B := B - 1;
1732                raise;
1733          end;
1734
1735          L := L - 1;
1736          B := B - 1;
1737       end;
1738    end Update_Element;
1739
1740    ---------
1741    -- Vet --
1742    ---------
1743
1744    function Vet (Position : Cursor) return Boolean is
1745    begin
1746       if Position.Node = null then
1747          return Position.Container = null;
1748       end if;
1749
1750       if Position.Container = null then
1751          return False;
1752       end if;
1753
1754       if Position.Node.Next = Position.Node then
1755          return False;
1756       end if;
1757
1758       if Position.Node.Prev = Position.Node then
1759          return False;
1760       end if;
1761
1762       if Position.Node.Element = null then
1763          return False;
1764       end if;
1765
1766       declare
1767          L : List renames Position.Container.all;
1768       begin
1769          if L.Length = 0 then
1770             return False;
1771          end if;
1772
1773          if L.First = null then
1774             return False;
1775          end if;
1776
1777          if L.Last = null then
1778             return False;
1779          end if;
1780
1781          if L.First.Prev /= null then
1782             return False;
1783          end if;
1784
1785          if L.Last.Next /= null then
1786             return False;
1787          end if;
1788
1789          if Position.Node.Prev = null
1790            and then Position.Node /= L.First
1791          then
1792             return False;
1793          end if;
1794
1795          if Position.Node.Next = null
1796            and then Position.Node /= L.Last
1797          then
1798             return False;
1799          end if;
1800
1801          if L.Length = 1 then
1802             return L.First = L.Last;
1803          end if;
1804
1805          if L.First = L.Last then
1806             return False;
1807          end if;
1808
1809          if L.First.Next = null then
1810             return False;
1811          end if;
1812
1813          if L.Last.Prev = null then
1814             return False;
1815          end if;
1816
1817          if L.First.Next.Prev /= L.First then
1818             return False;
1819          end if;
1820
1821          if L.Last.Prev.Next /= L.Last then
1822             return False;
1823          end if;
1824
1825          if L.Length = 2 then
1826             if L.First.Next /= L.Last then
1827                return False;
1828             end if;
1829
1830             if L.Last.Prev /= L.First then
1831                return False;
1832             end if;
1833
1834             return True;
1835          end if;
1836
1837          if L.First.Next = L.Last then
1838             return False;
1839          end if;
1840
1841          if L.Last.Prev = L.First then
1842             return False;
1843          end if;
1844
1845          if Position.Node = L.First then
1846             return True;
1847          end if;
1848
1849          if Position.Node = L.Last then
1850             return True;
1851          end if;
1852
1853          if Position.Node.Next = null then
1854             return False;
1855          end if;
1856
1857          if Position.Node.Prev = null then
1858             return False;
1859          end if;
1860
1861          if Position.Node.Next.Prev /= Position.Node then
1862             return False;
1863          end if;
1864
1865          if Position.Node.Prev.Next /= Position.Node then
1866             return False;
1867          end if;
1868
1869          if L.Length = 3 then
1870             if L.First.Next /= Position.Node then
1871                return False;
1872             end if;
1873
1874             if L.Last.Prev /= Position.Node then
1875                return False;
1876             end if;
1877          end if;
1878
1879          return True;
1880       end;
1881    end Vet;
1882
1883    -----------
1884    -- Write --
1885    -----------
1886
1887    procedure Write
1888      (Stream : not null access Root_Stream_Type'Class;
1889       Item   : List)
1890    is
1891       Node : Node_Access := Item.First;
1892
1893    begin
1894       Count_Type'Base'Write (Stream, Item.Length);
1895
1896       while Node /= null loop
1897          Element_Type'Output (Stream, Node.Element.all);
1898          Node := Node.Next;
1899       end loop;
1900    end Write;
1901
1902    procedure Write
1903      (Stream : not null access Root_Stream_Type'Class;
1904       Item   : Cursor)
1905    is
1906    begin
1907       raise Program_Error with "attempt to stream list cursor";
1908    end Write;
1909
1910 end Ada.Containers.Indefinite_Doubly_Linked_Lists;