gcc/ada/a-cdlili.adb

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