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