gcc/ada/a-cidlli.adb

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