gcc/ada/a-cidlli.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      A D A . C O N T A I N E R S .                       --
   6 --        I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S       --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2006, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 with System;  use type System.Address;
  34 with Ada.Unchecked_Deallocation;
  35
  36 package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
  37
  38    procedure Free is
  39      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    procedure Free (X : in out Node_Access);
  46
  47    procedure Insert_Internal
  48      (Container : in out List;
  49       Before    : Node_Access;
  50       New_Node  : Node_Access);
  51
  52    function Vet (Position : Cursor) return Boolean;
  53
  54    ---------
  55    -- "=" --
  56    ---------
  57
  58    function "=" (Left, Right : List) return Boolean is
  59       L : Node_Access;
  60       R : Node_Access;
  61
  62    begin
  63       if Left'Address = Right'Address then
  64          return True;
  65       end if;
  66
  67       if Left.Length /= Right.Length then
  68          return False;
  69       end if;
  70
  71       L := Left.First;
  72       R := Right.First;
  73       for J in 1 .. Left.Length loop
  74          if L.Element.all /= R.Element.all then
  75             return False;
  76          end if;
  77
  78          L := L.Next;
  79          R := R.Next;
  80       end loop;
  81
  82       return True;
  83    end "=";
  84
  85    ------------
  86    -- Adjust --
  87    ------------
  88
  89    procedure Adjust (Container : in out List) is
  90       Src : Node_Access := Container.First;
  91       Dst : Node_Access;
  92
  93    begin
  94       if Src = null then
  95          pragma Assert (Container.Last = null);
  96          pragma Assert (Container.Length = 0);
  97          pragma Assert (Container.Busy = 0);
  98          pragma Assert (Container.Lock = 0);
  99          return;
 100       end if;
 101
 102       pragma Assert (Container.First.Prev = null);
 103       pragma Assert (Container.Last.Next = null);
 104       pragma Assert (Container.Length > 0);
 105
 106       Container.First := null;
 107       Container.Last := null;
 108       Container.Length := 0;
 109       Container.Busy := 0;
 110       Container.Lock := 0;
 111
 112       declare
 113          Element : Element_Access := new Element_Type'(Src.Element.all);
 114       begin
 115          Dst := new Node_Type'(Element, null, null);
 116       exception
 117          when others =>
 118             Free (Element);
 119             raise;
 120       end;
 121
 122       Container.First := Dst;
 123       Container.Last := Dst;
 124       Container.Length := 1;
 125
 126       Src := Src.Next;
 127       while Src /= null loop
 128          declare
 129             Element : Element_Access := new Element_Type'(Src.Element.all);
 130          begin
 131             Dst := new Node_Type'(Element, null, Prev => Container.Last);
 132          exception
 133             when others =>
 134                Free (Element);
 135                raise;
 136          end;
 137
 138          Container.Last.Next := Dst;
 139          Container.Last := Dst;
 140          Container.Length := Container.Length + 1;
 141
 142          Src := Src.Next;
 143       end loop;
 144    end Adjust;
 145
 146    ------------
 147    -- Append --
 148    ------------
 149
 150    procedure Append
 151      (Container : in out List;
 152       New_Item  : Element_Type;
 153       Count     : Count_Type := 1)
 154    is
 155    begin
 156       Insert (Container, No_Element, New_Item, Count);
 157    end Append;
 158
 159    -----------
 160    -- Clear --
 161    -----------
 162
 163    procedure Clear (Container : in out List) is
 164       X : Node_Access;
 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                begin
 543                   RI.Node := RI.Node.Next;
 544                   Splice (Target, LI, Source, RJ);
 545                end;
 546
 547             else
 548                LI.Node := LI.Node.Next;
 549             end if;
 550          end loop;
 551       end Merge;
 552
 553       ----------
 554       -- Sort --
 555       ----------
 556
 557       procedure Sort (Container : in out List) is
 558          procedure Partition (Pivot : Node_Access; Back  : Node_Access);
 559
 560          procedure Sort (Front, Back : Node_Access);
 561
 562          ---------------
 563          -- Partition --
 564          ---------------
 565
 566          procedure Partition (Pivot : Node_Access; Back : Node_Access) is
 567             Node : Node_Access := Pivot.Next;
 568
 569          begin
 570             while Node /= Back loop
 571                if Node.Element.all < Pivot.Element.all then
 572                   declare
 573                      Prev : constant Node_Access := Node.Prev;
 574                      Next : constant Node_Access := Node.Next;
 575                   begin
 576                      Prev.Next := Next;
 577
 578                      if Next = null then
 579                         Container.Last := Prev;
 580                      else
 581                         Next.Prev := Prev;
 582                      end if;
 583
 584                      Node.Next := Pivot;
 585                      Node.Prev := Pivot.Prev;
 586
 587                      Pivot.Prev := Node;
 588
 589                      if Node.Prev = null then
 590                         Container.First := Node;
 591                      else
 592                         Node.Prev.Next := Node;
 593                      end if;
 594
 595                      Node := Next;
 596                   end;
 597
 598                else
 599                   Node := Node.Next;
 600                end if;
 601             end loop;
 602          end Partition;
 603
 604          ----------
 605          -- Sort --
 606          ----------
 607
 608          procedure Sort (Front, Back : Node_Access) is
 609             Pivot : Node_Access;
 610
 611          begin
 612             if Front = null then
 613                Pivot := Container.First;
 614             else
 615                Pivot := Front.Next;
 616             end if;
 617
 618             if Pivot /= Back then
 619                Partition (Pivot, Back);
 620                Sort (Front, Pivot);
 621                Sort (Pivot, Back);
 622             end if;
 623          end Sort;
 624
 625       --  Start of processing for Sort
 626
 627       begin
 628          if Container.Length <= 1 then
 629             return;
 630          end if;
 631
 632          pragma Assert (Container.First.Prev = null);
 633          pragma Assert (Container.Last.Next = null);
 634
 635          if Container.Busy > 0 then
 636             raise Program_Error with
 637               "attempt to tamper with elements (list is busy)";
 638          end if;
 639
 640          Sort (Front => null, Back => null);
 641
 642          pragma Assert (Container.First.Prev = null);
 643          pragma Assert (Container.Last.Next = null);
 644       end Sort;
 645
 646    end Generic_Sorting;
 647
 648    -----------------
 649    -- Has_Element --
 650    -----------------
 651
 652    function Has_Element (Position : Cursor) return Boolean is
 653    begin
 654       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 655       return Position.Node /= null;
 656    end Has_Element;
 657
 658    ------------
 659    -- Insert --
 660    ------------
 661
 662    procedure Insert
 663      (Container : in out List;
 664       Before    : Cursor;
 665       New_Item  : Element_Type;
 666       Position  : out Cursor;
 667       Count     : Count_Type := 1)
 668    is
 669       New_Node : Node_Access;
 670
 671    begin
 672       if Before.Container /= null then
 673          if Before.Container /= Container'Unrestricted_Access then
 674             raise Program_Error with
 675               "attempt to tamper with elements (list is busy)";
 676          end if;
 677
 678          if Before.Node = null
 679            or else Before.Node.Element = null
 680          then
 681             raise Program_Error with
 682               "Before cursor has no element";
 683          end if;
 684
 685          pragma Assert (Vet (Before), "bad cursor in Insert");
 686       end if;
 687
 688       if Count = 0 then
 689          Position := Before;
 690          return;
 691       end if;
 692
 693       if Container.Length > Count_Type'Last - Count then
 694          raise Constraint_Error with "new length exceeds maximum";
 695       end if;
 696
 697       if Container.Busy > 0 then
 698          raise Program_Error with
 699            "attempt to tamper with elements (list is busy)";
 700       end if;
 701
 702       declare
 703          Element : Element_Access := new Element_Type'(New_Item);
 704       begin
 705          New_Node := new Node_Type'(Element, null, null);
 706       exception
 707          when others =>
 708             Free (Element);
 709             raise;
 710       end;
 711
 712       Insert_Internal (Container, Before.Node, New_Node);
 713       Position := Cursor'(Container'Unchecked_Access, New_Node);
 714
 715       for J in Count_Type'(2) .. Count loop
 716
 717          declare
 718             Element : Element_Access := new Element_Type'(New_Item);
 719          begin
 720             New_Node := new Node_Type'(Element, null, null);
 721          exception
 722             when others =>
 723                Free (Element);
 724                raise;
 725          end;
 726
 727          Insert_Internal (Container, Before.Node, New_Node);
 728       end loop;
 729    end Insert;
 730
 731    procedure Insert
 732      (Container : in out List;
 733       Before    : Cursor;
 734       New_Item  : Element_Type;
 735       Count     : Count_Type := 1)
 736    is
 737       Position : Cursor;
 738    begin
 739       Insert (Container, Before, New_Item, Position, Count);
 740    end Insert;
 741
 742    ---------------------
 743    -- Insert_Internal --
 744    ---------------------
 745
 746    procedure Insert_Internal
 747      (Container : in out List;
 748       Before    : Node_Access;
 749       New_Node  : Node_Access)
 750    is
 751    begin
 752       if Container.Length = 0 then
 753          pragma Assert (Before = null);
 754          pragma Assert (Container.First = null);
 755          pragma Assert (Container.Last = null);
 756
 757          Container.First := New_Node;
 758          Container.Last := New_Node;
 759
 760       elsif Before = null then
 761          pragma Assert (Container.Last.Next = null);
 762
 763          Container.Last.Next := New_Node;
 764          New_Node.Prev := Container.Last;
 765
 766          Container.Last := New_Node;
 767
 768       elsif Before = Container.First then
 769          pragma Assert (Container.First.Prev = null);
 770
 771          Container.First.Prev := New_Node;
 772          New_Node.Next := Container.First;
 773
 774          Container.First := New_Node;
 775
 776       else
 777          pragma Assert (Container.First.Prev = null);
 778          pragma Assert (Container.Last.Next = null);
 779
 780          New_Node.Next := Before;
 781          New_Node.Prev := Before.Prev;
 782
 783          Before.Prev.Next := New_Node;
 784          Before.Prev := New_Node;
 785       end if;
 786
 787       Container.Length := Container.Length + 1;
 788    end Insert_Internal;
 789
 790    --------------
 791    -- Is_Empty --
 792    --------------
 793
 794    function Is_Empty (Container : List) return Boolean is
 795    begin
 796       return Container.Length = 0;
 797    end Is_Empty;
 798
 799    -------------
 800    -- Iterate --
 801    -------------
 802
 803    procedure Iterate
 804      (Container : List;
 805       Process   : not null access procedure (Position : Cursor))
 806    is
 807       C : List renames Container'Unrestricted_Access.all;
 808       B : Natural renames C.Busy;
 809
 810       Node : Node_Access := Container.First;
 811
 812    begin
 813       B := B + 1;
 814
 815       begin
 816          while Node /= null loop
 817             Process (Cursor'(Container'Unchecked_Access, Node));
 818             Node := Node.Next;
 819          end loop;
 820       exception
 821          when others =>
 822             B := B - 1;
 823             raise;
 824       end;
 825
 826       B := B - 1;
 827    end Iterate;
 828
 829    ----------
 830    -- Last --
 831    ----------
 832
 833    function Last (Container : List) return Cursor is
 834    begin
 835       if Container.Last = null then
 836          return No_Element;
 837       end if;
 838
 839       return Cursor'(Container'Unchecked_Access, Container.Last);
 840    end Last;
 841
 842    ------------------
 843    -- Last_Element --
 844    ------------------
 845
 846    function Last_Element (Container : List) return Element_Type is
 847    begin
 848       if Container.Last = null then
 849          raise Constraint_Error with "list is empty";
 850       end if;
 851
 852       return Container.Last.Element.all;
 853    end Last_Element;
 854
 855    ------------
 856    -- Length --
 857    ------------
 858
 859    function Length (Container : List) return Count_Type is
 860    begin
 861       return Container.Length;
 862    end Length;
 863
 864    ----------
 865    -- Move --
 866    ----------
 867
 868    procedure Move (Target : in out List; Source : in out List) is
 869    begin
 870       if Target'Address = Source'Address then
 871          return;
 872       end if;
 873
 874       if Source.Busy > 0 then
 875          raise Program_Error with
 876            "attempt to tamper with elements of Source (list is busy)";
 877       end if;
 878
 879       Clear (Target);
 880
 881       Target.First := Source.First;
 882       Source.First := null;
 883
 884       Target.Last := Source.Last;
 885       Source.Last := null;
 886
 887       Target.Length := Source.Length;
 888       Source.Length := 0;
 889    end Move;
 890
 891    ----------
 892    -- Next --
 893    ----------
 894
 895    procedure Next (Position : in out Cursor) is
 896    begin
 897       Position := Next (Position);
 898    end Next;
 899
 900    function Next (Position : Cursor) return Cursor is
 901    begin
 902       if Position.Node = null then
 903          return No_Element;
 904       end if;
 905
 906       pragma Assert (Vet (Position), "bad cursor in Next");
 907
 908       declare
 909          Next_Node : constant Node_Access := Position.Node.Next;
 910       begin
 911          if Next_Node = null then
 912             return No_Element;
 913          end if;
 914
 915          return Cursor'(Position.Container, Next_Node);
 916       end;
 917    end Next;
 918
 919    -------------
 920    -- Prepend --
 921    -------------
 922
 923    procedure Prepend
 924      (Container : in out List;
 925       New_Item  : Element_Type;
 926       Count     : Count_Type := 1)
 927    is
 928    begin
 929       Insert (Container, First (Container), New_Item, Count);
 930    end Prepend;
 931
 932    --------------
 933    -- Previous --
 934    --------------
 935
 936    procedure Previous (Position : in out Cursor) is
 937    begin
 938       Position := Previous (Position);
 939    end Previous;
 940
 941    function Previous (Position : Cursor) return Cursor is
 942    begin
 943       if Position.Node = null then
 944          return No_Element;
 945       end if;
 946
 947       pragma Assert (Vet (Position), "bad cursor in Previous");
 948
 949       declare
 950          Prev_Node : constant Node_Access := Position.Node.Prev;
 951       begin
 952          if Prev_Node = null then
 953             return No_Element;
 954          end if;
 955
 956          return Cursor'(Position.Container, Prev_Node);
 957       end;
 958    end Previous;
 959
 960    -------------------
 961    -- Query_Element --
 962    -------------------
 963
 964    procedure Query_Element
 965      (Position : Cursor;
 966       Process  : not null access procedure (Element : Element_Type))
 967    is
 968    begin
 969       if Position.Node = null then
 970          raise Constraint_Error with
 971            "Position cursor has no element";
 972       end if;
 973
 974       if Position.Node.Element = null then
 975          raise Program_Error with
 976            "Position cursor has no element";
 977       end if;
 978
 979       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 980
 981       declare
 982          C : List renames Position.Container.all'Unrestricted_Access.all;
 983          B : Natural renames C.Busy;
 984          L : Natural renames C.Lock;
 985
 986       begin
 987          B := B + 1;
 988          L := L + 1;
 989
 990          begin
 991             Process (Position.Node.Element.all);
 992          exception
 993             when others =>
 994                L := L - 1;
 995                B := B - 1;
 996                raise;
 997          end;
 998
 999          L := L - 1;
1000          B := B - 1;
1001       end;
1002    end Query_Element;
1003
1004    ----------
1005    -- Read --
1006    ----------
1007
1008    procedure Read
1009      (Stream : not null access Root_Stream_Type'Class;
1010       Item   : out List)
1011    is
1012       N   : Count_Type'Base;
1013       Dst : Node_Access;
1014
1015    begin
1016       Clear (Item);
1017
1018       Count_Type'Base'Read (Stream, N);
1019
1020       if N = 0 then
1021          return;
1022       end if;
1023
1024       declare
1025          Element : Element_Access :=
1026                      new Element_Type'(Element_Type'Input (Stream));
1027       begin
1028          Dst := new Node_Type'(Element, null, null);
1029       exception
1030          when others =>
1031             Free (Element);
1032             raise;
1033       end;
1034
1035       Item.First := Dst;
1036       Item.Last := Dst;
1037       Item.Length := 1;
1038
1039       while Item.Length < N loop
1040          declare
1041             Element : Element_Access :=
1042                         new Element_Type'(Element_Type'Input (Stream));
1043          begin
1044             Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1045          exception
1046             when others =>
1047                Free (Element);
1048                raise;
1049          end;
1050
1051          Item.Last.Next := Dst;
1052          Item.Last := Dst;
1053          Item.Length := Item.Length + 1;
1054       end loop;
1055    end Read;
1056
1057    procedure Read
1058      (Stream : not null access Root_Stream_Type'Class;
1059       Item   : out Cursor)
1060    is
1061    begin
1062       raise Program_Error with "attempt to stream list cursor";
1063    end Read;
1064
1065    ---------------------
1066    -- Replace_Element --
1067    ---------------------
1068
1069    procedure Replace_Element
1070      (Container : in out List;
1071       Position  : Cursor;
1072       New_Item  : Element_Type)
1073    is
1074    begin
1075       if Position.Container = null then
1076          raise Constraint_Error with "Position cursor has no element";
1077       end if;
1078
1079       if Position.Container /= Container'Unchecked_Access then
1080          raise Program_Error with
1081            "Position cursor designates wrong container";
1082       end if;
1083
1084       if Container.Lock > 0 then
1085          raise Program_Error with
1086            "attempt to tamper with cursors (list is locked)";
1087       end if;
1088
1089       if Position.Node.Element = null then
1090          raise Program_Error with
1091            "Position cursor has no element";
1092       end if;
1093
1094       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1095
1096       declare
1097          X : Element_Access := Position.Node.Element;
1098
1099       begin
1100          Position.Node.Element := new Element_Type'(New_Item);
1101          Free (X);
1102       end;
1103    end Replace_Element;
1104
1105    ----------------------
1106    -- Reverse_Elements --
1107    ----------------------
1108
1109    procedure Reverse_Elements (Container : in out List) is
1110       I : Node_Access := Container.First;
1111       J : Node_Access := Container.Last;
1112
1113       procedure Swap (L, R : Node_Access);
1114
1115       ----------
1116       -- Swap --
1117       ----------
1118
1119       procedure Swap (L, R : Node_Access) is
1120          LN : constant Node_Access := L.Next;
1121          LP : constant Node_Access := L.Prev;
1122
1123          RN : constant Node_Access := R.Next;
1124          RP : constant Node_Access := R.Prev;
1125
1126       begin
1127          if LP /= null then
1128             LP.Next := R;
1129          end if;
1130
1131          if RN /= null then
1132             RN.Prev := L;
1133          end if;
1134
1135          L.Next := RN;
1136          R.Prev := LP;
1137
1138          if LN = R then
1139             pragma Assert (RP = L);
1140
1141             L.Prev := R;
1142             R.Next := L;
1143
1144          else
1145             L.Prev := RP;
1146             RP.Next := L;
1147
1148             R.Next := LN;
1149             LN.Prev := R;
1150          end if;
1151       end Swap;
1152
1153    --  Start of processing for Reverse_Elements
1154
1155    begin
1156       if Container.Length <= 1 then
1157          return;
1158       end if;
1159
1160       pragma Assert (Container.First.Prev = null);
1161       pragma Assert (Container.Last.Next = null);
1162
1163       if Container.Busy > 0 then
1164          raise Program_Error with
1165            "attempt to tamper with elements (list is busy)";
1166       end if;
1167
1168       Container.First := J;
1169       Container.Last := I;
1170       loop
1171          Swap (L => I, R => J);
1172
1173          J := J.Next;
1174          exit when I = J;
1175
1176          I := I.Prev;
1177          exit when I = J;
1178
1179          Swap (L => J, R => I);
1180
1181          I := I.Next;
1182          exit when I = J;
1183
1184          J := J.Prev;
1185          exit when I = J;
1186       end loop;
1187
1188       pragma Assert (Container.First.Prev = null);
1189       pragma Assert (Container.Last.Next = null);
1190    end Reverse_Elements;
1191
1192    ------------------
1193    -- Reverse_Find --
1194    ------------------
1195
1196    function Reverse_Find
1197      (Container : List;
1198       Item      : Element_Type;
1199       Position  : Cursor := No_Element) return Cursor
1200    is
1201       Node : Node_Access := Position.Node;
1202
1203    begin
1204       if Node = null then
1205          Node := Container.Last;
1206
1207       else
1208          if Node.Element = null then
1209             raise Program_Error with "Position cursor has no element";
1210          end if;
1211
1212          if Position.Container /= Container'Unrestricted_Access then
1213             raise Program_Error with
1214               "Position cursor designates wrong container";
1215          end if;
1216
1217          pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1218       end if;
1219
1220       while Node /= null loop
1221          if Node.Element.all = Item then
1222             return Cursor'(Container'Unchecked_Access, Node);
1223          end if;
1224
1225          Node := Node.Prev;
1226       end loop;
1227
1228       return No_Element;
1229    end Reverse_Find;
1230
1231    ---------------------
1232    -- Reverse_Iterate --
1233    ---------------------
1234
1235    procedure Reverse_Iterate
1236      (Container : List;
1237       Process   : not null access procedure (Position : Cursor))
1238    is
1239       C : List renames Container'Unrestricted_Access.all;
1240       B : Natural renames C.Busy;
1241
1242       Node : Node_Access := Container.Last;
1243
1244    begin
1245       B := B + 1;
1246
1247       begin
1248          while Node /= null loop
1249             Process (Cursor'(Container'Unchecked_Access, Node));
1250             Node := Node.Prev;
1251          end loop;
1252       exception
1253          when others =>
1254             B := B - 1;
1255             raise;
1256       end;
1257
1258       B := B - 1;
1259    end Reverse_Iterate;
1260
1261    ------------
1262    -- Splice --
1263    ------------
1264
1265    procedure Splice
1266      (Target : in out List;
1267       Before : Cursor;
1268       Source : in out List)
1269    is
1270    begin
1271       if Before.Container /= null then
1272          if Before.Container /= Target'Unrestricted_Access then
1273             raise Program_Error with
1274               "Before cursor designates wrong container";
1275          end if;
1276
1277          if Before.Node = null
1278            or else Before.Node.Element = null
1279          then
1280             raise Program_Error with
1281               "Before cursor has no element";
1282          end if;
1283
1284          pragma Assert (Vet (Before), "bad cursor in Splice");
1285       end if;
1286
1287       if Target'Address = Source'Address
1288         or else Source.Length = 0
1289       then
1290          return;
1291       end if;
1292
1293       pragma Assert (Source.First.Prev = null);
1294       pragma Assert (Source.Last.Next = null);
1295
1296       if Target.Length > Count_Type'Last - Source.Length then
1297          raise Constraint_Error with "new length exceeds maximum";
1298       end if;
1299
1300       if Target.Busy > 0 then
1301          raise Program_Error with
1302            "attempt to tamper with elements of Target (list is busy)";
1303       end if;
1304
1305       if Source.Busy > 0 then
1306          raise Program_Error with
1307            "attempt to tamper with elements of Source (list is busy)";
1308       end if;
1309
1310       if Target.Length = 0 then
1311          pragma Assert (Before = No_Element);
1312          pragma Assert (Target.First = null);
1313          pragma Assert (Target.Last = null);
1314
1315          Target.First := Source.First;
1316          Target.Last := Source.Last;
1317
1318       elsif Before.Node = null then
1319          pragma Assert (Target.Last.Next = null);
1320
1321          Target.Last.Next := Source.First;
1322          Source.First.Prev := Target.Last;
1323
1324          Target.Last := Source.Last;
1325
1326       elsif Before.Node = Target.First then
1327          pragma Assert (Target.First.Prev = null);
1328
1329          Source.Last.Next := Target.First;
1330          Target.First.Prev := Source.Last;
1331
1332          Target.First := Source.First;
1333
1334       else
1335          pragma Assert (Target.Length >= 2);
1336          Before.Node.Prev.Next := Source.First;
1337          Source.First.Prev := Before.Node.Prev;
1338
1339          Before.Node.Prev := Source.Last;
1340          Source.Last.Next := Before.Node;
1341       end if;
1342
1343       Source.First := null;
1344       Source.Last := null;
1345
1346       Target.Length := Target.Length + Source.Length;
1347       Source.Length := 0;
1348    end Splice;
1349
1350    procedure Splice
1351      (Container : in out List;
1352       Before    : Cursor;
1353       Position  : Cursor)
1354    is
1355    begin
1356       if Before.Container /= null then
1357          if Before.Container /= Container'Unchecked_Access then
1358             raise Program_Error with
1359               "Before cursor designates wrong container";
1360          end if;
1361
1362          if Before.Node = null
1363            or else Before.Node.Element = null
1364          then
1365             raise Program_Error with
1366               "Before cursor has no element";
1367          end if;
1368
1369          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1370       end if;
1371
1372       if Position.Node = null then
1373          raise Constraint_Error with "Position cursor has no element";
1374       end if;
1375
1376       if Position.Node.Element = null then
1377          raise Program_Error with "Position cursor has no element";
1378       end if;
1379
1380       if Position.Container /= Container'Unrestricted_Access then
1381          raise Program_Error with
1382            "Position cursor designates wrong container";
1383       end if;
1384
1385       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1386
1387       if Position.Node = Before.Node
1388         or else Position.Node.Next = Before.Node
1389       then
1390          return;
1391       end if;
1392
1393       pragma Assert (Container.Length >= 2);
1394
1395       if Container.Busy > 0 then
1396          raise Program_Error with
1397            "attempt to tamper with elements (list is busy)";
1398       end if;
1399
1400       if Before.Node = null then
1401          pragma Assert (Position.Node /= Container.Last);
1402
1403          if Position.Node = Container.First then
1404             Container.First := Position.Node.Next;
1405             Container.First.Prev := null;
1406          else
1407             Position.Node.Prev.Next := Position.Node.Next;
1408             Position.Node.Next.Prev := Position.Node.Prev;
1409          end if;
1410
1411          Container.Last.Next := Position.Node;
1412          Position.Node.Prev := Container.Last;
1413
1414          Container.Last := Position.Node;
1415          Container.Last.Next := null;
1416
1417          return;
1418       end if;
1419
1420       if Before.Node = Container.First then
1421          pragma Assert (Position.Node /= Container.First);
1422
1423          if Position.Node = Container.Last then
1424             Container.Last := Position.Node.Prev;
1425             Container.Last.Next := null;
1426          else
1427             Position.Node.Prev.Next := Position.Node.Next;
1428             Position.Node.Next.Prev := Position.Node.Prev;
1429          end if;
1430
1431          Container.First.Prev := Position.Node;
1432          Position.Node.Next := Container.First;
1433
1434          Container.First := Position.Node;
1435          Container.First.Prev := null;
1436
1437          return;
1438       end if;
1439
1440       if Position.Node = Container.First then
1441          Container.First := Position.Node.Next;
1442          Container.First.Prev := null;
1443
1444       elsif Position.Node = Container.Last then
1445          Container.Last := Position.Node.Prev;
1446          Container.Last.Next := null;
1447
1448       else
1449          Position.Node.Prev.Next := Position.Node.Next;
1450          Position.Node.Next.Prev := Position.Node.Prev;
1451       end if;
1452
1453       Before.Node.Prev.Next := Position.Node;
1454       Position.Node.Prev := Before.Node.Prev;
1455
1456       Before.Node.Prev := Position.Node;
1457       Position.Node.Next := Before.Node;
1458
1459       pragma Assert (Container.First.Prev = null);
1460       pragma Assert (Container.Last.Next = null);
1461    end Splice;
1462
1463    procedure Splice
1464      (Target   : in out List;
1465       Before   : Cursor;
1466       Source   : in out List;
1467       Position : in out Cursor)
1468    is
1469    begin
1470       if Target'Address = Source'Address then
1471          Splice (Target, Before, Position);
1472          return;
1473       end if;
1474
1475       if Before.Container /= null then
1476          if Before.Container /= Target'Unrestricted_Access then
1477             raise Program_Error with
1478               "Before cursor designates wrong container";
1479          end if;
1480
1481          if Before.Node = null
1482            or else Before.Node.Element = null
1483          then
1484             raise Program_Error with
1485               "Before cursor has no element";
1486          end if;
1487
1488          pragma Assert (Vet (Before), "bad Before cursor in Splice");
1489       end if;
1490
1491       if Position.Node = null then
1492          raise Constraint_Error with "Position cursor has no element";
1493       end if;
1494
1495       if Position.Node.Element = null then
1496          raise Program_Error with
1497            "Position cursor has no element";
1498       end if;
1499
1500       if Position.Container /= Source'Unrestricted_Access then
1501          raise Program_Error with
1502            "Position cursor designates wrong container";
1503       end if;
1504
1505       pragma Assert (Vet (Position), "bad Position cursor in Splice");
1506
1507       if Target.Length = Count_Type'Last then
1508          raise Constraint_Error with "Target is full";
1509       end if;
1510
1511       if Target.Busy > 0 then
1512          raise Program_Error with
1513            "attempt to tamper with elements of Target (list is busy)";
1514       end if;
1515
1516       if Source.Busy > 0 then
1517          raise Program_Error with
1518            "attempt to tamper with elements of Source (list is busy)";
1519       end if;
1520
1521       if Position.Node = Source.First then
1522          Source.First := Position.Node.Next;
1523
1524          if Position.Node = Source.Last then
1525             pragma Assert (Source.First = null);
1526             pragma Assert (Source.Length = 1);
1527             Source.Last := null;
1528
1529          else
1530             Source.First.Prev := null;
1531          end if;
1532
1533       elsif Position.Node = Source.Last then
1534          pragma Assert (Source.Length >= 2);
1535          Source.Last := Position.Node.Prev;
1536          Source.Last.Next := null;
1537
1538       else
1539          pragma Assert (Source.Length >= 3);
1540          Position.Node.Prev.Next := Position.Node.Next;
1541          Position.Node.Next.Prev := Position.Node.Prev;
1542       end if;
1543
1544       if Target.Length = 0 then
1545          pragma Assert (Before = No_Element);
1546          pragma Assert (Target.First = null);
1547          pragma Assert (Target.Last = null);
1548
1549          Target.First := Position.Node;
1550          Target.Last := Position.Node;
1551
1552          Target.First.Prev := null;
1553          Target.Last.Next := null;
1554
1555       elsif Before.Node = null then
1556          pragma Assert (Target.Last.Next = null);
1557          Target.Last.Next := Position.Node;
1558          Position.Node.Prev := Target.Last;
1559
1560          Target.Last := Position.Node;
1561          Target.Last.Next := null;
1562
1563       elsif Before.Node = Target.First then
1564          pragma Assert (Target.First.Prev = null);
1565          Target.First.Prev := Position.Node;
1566          Position.Node.Next := Target.First;
1567
1568          Target.First := Position.Node;
1569          Target.First.Prev := null;
1570
1571       else
1572          pragma Assert (Target.Length >= 2);
1573          Before.Node.Prev.Next := Position.Node;
1574          Position.Node.Prev := Before.Node.Prev;
1575
1576          Before.Node.Prev := Position.Node;
1577          Position.Node.Next := Before.Node;
1578       end if;
1579
1580       Target.Length := Target.Length + 1;
1581       Source.Length := Source.Length - 1;
1582
1583       Position.Container := Target'Unchecked_Access;
1584    end Splice;
1585
1586    ----------
1587    -- Swap --
1588    ----------
1589
1590    procedure Swap
1591      (Container : in out List;
1592       I, J      : Cursor)
1593    is
1594    begin
1595       if I.Node = null then
1596          raise Constraint_Error with "I cursor has no element";
1597       end if;
1598
1599       if J.Node = null then
1600          raise Constraint_Error with "J cursor has no element";
1601       end if;
1602
1603       if I.Container /= Container'Unchecked_Access then
1604          raise Program_Error with "I cursor designates wrong container";
1605       end if;
1606
1607       if J.Container /= Container'Unchecked_Access then
1608          raise Program_Error with "J cursor designates wrong container";
1609       end if;
1610
1611       if I.Node = J.Node then
1612          return;
1613       end if;
1614
1615       if Container.Lock > 0 then
1616          raise Program_Error with
1617            "attempt to tamper with cursors (list is locked)";
1618       end if;
1619
1620       pragma Assert (Vet (I), "bad I cursor in Swap");
1621       pragma Assert (Vet (J), "bad J cursor in Swap");
1622
1623       declare
1624          EI_Copy : constant Element_Access := I.Node.Element;
1625
1626       begin
1627          I.Node.Element := J.Node.Element;
1628          J.Node.Element := EI_Copy;
1629       end;
1630    end Swap;
1631
1632    ----------------
1633    -- Swap_Links --
1634    ----------------
1635
1636    procedure Swap_Links
1637      (Container : in out List;
1638       I, J      : Cursor)
1639    is
1640    begin
1641       if I.Node = null then
1642          raise Constraint_Error with "I cursor has no element";
1643       end if;
1644
1645       if J.Node = null then
1646          raise Constraint_Error with "J cursor has no element";
1647       end if;
1648
1649       if I.Container /= Container'Unrestricted_Access then
1650          raise Program_Error with "I cursor designates wrong container";
1651       end if;
1652
1653       if J.Container /= Container'Unrestricted_Access then
1654          raise Program_Error with "J cursor designates wrong container";
1655       end if;
1656
1657       if I.Node = J.Node then
1658          return;
1659       end if;
1660
1661       if Container.Busy > 0 then
1662          raise Program_Error with
1663            "attempt to tamper with elements (list is busy)";
1664       end if;
1665
1666       pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1667       pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1668
1669       declare
1670          I_Next : constant Cursor := Next (I);
1671
1672       begin
1673          if I_Next = J then
1674             Splice (Container, Before => I, Position => J);
1675
1676          else
1677             declare
1678                J_Next : constant Cursor := Next (J);
1679
1680             begin
1681                if J_Next = I then
1682                   Splice (Container, Before => J, Position => I);
1683
1684                else
1685                   pragma Assert (Container.Length >= 3);
1686
1687                   Splice (Container, Before => I_Next, Position => J);
1688                   Splice (Container, Before => J_Next, Position => I);
1689                end if;
1690             end;
1691          end if;
1692       end;
1693
1694       pragma Assert (Container.First.Prev = null);
1695       pragma Assert (Container.Last.Next = null);
1696    end Swap_Links;
1697
1698    --------------------
1699    -- Update_Element --
1700    --------------------
1701
1702    procedure Update_Element
1703      (Container : in out List;
1704       Position  : Cursor;
1705       Process   : not null access procedure (Element : in out Element_Type))
1706    is
1707    begin
1708       if Position.Node = null then
1709          raise Constraint_Error with "Position cursor has no element";
1710       end if;
1711
1712       if Position.Node.Element = null then
1713          raise Program_Error with
1714            "Position cursor has no element";
1715       end if;
1716
1717       if Position.Container /= Container'Unchecked_Access then
1718          raise Program_Error with
1719            "Position cursor designates wrong container";
1720       end if;
1721
1722       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1723
1724       declare
1725          B : Natural renames Container.Busy;
1726          L : Natural renames Container.Lock;
1727
1728       begin
1729          B := B + 1;
1730          L := L + 1;
1731
1732          begin
1733             Process (Position.Node.Element.all);
1734          exception
1735             when others =>
1736                L := L - 1;
1737                B := B - 1;
1738                raise;
1739          end;
1740
1741          L := L - 1;
1742          B := B - 1;
1743       end;
1744    end Update_Element;
1745
1746    ---------
1747    -- Vet --
1748    ---------
1749
1750    function Vet (Position : Cursor) return Boolean is
1751    begin
1752       if Position.Node = null then
1753          return Position.Container = null;
1754       end if;
1755
1756       if Position.Container = null then
1757          return False;
1758       end if;
1759
1760       if Position.Node.Next = Position.Node then
1761          return False;
1762       end if;
1763
1764       if Position.Node.Prev = Position.Node then
1765          return False;
1766       end if;
1767
1768       if Position.Node.Element = null then
1769          return False;
1770       end if;
1771
1772       declare
1773          L : List renames Position.Container.all;
1774       begin
1775          if L.Length = 0 then
1776             return False;
1777          end if;
1778
1779          if L.First = null then
1780             return False;
1781          end if;
1782
1783          if L.Last = null then
1784             return False;
1785          end if;
1786
1787          if L.First.Prev /= null then
1788             return False;
1789          end if;
1790
1791          if L.Last.Next /= null then
1792             return False;
1793          end if;
1794
1795          if Position.Node.Prev = null
1796            and then Position.Node /= L.First
1797          then
1798             return False;
1799          end if;
1800
1801          if Position.Node.Next = null
1802            and then Position.Node /= L.Last
1803          then
1804             return False;
1805          end if;
1806
1807          if L.Length = 1 then
1808             return L.First = L.Last;
1809          end if;
1810
1811          if L.First = L.Last then
1812             return False;
1813          end if;
1814
1815          if L.First.Next = null then
1816             return False;
1817          end if;
1818
1819          if L.Last.Prev = null then
1820             return False;
1821          end if;
1822
1823          if L.First.Next.Prev /= L.First then
1824             return False;
1825          end if;
1826
1827          if L.Last.Prev.Next /= L.Last then
1828             return False;
1829          end if;
1830
1831          if L.Length = 2 then
1832             if L.First.Next /= L.Last then
1833                return False;
1834             end if;
1835
1836             if L.Last.Prev /= L.First then
1837                return False;
1838             end if;
1839
1840             return True;
1841          end if;
1842
1843          if L.First.Next = L.Last then
1844             return False;
1845          end if;
1846
1847          if L.Last.Prev = L.First then
1848             return False;
1849          end if;
1850
1851          if Position.Node = L.First then
1852             return True;
1853          end if;
1854
1855          if Position.Node = L.Last then
1856             return True;
1857          end if;
1858
1859          if Position.Node.Next = null then
1860             return False;
1861          end if;
1862
1863          if Position.Node.Prev = null then
1864             return False;
1865          end if;
1866
1867          if Position.Node.Next.Prev /= Position.Node then
1868             return False;
1869          end if;
1870
1871          if Position.Node.Prev.Next /= Position.Node then
1872             return False;
1873          end if;
1874
1875          if L.Length = 3 then
1876             if L.First.Next /= Position.Node then
1877                return False;
1878             end if;
1879
1880             if L.Last.Prev /= Position.Node then
1881                return False;
1882             end if;
1883          end if;
1884
1885          return True;
1886       end;
1887    end Vet;
1888
1889    -----------
1890    -- Write --
1891    -----------
1892
1893    procedure Write
1894      (Stream : not null access Root_Stream_Type'Class;
1895       Item   : List)
1896    is
1897       Node : Node_Access := Item.First;
1898
1899    begin
1900       Count_Type'Base'Write (Stream, Item.Length);
1901
1902       while Node /= null loop
1903          Element_Type'Output (Stream, Node.Element.all);
1904          Node := Node.Next;
1905       end loop;
1906    end Write;
1907
1908    procedure Write
1909      (Stream : not null access Root_Stream_Type'Class;
1910       Item   : Cursor)
1911    is
1912    begin
1913       raise Program_Error with "attempt to stream list cursor";
1914    end Write;
1915
1916 end Ada.Containers.Indefinite_Doubly_Linked_Lists;