gcc/ada/a-cimutr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                   ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES               --
   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 Ada.Unchecked_Deallocation;
  31
  32 with System; use type System.Address;
  33
  34 package body Ada.Containers.Indefinite_Multiway_Trees is
  35
  36    --------------------
  37    --  Root_Iterator --
  38    --------------------
  39
  40    type Root_Iterator is abstract new Limited_Controlled and
  41      Tree_Iterator_Interfaces.Forward_Iterator with
  42    record
  43       Container : Tree_Access;
  44       Subtree   : Tree_Node_Access;
  45    end record;
  46
  47    overriding procedure Finalize (Object : in out Root_Iterator);
  48
  49    -----------------------
  50    --  Subtree_Iterator --
  51    -----------------------
  52
  53    type Subtree_Iterator is new Root_Iterator with null record;
  54
  55    overriding function First (Object : Subtree_Iterator) return Cursor;
  56
  57    overriding function Next
  58      (Object   : Subtree_Iterator;
  59       Position : Cursor) return Cursor;
  60
  61    ---------------------
  62    --  Child_Iterator --
  63    ---------------------
  64
  65    type Child_Iterator is new Root_Iterator and
  66      Tree_Iterator_Interfaces.Reversible_Iterator with null record;
  67
  68    overriding function First (Object : Child_Iterator) return Cursor;
  69
  70    overriding function Next
  71      (Object   : Child_Iterator;
  72       Position : Cursor) return Cursor;
  73
  74    overriding function Last (Object : Child_Iterator) return Cursor;
  75
  76    overriding function Previous
  77      (Object   : Child_Iterator;
  78       Position : Cursor) return Cursor;
  79
  80    -----------------------
  81    -- Local Subprograms --
  82    -----------------------
  83
  84    function Root_Node (Container : Tree) return Tree_Node_Access;
  85
  86    procedure Free_Element is
  87       new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
  88
  89    procedure Deallocate_Node (X : in out Tree_Node_Access);
  90
  91    procedure Deallocate_Children
  92      (Subtree : Tree_Node_Access;
  93       Count   : in out Count_Type);
  94
  95    procedure Deallocate_Subtree
  96      (Subtree : in out Tree_Node_Access;
  97       Count   : in out Count_Type);
  98
  99    function Equal_Children
 100      (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
 101
 102    function Equal_Subtree
 103      (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
 104
 105    procedure Iterate_Children
 106      (Container : Tree_Access;
 107       Subtree   : Tree_Node_Access;
 108       Process   : not null access procedure (Position : Cursor));
 109
 110    procedure Iterate_Subtree
 111      (Container : Tree_Access;
 112       Subtree   : Tree_Node_Access;
 113       Process   : not null access procedure (Position : Cursor));
 114
 115    procedure Copy_Children
 116      (Source : Children_Type;
 117       Parent : Tree_Node_Access;
 118       Count  : in out Count_Type);
 119
 120    procedure Copy_Subtree
 121      (Source : Tree_Node_Access;
 122       Parent : Tree_Node_Access;
 123       Target : out Tree_Node_Access;
 124       Count  : in out Count_Type);
 125
 126    function Find_In_Children
 127      (Subtree : Tree_Node_Access;
 128       Item    : Element_Type) return Tree_Node_Access;
 129
 130    function Find_In_Subtree
 131      (Subtree : Tree_Node_Access;
 132       Item    : Element_Type) return Tree_Node_Access;
 133
 134    function Child_Count (Children : Children_Type) return Count_Type;
 135
 136    function Subtree_Node_Count
 137      (Subtree : Tree_Node_Access) return Count_Type;
 138
 139    function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
 140
 141    procedure Remove_Subtree (Subtree : Tree_Node_Access);
 142
 143    procedure Insert_Subtree_Node
 144      (Subtree : Tree_Node_Access;
 145       Parent  : Tree_Node_Access;
 146       Before  : Tree_Node_Access);
 147
 148    procedure Insert_Subtree_List
 149      (First  : Tree_Node_Access;
 150       Last   : Tree_Node_Access;
 151       Parent : Tree_Node_Access;
 152       Before : Tree_Node_Access);
 153
 154    procedure Splice_Children
 155      (Target_Parent : Tree_Node_Access;
 156       Before        : Tree_Node_Access;
 157       Source_Parent : Tree_Node_Access);
 158
 159    ---------
 160    -- "=" --
 161    ---------
 162
 163    function "=" (Left, Right : Tree) return Boolean is
 164    begin
 165       if Left'Address = Right'Address then
 166          return True;
 167       end if;
 168
 169       return Equal_Children (Root_Node (Left), Root_Node (Right));
 170    end "=";
 171
 172    ------------
 173    -- Adjust --
 174    ------------
 175
 176    procedure Adjust (Container : in out Tree) is
 177       Source       : constant Children_Type := Container.Root.Children;
 178       Source_Count : constant Count_Type := Container.Count;
 179       Target_Count : Count_Type;
 180
 181    begin
 182       --  We first restore the target container to its default-initialized
 183       --  state, before we attempt any allocation, to ensure that invariants
 184       --  are preserved in the event that the allocation fails.
 185
 186       Container.Root.Children := Children_Type'(others => null);
 187       Container.Busy := 0;
 188       Container.Lock := 0;
 189       Container.Count := 0;
 190
 191       --  Copy_Children returns a count of the number of nodes that it
 192       --  allocates, but it works by incrementing the value that is passed in.
 193       --  We must therefore initialize the count value before calling
 194       --  Copy_Children.
 195
 196       Target_Count := 0;
 197
 198       --  Now we attempt the allocation of subtrees. The invariants are
 199       --  satisfied even if the allocation fails.
 200
 201       Copy_Children (Source, Root_Node (Container), Target_Count);
 202       pragma Assert (Target_Count = Source_Count);
 203
 204       Container.Count := Source_Count;
 205    end Adjust;
 206
 207    -------------------
 208    -- Ancestor_Find --
 209    -------------------
 210
 211    function Ancestor_Find
 212      (Position : Cursor;
 213       Item     : Element_Type) return Cursor
 214    is
 215       R, N : Tree_Node_Access;
 216
 217    begin
 218       if Position = No_Element then
 219          raise Constraint_Error with "Position cursor has no element";
 220       end if;
 221
 222       --  Commented-out pending ARG ruling.  ???
 223
 224       --  if Position.Container /= Container'Unrestricted_Access then
 225       --     raise Program_Error with "Position cursor not in container";
 226       --  end if;
 227
 228       --  AI-0136 says to raise PE if Position equals the root node. This does
 229       --  not seem correct, as this value is just the limiting condition of the
 230       --  search. For now we omit this check pending a ruling from the ARG.???
 231
 232       --  if Is_Root (Position) then
 233       --     raise Program_Error with "Position cursor designates root";
 234       --  end if;
 235
 236       R := Root_Node (Position.Container.all);
 237       N := Position.Node;
 238       while N /= R loop
 239          if N.Element.all = Item then
 240             return Cursor'(Position.Container, N);
 241          end if;
 242
 243          N := N.Parent;
 244       end loop;
 245
 246       return No_Element;
 247    end Ancestor_Find;
 248
 249    ------------------
 250    -- Append_Child --
 251    ------------------
 252
 253    procedure Append_Child
 254      (Container : in out Tree;
 255       Parent    : Cursor;
 256       New_Item  : Element_Type;
 257       Count     : Count_Type := 1)
 258    is
 259       First, Last : Tree_Node_Access;
 260       Element     : Element_Access;
 261
 262    begin
 263       if Parent = No_Element then
 264          raise Constraint_Error with "Parent cursor has no element";
 265       end if;
 266
 267       if Parent.Container /= Container'Unrestricted_Access then
 268          raise Program_Error with "Parent cursor not in container";
 269       end if;
 270
 271       if Count = 0 then
 272          return;
 273       end if;
 274
 275       if Container.Busy > 0 then
 276          raise Program_Error
 277            with "attempt to tamper with cursors (tree is busy)";
 278       end if;
 279
 280       Element := new Element_Type'(New_Item);
 281       First := new Tree_Node_Type'(Parent  => Parent.Node,
 282                                    Element => Element,
 283                                    others  => <>);
 284
 285       Last := First;
 286
 287       for J in Count_Type'(2) .. Count loop
 288
 289          --  Reclaim other nodes if Storage_Error.  ???
 290
 291          Element := new Element_Type'(New_Item);
 292          Last.Next := new Tree_Node_Type'(Parent  => Parent.Node,
 293                                           Prev    => Last,
 294                                           Element => Element,
 295                                           others  => <>);
 296
 297          Last := Last.Next;
 298       end loop;
 299
 300       Insert_Subtree_List
 301         (First  => First,
 302          Last   => Last,
 303          Parent => Parent.Node,
 304          Before => null);  -- null means "insert at end of list"
 305
 306       --  In order for operation Node_Count to complete in O(1) time, we cache
 307       --  the count value. Here we increment the total count by the number of
 308       --  nodes we just inserted.
 309
 310       Container.Count := Container.Count + Count;
 311    end Append_Child;
 312
 313    ------------
 314    -- Assign --
 315    ------------
 316
 317    procedure Assign (Target : in out Tree; Source : Tree) is
 318       Source_Count : constant Count_Type := Source.Count;
 319       Target_Count : Count_Type;
 320
 321    begin
 322       if Target'Address = Source'Address then
 323          return;
 324       end if;
 325
 326       Target.Clear;  -- checks busy bit
 327
 328       --  Copy_Children returns the number of nodes that it allocates, but it
 329       --  does this by incrementing the count value passed in, so we must
 330       --  initialize the count before calling Copy_Children.
 331
 332       Target_Count := 0;
 333
 334       --  Note that Copy_Children inserts the newly-allocated children into
 335       --  their parent list only after the allocation of all the children has
 336       --  succeeded. This preserves invariants even if the allocation fails.
 337
 338       Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
 339       pragma Assert (Target_Count = Source_Count);
 340
 341       Target.Count := Source_Count;
 342    end Assign;
 343
 344    -----------------
 345    -- Child_Count --
 346    -----------------
 347
 348    function Child_Count (Parent : Cursor) return Count_Type is
 349    begin
 350       if Parent = No_Element then
 351          return 0;
 352       else
 353          return Child_Count (Parent.Node.Children);
 354       end if;
 355    end Child_Count;
 356
 357    function Child_Count (Children : Children_Type) return Count_Type is
 358       Result : Count_Type;
 359       Node   : Tree_Node_Access;
 360
 361    begin
 362       Result := 0;
 363       Node := Children.First;
 364       while Node /= null loop
 365          Result := Result + 1;
 366          Node := Node.Next;
 367       end loop;
 368
 369       return Result;
 370    end Child_Count;
 371
 372    -----------------
 373    -- Child_Depth --
 374    -----------------
 375
 376    function Child_Depth (Parent, Child : Cursor) return Count_Type is
 377       Result : Count_Type;
 378       N      : Tree_Node_Access;
 379
 380    begin
 381       if Parent = No_Element then
 382          raise Constraint_Error with "Parent cursor has no element";
 383       end if;
 384
 385       if Child = No_Element then
 386          raise Constraint_Error with "Child cursor has no element";
 387       end if;
 388
 389       if Parent.Container /= Child.Container then
 390          raise Program_Error with "Parent and Child in different containers";
 391       end if;
 392
 393       Result := 0;
 394       N := Child.Node;
 395       while N /= Parent.Node loop
 396          Result := Result + 1;
 397          N := N.Parent;
 398
 399          if N = null then
 400             raise Program_Error with "Parent is not ancestor of Child";
 401          end if;
 402       end loop;
 403
 404       return Result;
 405    end Child_Depth;
 406
 407    -----------
 408    -- Clear --
 409    -----------
 410
 411    procedure Clear (Container : in out Tree) is
 412       Container_Count : Count_Type;
 413       Children_Count  : Count_Type;
 414
 415    begin
 416       if Container.Busy > 0 then
 417          raise Program_Error
 418            with "attempt to tamper with cursors (tree is busy)";
 419       end if;
 420
 421       --  We first set the container count to 0, in order to preserve
 422       --  invariants in case the deallocation fails. (This works because
 423       --  Deallocate_Children immediately removes the children from their
 424       --  parent, and then does the actual deallocation.)
 425
 426       Container_Count := Container.Count;
 427       Container.Count := 0;
 428
 429       --  Deallocate_Children returns the number of nodes that it deallocates,
 430       --  but it does this by incrementing the count value that is passed in,
 431       --  so we must first initialize the count return value before calling it.
 432
 433       Children_Count := 0;
 434
 435       --  See comment above. Deallocate_Children immediately removes the
 436       --  children list from their parent node (here, the root of the tree),
 437       --  and only after that does it attempt the actual deallocation. So even
 438       --  if the deallocation fails, the representation invariants
 439
 440       Deallocate_Children (Root_Node (Container), Children_Count);
 441       pragma Assert (Children_Count = Container_Count);
 442    end Clear;
 443
 444    ------------------------
 445    -- Constant_Reference --
 446    ------------------------
 447
 448    function Constant_Reference
 449      (Container : aliased Tree;
 450       Position  : Cursor) return Constant_Reference_Type
 451    is
 452    begin
 453       if Position.Container = null then
 454          raise Constraint_Error with
 455            "Position cursor has no element";
 456       end if;
 457
 458       if Position.Container /= Container'Unrestricted_Access then
 459          raise Program_Error with
 460            "Position cursor designates wrong container";
 461       end if;
 462
 463       if Position.Node = Root_Node (Container) then
 464          raise Program_Error with "Position cursor designates root";
 465       end if;
 466
 467       if Position.Node.Element = null then
 468          raise Program_Error with "Node has no element";
 469       end if;
 470
 471       --  Implement Vet for multiway tree???
 472       --  pragma Assert (Vet (Position),
 473       --                 "Position cursor in Constant_Reference is bad");
 474
 475       return (Element => Position.Node.Element.all'Access);
 476    end Constant_Reference;
 477
 478    --------------
 479    -- Contains --
 480    --------------
 481
 482    function Contains
 483      (Container : Tree;
 484       Item      : Element_Type) return Boolean
 485    is
 486    begin
 487       return Find (Container, Item) /= No_Element;
 488    end Contains;
 489
 490    ----------
 491    -- Copy --
 492    ----------
 493
 494    function Copy (Source : Tree) return Tree is
 495    begin
 496       return Target : Tree do
 497          Copy_Children
 498            (Source => Source.Root.Children,
 499             Parent => Root_Node (Target),
 500             Count  => Target.Count);
 501
 502          pragma Assert (Target.Count = Source.Count);
 503       end return;
 504    end Copy;
 505
 506    -------------------
 507    -- Copy_Children --
 508    -------------------
 509
 510    procedure Copy_Children
 511      (Source : Children_Type;
 512       Parent : Tree_Node_Access;
 513       Count  : in out Count_Type)
 514    is
 515       pragma Assert (Parent /= null);
 516       pragma Assert (Parent.Children.First = null);
 517       pragma Assert (Parent.Children.Last = null);
 518
 519       CC : Children_Type;
 520       C  : Tree_Node_Access;
 521
 522    begin
 523       --  We special-case the first allocation, in order to establish the
 524       --  representation invariants for type Children_Type.
 525
 526       C := Source.First;
 527
 528       if C = null then
 529          return;
 530       end if;
 531
 532       Copy_Subtree
 533         (Source => C,
 534          Parent => Parent,
 535          Target => CC.First,
 536          Count  => Count);
 537
 538       CC.Last := CC.First;
 539
 540       --  The representation invariants for the Children_Type list have been
 541       --  established, so we can now copy the remaining children of Source.
 542
 543       C := C.Next;
 544       while C /= null loop
 545          Copy_Subtree
 546            (Source => C,
 547             Parent => Parent,
 548             Target => CC.Last.Next,
 549             Count  => Count);
 550
 551          CC.Last.Next.Prev := CC.Last;
 552          CC.Last := CC.Last.Next;
 553
 554          C := C.Next;
 555       end loop;
 556
 557       --  We add the newly-allocated children to their parent list only after
 558       --  the allocation has succeeded, in order to preserve invariants of the
 559       --  parent.
 560
 561       Parent.Children := CC;
 562    end Copy_Children;
 563
 564    ------------------
 565    -- Copy_Subtree --
 566    ------------------
 567
 568    procedure Copy_Subtree
 569      (Target   : in out Tree;
 570       Parent   : Cursor;
 571       Before   : Cursor;
 572       Source   : Cursor)
 573    is
 574       Target_Subtree : Tree_Node_Access;
 575       Target_Count   : Count_Type;
 576
 577    begin
 578       if Parent = No_Element then
 579          raise Constraint_Error with "Parent cursor has no element";
 580       end if;
 581
 582       if Parent.Container /= Target'Unrestricted_Access then
 583          raise Program_Error with "Parent cursor not in container";
 584       end if;
 585
 586       if Before /= No_Element then
 587          if Before.Container /= Target'Unrestricted_Access then
 588             raise Program_Error with "Before cursor not in container";
 589          end if;
 590
 591          if Before.Node.Parent /= Parent.Node then
 592             raise Constraint_Error with "Before cursor not child of Parent";
 593          end if;
 594       end if;
 595
 596       if Source = No_Element then
 597          return;
 598       end if;
 599
 600       if Is_Root (Source) then
 601          raise Constraint_Error with "Source cursor designates root";
 602       end if;
 603
 604       --  Copy_Subtree returns a count of the number of nodes that it
 605       --  allocates, but it works by incrementing the value that is passed in.
 606       --  We must therefore initialize the count value before calling
 607       --  Copy_Subtree.
 608
 609       Target_Count := 0;
 610
 611       Copy_Subtree
 612         (Source => Source.Node,
 613          Parent => Parent.Node,
 614          Target => Target_Subtree,
 615          Count  => Target_Count);
 616
 617       pragma Assert (Target_Subtree /= null);
 618       pragma Assert (Target_Subtree.Parent = Parent.Node);
 619       pragma Assert (Target_Count >= 1);
 620
 621       Insert_Subtree_Node
 622         (Subtree => Target_Subtree,
 623          Parent  => Parent.Node,
 624          Before  => Before.Node);
 625
 626       --  In order for operation Node_Count to complete in O(1) time, we cache
 627       --  the count value. Here we increment the total count by the number of
 628       --  nodes we just inserted.
 629
 630       Target.Count := Target.Count + Target_Count;
 631    end Copy_Subtree;
 632
 633    procedure Copy_Subtree
 634      (Source : Tree_Node_Access;
 635       Parent : Tree_Node_Access;
 636       Target : out Tree_Node_Access;
 637       Count  : in out Count_Type)
 638    is
 639       E : constant Element_Access := new Element_Type'(Source.Element.all);
 640
 641    begin
 642       Target := new Tree_Node_Type'(Element => E,
 643                                     Parent  => Parent,
 644                                     others  => <>);
 645
 646       Count := Count + 1;
 647
 648       Copy_Children
 649         (Source => Source.Children,
 650          Parent => Target,
 651          Count  => Count);
 652    end Copy_Subtree;
 653
 654    -------------------------
 655    -- Deallocate_Children --
 656    -------------------------
 657
 658    procedure Deallocate_Children
 659      (Subtree : Tree_Node_Access;
 660       Count   : in out Count_Type)
 661    is
 662       pragma Assert (Subtree /= null);
 663
 664       CC : Children_Type := Subtree.Children;
 665       C  : Tree_Node_Access;
 666
 667    begin
 668       --  We immediately remove the children from their parent, in order to
 669       --  preserve invariants in case the deallocation fails.
 670
 671       Subtree.Children := Children_Type'(others => null);
 672
 673       while CC.First /= null loop
 674          C := CC.First;
 675          CC.First := C.Next;
 676
 677          Deallocate_Subtree (C, Count);
 678       end loop;
 679    end Deallocate_Children;
 680
 681    ---------------------
 682    -- Deallocate_Node --
 683    ---------------------
 684
 685    procedure Deallocate_Node (X : in out Tree_Node_Access) is
 686       procedure Free_Node is
 687          new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
 688
 689    --  Start of processing for Deallocate_Node
 690
 691    begin
 692       if X /= null then
 693          Free_Element (X.Element);
 694          Free_Node (X);
 695       end if;
 696    end Deallocate_Node;
 697
 698    ------------------------
 699    -- Deallocate_Subtree --
 700    ------------------------
 701
 702    procedure Deallocate_Subtree
 703      (Subtree : in out Tree_Node_Access;
 704       Count   : in out Count_Type)
 705    is
 706    begin
 707       Deallocate_Children (Subtree, Count);
 708       Deallocate_Node (Subtree);
 709       Count := Count + 1;
 710    end Deallocate_Subtree;
 711
 712    ---------------------
 713    -- Delete_Children --
 714    ---------------------
 715
 716    procedure Delete_Children
 717      (Container : in out Tree;
 718       Parent    : Cursor)
 719    is
 720       Count : Count_Type;
 721
 722    begin
 723       if Parent = No_Element then
 724          raise Constraint_Error with "Parent cursor has no element";
 725       end if;
 726
 727       if Parent.Container /= Container'Unrestricted_Access then
 728          raise Program_Error with "Parent cursor not in container";
 729       end if;
 730
 731       if Container.Busy > 0 then
 732          raise Program_Error
 733            with "attempt to tamper with cursors (tree is busy)";
 734       end if;
 735
 736       --  Deallocate_Children returns a count of the number of nodes
 737       --  that it deallocates, but it works by incrementing the
 738       --  value that is passed in. We must therefore initialize
 739       --  the count value before calling Deallocate_Children.
 740
 741       Count := 0;
 742
 743       Deallocate_Children (Parent.Node, Count);
 744       pragma Assert (Count <= Container.Count);
 745
 746       Container.Count := Container.Count - Count;
 747    end Delete_Children;
 748
 749    -----------------
 750    -- Delete_Leaf --
 751    -----------------
 752
 753    procedure Delete_Leaf
 754      (Container : in out Tree;
 755       Position  : in out Cursor)
 756    is
 757       X : Tree_Node_Access;
 758
 759    begin
 760       if Position = No_Element then
 761          raise Constraint_Error with "Position cursor has no element";
 762       end if;
 763
 764       if Position.Container /= Container'Unrestricted_Access then
 765          raise Program_Error with "Position cursor not in container";
 766       end if;
 767
 768       if Is_Root (Position) then
 769          raise Program_Error with "Position cursor designates root";
 770       end if;
 771
 772       if not Is_Leaf (Position) then
 773          raise Constraint_Error with "Position cursor does not designate leaf";
 774       end if;
 775
 776       if Container.Busy > 0 then
 777          raise Program_Error
 778            with "attempt to tamper with cursors (tree is busy)";
 779       end if;
 780
 781       X := Position.Node;
 782       Position := No_Element;
 783
 784       --  Restore represention invariants before attempting the actual
 785       --  deallocation.
 786
 787       Remove_Subtree (X);
 788       Container.Count := Container.Count - 1;
 789
 790       --  It is now safe to attempt the deallocation. This leaf node has been
 791       --  disassociated from the tree, so even if the deallocation fails,
 792       --  representation invariants will remain satisfied.
 793
 794       Deallocate_Node (X);
 795    end Delete_Leaf;
 796
 797    --------------------
 798    -- Delete_Subtree --
 799    --------------------
 800
 801    procedure Delete_Subtree
 802      (Container : in out Tree;
 803       Position  : in out Cursor)
 804    is
 805       X     : Tree_Node_Access;
 806       Count : Count_Type;
 807
 808    begin
 809       if Position = No_Element then
 810          raise Constraint_Error with "Position cursor has no element";
 811       end if;
 812
 813       if Position.Container /= Container'Unrestricted_Access then
 814          raise Program_Error with "Position cursor not in container";
 815       end if;
 816
 817       if Is_Root (Position) then
 818          raise Program_Error with "Position cursor designates root";
 819       end if;
 820
 821       if Container.Busy > 0 then
 822          raise Program_Error
 823            with "attempt to tamper with cursors (tree is busy)";
 824       end if;
 825
 826       X := Position.Node;
 827       Position := No_Element;
 828
 829       --  Here is one case where a deallocation failure can result in the
 830       --  violation of a representation invariant. We disassociate the subtree
 831       --  from the tree now, but we only decrement the total node count after
 832       --  we attempt the deallocation. However, if the deallocation fails, the
 833       --  total node count will not get decremented.
 834
 835       --  One way around this dilemma is to count the nodes in the subtree
 836       --  before attempt to delete the subtree, but that is an O(n) operation,
 837       --  so it does not seem worth it.
 838
 839       --  Perhaps this is much ado about nothing, since the only way
 840       --  deallocation can fail is if Controlled Finalization fails: this
 841       --  propagates Program_Error so all bets are off anyway. ???
 842
 843       Remove_Subtree (X);
 844
 845       --  Deallocate_Subtree returns a count of the number of nodes that it
 846       --  deallocates, but it works by incrementing the value that is passed
 847       --  in. We must therefore initialize the count value before calling
 848       --  Deallocate_Subtree.
 849
 850       Count := 0;
 851
 852       Deallocate_Subtree (X, Count);
 853       pragma Assert (Count <= Container.Count);
 854
 855       --  See comments above. We would prefer to do this sooner, but there's no
 856       --  way to satisfy that goal without an potentially severe execution
 857       --  penalty.
 858
 859       Container.Count := Container.Count - Count;
 860    end Delete_Subtree;
 861
 862    -----------
 863    -- Depth --
 864    -----------
 865
 866    function Depth (Position : Cursor) return Count_Type is
 867       Result : Count_Type;
 868       N      : Tree_Node_Access;
 869
 870    begin
 871       Result := 0;
 872       N := Position.Node;
 873       while N /= null loop
 874          N := N.Parent;
 875          Result := Result + 1;
 876       end loop;
 877
 878       return Result;
 879    end Depth;
 880
 881    -------------
 882    -- Element --
 883    -------------
 884
 885    function Element (Position : Cursor) return Element_Type is
 886    begin
 887       if Position.Container = null then
 888          raise Constraint_Error with "Position cursor has no element";
 889       end if;
 890
 891       if Position.Node = Root_Node (Position.Container.all) then
 892          raise Program_Error with "Position cursor designates root";
 893       end if;
 894
 895       return Position.Node.Element.all;
 896    end Element;
 897
 898    --------------------
 899    -- Equal_Children --
 900    --------------------
 901
 902    function Equal_Children
 903      (Left_Subtree  : Tree_Node_Access;
 904       Right_Subtree : Tree_Node_Access) return Boolean
 905    is
 906       Left_Children  : Children_Type renames Left_Subtree.Children;
 907       Right_Children : Children_Type renames Right_Subtree.Children;
 908
 909       L, R : Tree_Node_Access;
 910
 911    begin
 912       if Child_Count (Left_Children) /= Child_Count (Right_Children) then
 913          return False;
 914       end if;
 915
 916       L := Left_Children.First;
 917       R := Right_Children.First;
 918       while L /= null loop
 919          if not Equal_Subtree (L, R) then
 920             return False;
 921          end if;
 922
 923          L := L.Next;
 924          R := R.Next;
 925       end loop;
 926
 927       return True;
 928    end Equal_Children;
 929
 930    -------------------
 931    -- Equal_Subtree --
 932    -------------------
 933
 934    function Equal_Subtree
 935      (Left_Position  : Cursor;
 936       Right_Position : Cursor) return Boolean
 937    is
 938    begin
 939       if Left_Position = No_Element then
 940          raise Constraint_Error with "Left cursor has no element";
 941       end if;
 942
 943       if Right_Position = No_Element then
 944          raise Constraint_Error with "Right cursor has no element";
 945       end if;
 946
 947       if Left_Position = Right_Position then
 948          return True;
 949       end if;
 950
 951       if Is_Root (Left_Position) then
 952          if not Is_Root (Right_Position) then
 953             return False;
 954          end if;
 955
 956          return Equal_Children (Left_Position.Node, Right_Position.Node);
 957       end if;
 958
 959       if Is_Root (Right_Position) then
 960          return False;
 961       end if;
 962
 963       return Equal_Subtree (Left_Position.Node, Right_Position.Node);
 964    end Equal_Subtree;
 965
 966    function Equal_Subtree
 967      (Left_Subtree  : Tree_Node_Access;
 968       Right_Subtree : Tree_Node_Access) return Boolean
 969    is
 970    begin
 971       if Left_Subtree.Element.all /= Right_Subtree.Element.all then
 972          return False;
 973       end if;
 974
 975       return Equal_Children (Left_Subtree, Right_Subtree);
 976    end Equal_Subtree;
 977
 978    --------------
 979    -- Finalize --
 980    --------------
 981
 982    procedure Finalize (Object : in out Root_Iterator) is
 983       B : Natural renames Object.Container.Busy;
 984    begin
 985       B := B - 1;
 986    end Finalize;
 987
 988    ----------
 989    -- Find --
 990    ----------
 991
 992    function Find
 993      (Container : Tree;
 994       Item      : Element_Type) return Cursor
 995    is
 996       N : constant Tree_Node_Access :=
 997             Find_In_Children (Root_Node (Container), Item);
 998
 999    begin
1000       if N = null then
1001          return No_Element;
1002       end if;
1003
1004       return Cursor'(Container'Unrestricted_Access, N);
1005    end Find;
1006
1007    -----------
1008    -- First --
1009    -----------
1010
1011    overriding function First (Object : Subtree_Iterator) return Cursor is
1012    begin
1013       if Object.Subtree = Root_Node (Object.Container.all) then
1014          return First_Child (Root (Object.Container.all));
1015       else
1016          return Cursor'(Object.Container, Object.Subtree);
1017       end if;
1018    end First;
1019
1020    overriding function First (Object : Child_Iterator) return Cursor is
1021    begin
1022       return First_Child (Cursor'(Object.Container, Object.Subtree));
1023    end First;
1024
1025    -----------------
1026    -- First_Child --
1027    -----------------
1028
1029    function First_Child (Parent : Cursor) return Cursor is
1030       Node : Tree_Node_Access;
1031
1032    begin
1033       if Parent = No_Element then
1034          raise Constraint_Error with "Parent cursor has no element";
1035       end if;
1036
1037       Node := Parent.Node.Children.First;
1038
1039       if Node = null then
1040          return No_Element;
1041       end if;
1042
1043       return Cursor'(Parent.Container, Node);
1044    end First_Child;
1045
1046    -------------------------
1047    -- First_Child_Element --
1048    -------------------------
1049
1050    function First_Child_Element (Parent : Cursor) return Element_Type is
1051    begin
1052       return Element (First_Child (Parent));
1053    end First_Child_Element;
1054
1055    ----------------------
1056    -- Find_In_Children --
1057    ----------------------
1058
1059    function Find_In_Children
1060      (Subtree : Tree_Node_Access;
1061       Item    : Element_Type) return Tree_Node_Access
1062    is
1063       N, Result : Tree_Node_Access;
1064
1065    begin
1066       N := Subtree.Children.First;
1067       while N /= null loop
1068          Result := Find_In_Subtree (N, Item);
1069
1070          if Result /= null then
1071             return Result;
1072          end if;
1073
1074          N := N.Next;
1075       end loop;
1076
1077       return null;
1078    end Find_In_Children;
1079
1080    ---------------------
1081    -- Find_In_Subtree --
1082    ---------------------
1083
1084    function Find_In_Subtree
1085      (Position : Cursor;
1086       Item     : Element_Type) return Cursor
1087    is
1088       Result : Tree_Node_Access;
1089
1090    begin
1091       if Position = No_Element then
1092          raise Constraint_Error with "Position cursor has no element";
1093       end if;
1094
1095       --  Commented-out pending ruling from ARG.  ???
1096
1097       --  if Position.Container /= Container'Unrestricted_Access then
1098       --     raise Program_Error with "Position cursor not in container";
1099       --  end if;
1100
1101       if Is_Root (Position) then
1102          Result := Find_In_Children (Position.Node, Item);
1103
1104       else
1105          Result := Find_In_Subtree (Position.Node, Item);
1106       end if;
1107
1108       if Result = null then
1109          return No_Element;
1110       end if;
1111
1112       return Cursor'(Position.Container, Result);
1113    end Find_In_Subtree;
1114
1115    function Find_In_Subtree
1116      (Subtree : Tree_Node_Access;
1117       Item    : Element_Type) return Tree_Node_Access
1118    is
1119    begin
1120       if Subtree.Element.all = Item then
1121          return Subtree;
1122       end if;
1123
1124       return Find_In_Children (Subtree, Item);
1125    end Find_In_Subtree;
1126
1127    -----------------
1128    -- Has_Element --
1129    -----------------
1130
1131    function Has_Element (Position : Cursor) return Boolean is
1132    begin
1133       if Position = No_Element then
1134          return False;
1135       end if;
1136
1137       return Position.Node.Parent /= null;
1138    end Has_Element;
1139
1140    ------------------
1141    -- Insert_Child --
1142    ------------------
1143
1144    procedure Insert_Child
1145      (Container : in out Tree;
1146       Parent    : Cursor;
1147       Before    : Cursor;
1148       New_Item  : Element_Type;
1149       Count     : Count_Type := 1)
1150    is
1151       Position : Cursor;
1152       pragma Unreferenced (Position);
1153
1154    begin
1155       Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1156    end Insert_Child;
1157
1158    procedure Insert_Child
1159      (Container : in out Tree;
1160       Parent    : Cursor;
1161       Before    : Cursor;
1162       New_Item  : Element_Type;
1163       Position  : out Cursor;
1164       Count     : Count_Type := 1)
1165    is
1166       Last    : Tree_Node_Access;
1167       Element : Element_Access;
1168
1169    begin
1170       if Parent = No_Element then
1171          raise Constraint_Error with "Parent cursor has no element";
1172       end if;
1173
1174       if Parent.Container /= Container'Unrestricted_Access then
1175          raise Program_Error with "Parent cursor not in container";
1176       end if;
1177
1178       if Before /= No_Element then
1179          if Before.Container /= Container'Unrestricted_Access then
1180             raise Program_Error with "Before cursor not in container";
1181          end if;
1182
1183          if Before.Node.Parent /= Parent.Node then
1184             raise Constraint_Error with "Parent cursor not parent of Before";
1185          end if;
1186       end if;
1187
1188       if Count = 0 then
1189          Position := No_Element;  -- Need ruling from ARG ???
1190          return;
1191       end if;
1192
1193       if Container.Busy > 0 then
1194          raise Program_Error
1195            with "attempt to tamper with cursors (tree is busy)";
1196       end if;
1197
1198       Position.Container := Parent.Container;
1199
1200       Element := new Element_Type'(New_Item);
1201       Position.Node := new Tree_Node_Type'(Parent  => Parent.Node,
1202                                            Element => Element,
1203                                            others  => <>);
1204
1205       Last := Position.Node;
1206
1207       for J in Count_Type'(2) .. Count loop
1208          --  Reclaim other nodes if Storage_Error.  ???
1209
1210          Element := new Element_Type'(New_Item);
1211          Last.Next := new Tree_Node_Type'(Parent  => Parent.Node,
1212                                           Prev    => Last,
1213                                           Element => Element,
1214                                           others  => <>);
1215
1216          Last := Last.Next;
1217       end loop;
1218
1219       Insert_Subtree_List
1220         (First  => Position.Node,
1221          Last   => Last,
1222          Parent => Parent.Node,
1223          Before => Before.Node);
1224
1225       --  In order for operation Node_Count to complete in O(1) time, we cache
1226       --  the count value. Here we increment the total count by the number of
1227       --  nodes we just inserted.
1228
1229       Container.Count := Container.Count + Count;
1230    end Insert_Child;
1231
1232    -------------------------
1233    -- Insert_Subtree_List --
1234    -------------------------
1235
1236    procedure Insert_Subtree_List
1237      (First  : Tree_Node_Access;
1238       Last   : Tree_Node_Access;
1239       Parent : Tree_Node_Access;
1240       Before : Tree_Node_Access)
1241    is
1242       pragma Assert (Parent /= null);
1243       C : Children_Type renames Parent.Children;
1244
1245    begin
1246       --  This is a simple utility operation to insert a list of nodes (from
1247       --  First..Last) as children of Parent. The Before node specifies where
1248       --  the new children should be inserted relative to the existing
1249       --  children.
1250
1251       if First = null then
1252          pragma Assert (Last = null);
1253          return;
1254       end if;
1255
1256       pragma Assert (Last /= null);
1257       pragma Assert (Before = null or else Before.Parent = Parent);
1258
1259       if C.First = null then
1260          C.First := First;
1261          C.First.Prev := null;
1262          C.Last := Last;
1263          C.Last.Next := null;
1264
1265       elsif Before = null then  -- means "insert after existing nodes"
1266          C.Last.Next := First;
1267          First.Prev := C.Last;
1268          C.Last := Last;
1269          C.Last.Next := null;
1270
1271       elsif Before = C.First then
1272          Last.Next := C.First;
1273          C.First.Prev := Last;
1274          C.First := First;
1275          C.First.Prev := null;
1276
1277       else
1278          Before.Prev.Next := First;
1279          First.Prev := Before.Prev;
1280          Last.Next := Before;
1281          Before.Prev := Last;
1282       end if;
1283    end Insert_Subtree_List;
1284
1285    -------------------------
1286    -- Insert_Subtree_Node --
1287    -------------------------
1288
1289    procedure Insert_Subtree_Node
1290      (Subtree : Tree_Node_Access;
1291       Parent  : Tree_Node_Access;
1292       Before  : Tree_Node_Access)
1293    is
1294    begin
1295       --  This is a simple wrapper operation to insert a single child into the
1296       --  Parent's children list.
1297
1298       Insert_Subtree_List
1299         (First  => Subtree,
1300          Last   => Subtree,
1301          Parent => Parent,
1302          Before => Before);
1303    end Insert_Subtree_Node;
1304
1305    --------------
1306    -- Is_Empty --
1307    --------------
1308
1309    function Is_Empty (Container : Tree) return Boolean is
1310    begin
1311       return Container.Root.Children.First = null;
1312    end Is_Empty;
1313
1314    -------------
1315    -- Is_Leaf --
1316    -------------
1317
1318    function Is_Leaf (Position : Cursor) return Boolean is
1319    begin
1320       if Position = No_Element then
1321          return False;
1322       end if;
1323
1324       return Position.Node.Children.First = null;
1325    end Is_Leaf;
1326
1327    ------------------
1328    -- Is_Reachable --
1329    ------------------
1330
1331    function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1332       pragma Assert (From /= null);
1333       pragma Assert (To /= null);
1334
1335       N : Tree_Node_Access;
1336
1337    begin
1338       N := From;
1339       while N /= null loop
1340          if N = To then
1341             return True;
1342          end if;
1343
1344          N := N.Parent;
1345       end loop;
1346
1347       return False;
1348    end Is_Reachable;
1349
1350    -------------
1351    -- Is_Root --
1352    -------------
1353
1354    function Is_Root (Position : Cursor) return Boolean is
1355    begin
1356       if Position.Container = null then
1357          return False;
1358       end if;
1359
1360       return Position = Root (Position.Container.all);
1361    end Is_Root;
1362
1363    -------------
1364    -- Iterate --
1365    -------------
1366
1367    procedure Iterate
1368      (Container : Tree;
1369       Process   : not null access procedure (Position : Cursor))
1370    is
1371       B : Natural renames Container'Unrestricted_Access.all.Busy;
1372
1373    begin
1374       B := B + 1;
1375
1376       Iterate_Children
1377         (Container => Container'Unrestricted_Access,
1378          Subtree   => Root_Node (Container),
1379          Process   => Process);
1380
1381       B := B - 1;
1382
1383    exception
1384       when others =>
1385          B := B - 1;
1386          raise;
1387    end Iterate;
1388
1389    function Iterate (Container : Tree)
1390      return Tree_Iterator_Interfaces.Forward_Iterator'Class
1391    is
1392    begin
1393       return Iterate_Subtree (Root (Container));
1394    end Iterate;
1395
1396    ----------------------
1397    -- Iterate_Children --
1398    ----------------------
1399
1400    procedure Iterate_Children
1401      (Parent  : Cursor;
1402       Process : not null access procedure (Position : Cursor))
1403    is
1404    begin
1405       if Parent = No_Element then
1406          raise Constraint_Error with "Parent cursor has no element";
1407       end if;
1408
1409       declare
1410          B : Natural renames Parent.Container.Busy;
1411          C : Tree_Node_Access;
1412
1413       begin
1414          B := B + 1;
1415
1416          C := Parent.Node.Children.First;
1417          while C /= null loop
1418             Process (Position => Cursor'(Parent.Container, Node => C));
1419             C := C.Next;
1420          end loop;
1421
1422          B := B - 1;
1423
1424       exception
1425          when others =>
1426             B := B - 1;
1427             raise;
1428       end;
1429    end Iterate_Children;
1430
1431    procedure Iterate_Children
1432      (Container : Tree_Access;
1433       Subtree   : Tree_Node_Access;
1434       Process   : not null access procedure (Position : Cursor))
1435    is
1436       Node : Tree_Node_Access;
1437
1438    begin
1439       --  This is a helper function to recursively iterate over all the nodes
1440       --  in a subtree, in depth-first fashion. This particular helper just
1441       --  visits the children of this subtree, not the root of the subtree node
1442       --  itself. This is useful when starting from the ultimate root of the
1443       --  entire tree (see Iterate), as that root does not have an element.
1444
1445       Node := Subtree.Children.First;
1446       while Node /= null loop
1447          Iterate_Subtree (Container, Node, Process);
1448          Node := Node.Next;
1449       end loop;
1450    end Iterate_Children;
1451
1452    function Iterate_Children
1453      (Container : Tree;
1454       Parent    : Cursor)
1455      return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1456    is
1457       C : constant Tree_Access := Container'Unrestricted_Access;
1458       B : Natural renames C.Busy;
1459
1460    begin
1461       if Parent = No_Element then
1462          raise Constraint_Error with "Parent cursor has no element";
1463       end if;
1464
1465       if Parent.Container /= C then
1466          raise Program_Error with "Parent cursor not in container";
1467       end if;
1468
1469       return It : constant Child_Iterator :=
1470                     Child_Iterator'(Limited_Controlled with
1471                                       Container => C,
1472                                       Subtree   => Parent.Node)
1473       do
1474          B := B + 1;
1475       end return;
1476    end Iterate_Children;
1477
1478    ---------------------
1479    -- Iterate_Subtree --
1480    ---------------------
1481
1482    function Iterate_Subtree
1483      (Position : Cursor)
1484       return Tree_Iterator_Interfaces.Forward_Iterator'Class
1485    is
1486    begin
1487       if Position = No_Element then
1488          raise Constraint_Error with "Position cursor has no element";
1489       end if;
1490
1491       --  Implement Vet for multiway trees???
1492       --  pragma Assert (Vet (Position), "bad subtree cursor");
1493
1494       declare
1495          B : Natural renames Position.Container.Busy;
1496       begin
1497          return It : constant Subtree_Iterator :=
1498                        (Limited_Controlled with
1499                           Container => Position.Container,
1500                           Subtree   => Position.Node)
1501          do
1502             B := B + 1;
1503          end return;
1504       end;
1505    end Iterate_Subtree;
1506
1507    procedure Iterate_Subtree
1508      (Position  : Cursor;
1509       Process   : not null access procedure (Position : Cursor))
1510    is
1511    begin
1512       if Position = No_Element then
1513          raise Constraint_Error with "Position cursor has no element";
1514       end if;
1515
1516       declare
1517          B : Natural renames Position.Container.Busy;
1518
1519       begin
1520          B := B + 1;
1521
1522          if Is_Root (Position) then
1523             Iterate_Children (Position.Container, Position.Node, Process);
1524          else
1525             Iterate_Subtree (Position.Container, Position.Node, Process);
1526          end if;
1527
1528          B := B - 1;
1529
1530       exception
1531          when others =>
1532             B := B - 1;
1533             raise;
1534       end;
1535    end Iterate_Subtree;
1536
1537    procedure Iterate_Subtree
1538      (Container : Tree_Access;
1539       Subtree   : Tree_Node_Access;
1540       Process   : not null access procedure (Position : Cursor))
1541    is
1542    begin
1543       --  This is a helper function to recursively iterate over all the nodes
1544       --  in a subtree, in depth-first fashion. It first visits the root of the
1545       --  subtree, then visits its children.
1546
1547       Process (Cursor'(Container, Subtree));
1548       Iterate_Children (Container, Subtree, Process);
1549    end Iterate_Subtree;
1550
1551    ----------
1552    -- Last --
1553    ----------
1554
1555    overriding function Last (Object : Child_Iterator) return Cursor is
1556    begin
1557       return Last_Child (Cursor'(Object.Container, Object.Subtree));
1558    end Last;
1559
1560    ----------------
1561    -- Last_Child --
1562    ----------------
1563
1564    function Last_Child (Parent : Cursor) return Cursor is
1565       Node : Tree_Node_Access;
1566
1567    begin
1568       if Parent = No_Element then
1569          raise Constraint_Error with "Parent cursor has no element";
1570       end if;
1571
1572       Node := Parent.Node.Children.Last;
1573
1574       if Node = null then
1575          return No_Element;
1576       end if;
1577
1578       return (Parent.Container, Node);
1579    end Last_Child;
1580
1581    ------------------------
1582    -- Last_Child_Element --
1583    ------------------------
1584
1585    function Last_Child_Element (Parent : Cursor) return Element_Type is
1586    begin
1587       return Element (Last_Child (Parent));
1588    end Last_Child_Element;
1589
1590    ----------
1591    -- Move --
1592    ----------
1593
1594    procedure Move (Target : in out Tree; Source : in out Tree) is
1595       Node : Tree_Node_Access;
1596
1597    begin
1598       if Target'Address = Source'Address then
1599          return;
1600       end if;
1601
1602       if Source.Busy > 0 then
1603          raise Program_Error
1604            with "attempt to tamper with cursors of Source (tree is busy)";
1605       end if;
1606
1607       Target.Clear;  -- checks busy bit
1608
1609       Target.Root.Children := Source.Root.Children;
1610       Source.Root.Children := Children_Type'(others => null);
1611
1612       Node := Target.Root.Children.First;
1613       while Node /= null loop
1614          Node.Parent := Root_Node (Target);
1615          Node := Node.Next;
1616       end loop;
1617
1618       Target.Count := Source.Count;
1619       Source.Count := 0;
1620    end Move;
1621
1622    ----------
1623    -- Next --
1624    ----------
1625
1626    function Next
1627      (Object   : Subtree_Iterator;
1628       Position : Cursor) return Cursor
1629    is
1630       Node : Tree_Node_Access;
1631
1632    begin
1633       if Position.Container = null then
1634          return No_Element;
1635       end if;
1636
1637       if Position.Container /= Object.Container then
1638          raise Program_Error with
1639            "Position cursor of Next designates wrong tree";
1640       end if;
1641
1642       Node := Position.Node;
1643
1644       if Node.Children.First /= null then
1645          return Cursor'(Object.Container, Node.Children.First);
1646       end if;
1647
1648       while Node /= Object.Subtree loop
1649          if Node.Next /= null then
1650             return Cursor'(Object.Container, Node.Next);
1651          end if;
1652
1653          Node := Node.Parent;
1654       end loop;
1655
1656       return No_Element;
1657    end Next;
1658
1659    function Next
1660      (Object   : Child_Iterator;
1661       Position : Cursor) return Cursor
1662    is
1663    begin
1664       if Position.Container = null then
1665          return No_Element;
1666       end if;
1667
1668       if Position.Container /= Object.Container then
1669          raise Program_Error with
1670            "Position cursor of Next designates wrong tree";
1671       end if;
1672
1673       return Next_Sibling (Position);
1674    end Next;
1675
1676    ------------------
1677    -- Next_Sibling --
1678    ------------------
1679
1680    function Next_Sibling (Position : Cursor) return Cursor is
1681    begin
1682       if Position = No_Element then
1683          return No_Element;
1684       end if;
1685
1686       if Position.Node.Next = null then
1687          return No_Element;
1688       end if;
1689
1690       return Cursor'(Position.Container, Position.Node.Next);
1691    end Next_Sibling;
1692
1693    procedure Next_Sibling (Position : in out Cursor) is
1694    begin
1695       Position := Next_Sibling (Position);
1696    end Next_Sibling;
1697
1698    ----------------
1699    -- Node_Count --
1700    ----------------
1701
1702    function Node_Count (Container : Tree) return Count_Type is
1703    begin
1704       --  Container.Count is the number of nodes we have actually allocated. We
1705       --  cache the value specifically so this Node_Count operation can execute
1706       --  in O(1) time, which makes it behave similarly to how the Length
1707       --  selector function behaves for other containers.
1708       --
1709       --  The cached node count value only describes the nodes we have
1710       --  allocated; the root node itself is not included in that count. The
1711       --  Node_Count operation returns a value that includes the root node
1712       --  (because the RM says so), so we must add 1 to our cached value.
1713
1714       return 1 + Container.Count;
1715    end Node_Count;
1716
1717    ------------
1718    -- Parent --
1719    ------------
1720
1721    function Parent (Position : Cursor) return Cursor is
1722    begin
1723       if Position = No_Element then
1724          return No_Element;
1725       end if;
1726
1727       if Position.Node.Parent = null then
1728          return No_Element;
1729       end if;
1730
1731       return Cursor'(Position.Container, Position.Node.Parent);
1732    end Parent;
1733
1734    -------------------
1735    -- Prepent_Child --
1736    -------------------
1737
1738    procedure Prepend_Child
1739      (Container : in out Tree;
1740       Parent    : Cursor;
1741       New_Item  : Element_Type;
1742       Count     : Count_Type := 1)
1743    is
1744       First, Last : Tree_Node_Access;
1745       Element     : Element_Access;
1746
1747    begin
1748       if Parent = No_Element then
1749          raise Constraint_Error with "Parent cursor has no element";
1750       end if;
1751
1752       if Parent.Container /= Container'Unrestricted_Access then
1753          raise Program_Error with "Parent cursor not in container";
1754       end if;
1755
1756       if Count = 0 then
1757          return;
1758       end if;
1759
1760       if Container.Busy > 0 then
1761          raise Program_Error
1762            with "attempt to tamper with cursors (tree is busy)";
1763       end if;
1764
1765       Element := new Element_Type'(New_Item);
1766       First := new Tree_Node_Type'(Parent  => Parent.Node,
1767                                    Element => Element,
1768                                    others  => <>);
1769
1770       Last := First;
1771
1772       for J in Count_Type'(2) .. Count loop
1773
1774          --  Reclaim other nodes if Storage_Error.  ???
1775
1776          Element := new Element_Type'(New_Item);
1777          Last.Next := new Tree_Node_Type'(Parent  => Parent.Node,
1778                                           Prev    => Last,
1779                                           Element => Element,
1780                                           others  => <>);
1781
1782          Last := Last.Next;
1783       end loop;
1784
1785       Insert_Subtree_List
1786         (First  => First,
1787          Last   => Last,
1788          Parent => Parent.Node,
1789          Before => Parent.Node.Children.First);
1790
1791       --  In order for operation Node_Count to complete in O(1) time, we cache
1792       --  the count value. Here we increment the total count by the number of
1793       --  nodes we just inserted.
1794
1795       Container.Count := Container.Count + Count;
1796    end Prepend_Child;
1797
1798    --------------
1799    -- Previous --
1800    --------------
1801
1802    overriding function Previous
1803      (Object   : Child_Iterator;
1804       Position : Cursor) return Cursor
1805    is
1806    begin
1807       if Position.Container = null then
1808          return No_Element;
1809       end if;
1810
1811       if Position.Container /= Object.Container then
1812          raise Program_Error with
1813            "Position cursor of Previous designates wrong tree";
1814       end if;
1815
1816       return Previous_Sibling (Position);
1817    end Previous;
1818
1819    ----------------------
1820    -- Previous_Sibling --
1821    ----------------------
1822
1823    function Previous_Sibling (Position : Cursor) return Cursor is
1824    begin
1825       if Position = No_Element then
1826          return No_Element;
1827       end if;
1828
1829       if Position.Node.Prev = null then
1830          return No_Element;
1831       end if;
1832
1833       return Cursor'(Position.Container, Position.Node.Prev);
1834    end Previous_Sibling;
1835
1836    procedure Previous_Sibling (Position : in out Cursor) is
1837    begin
1838       Position := Previous_Sibling (Position);
1839    end Previous_Sibling;
1840
1841    -------------------
1842    -- Query_Element --
1843    -------------------
1844
1845    procedure Query_Element
1846      (Position : Cursor;
1847       Process  : not null access procedure (Element : Element_Type))
1848    is
1849    begin
1850       if Position = No_Element then
1851          raise Constraint_Error with "Position cursor has no element";
1852       end if;
1853
1854       if Is_Root (Position) then
1855          raise Program_Error with "Position cursor designates root";
1856       end if;
1857
1858       declare
1859          T : Tree renames Position.Container.all'Unrestricted_Access.all;
1860          B : Natural renames T.Busy;
1861          L : Natural renames T.Lock;
1862
1863       begin
1864          B := B + 1;
1865          L := L + 1;
1866
1867          Process (Position.Node.Element.all);
1868
1869          L := L - 1;
1870          B := B - 1;
1871
1872       exception
1873          when others =>
1874             L := L - 1;
1875             B := B - 1;
1876             raise;
1877       end;
1878    end Query_Element;
1879
1880    ----------
1881    -- Read --
1882    ----------
1883
1884    procedure Read
1885      (Stream    : not null access Root_Stream_Type'Class;
1886       Container : out Tree)
1887    is
1888       procedure Read_Children (Subtree : Tree_Node_Access);
1889
1890       function Read_Subtree
1891         (Parent : Tree_Node_Access) return Tree_Node_Access;
1892
1893       Total_Count : Count_Type'Base;
1894       --  Value read from the stream that says how many elements follow
1895
1896       Read_Count : Count_Type'Base;
1897       --  Actual number of elements read from the stream
1898
1899       -------------------
1900       -- Read_Children --
1901       -------------------
1902
1903       procedure Read_Children (Subtree : Tree_Node_Access) is
1904          pragma Assert (Subtree /= null);
1905          pragma Assert (Subtree.Children.First = null);
1906          pragma Assert (Subtree.Children.Last = null);
1907
1908          Count : Count_Type'Base;
1909          --  Number of child subtrees
1910
1911          C : Children_Type;
1912
1913       begin
1914          Count_Type'Read (Stream, Count);
1915
1916          if Count < 0 then
1917             raise Program_Error with "attempt to read from corrupt stream";
1918          end if;
1919
1920          if Count = 0 then
1921             return;
1922          end if;
1923
1924          C.First := Read_Subtree (Parent => Subtree);
1925          C.Last := C.First;
1926
1927          for J in Count_Type'(2) .. Count loop
1928             C.Last.Next := Read_Subtree (Parent => Subtree);
1929             C.Last.Next.Prev := C.Last;
1930             C.Last := C.Last.Next;
1931          end loop;
1932
1933          --  Now that the allocation and reads have completed successfully, it
1934          --  is safe to link the children to their parent.
1935
1936          Subtree.Children := C;
1937       end Read_Children;
1938
1939       ------------------
1940       -- Read_Subtree --
1941       ------------------
1942
1943       function Read_Subtree
1944         (Parent : Tree_Node_Access) return Tree_Node_Access
1945       is
1946          Element : constant Element_Access :=
1947                      new Element_Type'(Element_Type'Input (Stream));
1948
1949          Subtree : constant Tree_Node_Access :=
1950                      new Tree_Node_Type'
1951                            (Parent  => Parent,
1952                             Element => Element,
1953                             others  => <>);
1954
1955       begin
1956          Read_Count := Read_Count + 1;
1957
1958          Read_Children (Subtree);
1959
1960          return Subtree;
1961       end Read_Subtree;
1962
1963    --  Start of processing for Read
1964
1965    begin
1966       Container.Clear;  -- checks busy bit
1967
1968       Count_Type'Read (Stream, Total_Count);
1969
1970       if Total_Count < 0 then
1971          raise Program_Error with "attempt to read from corrupt stream";
1972       end if;
1973
1974       if Total_Count = 0 then
1975          return;
1976       end if;
1977
1978       Read_Count := 0;
1979
1980       Read_Children (Root_Node (Container));
1981
1982       if Read_Count /= Total_Count then
1983          raise Program_Error with "attempt to read from corrupt stream";
1984       end if;
1985
1986       Container.Count := Total_Count;
1987    end Read;
1988
1989    procedure Read
1990      (Stream   : not null access Root_Stream_Type'Class;
1991       Position : out Cursor)
1992    is
1993    begin
1994       raise Program_Error with "attempt to read tree cursor from stream";
1995    end Read;
1996
1997    procedure Read
1998      (Stream : not null access Root_Stream_Type'Class;
1999       Item   : out Reference_Type)
2000    is
2001    begin
2002       raise Program_Error with "attempt to stream reference";
2003    end Read;
2004
2005    procedure Read
2006      (Stream : not null access Root_Stream_Type'Class;
2007       Item   : out Constant_Reference_Type)
2008    is
2009    begin
2010       raise Program_Error with "attempt to stream reference";
2011    end Read;
2012
2013    ---------------
2014    -- Reference --
2015    ---------------
2016
2017    function Reference
2018      (Container : aliased in out Tree;
2019       Position  : Cursor) return Reference_Type
2020    is
2021    begin
2022       if Position.Container = null then
2023          raise Constraint_Error with
2024            "Position cursor has no element";
2025       end if;
2026
2027       if Position.Container /= Container'Unrestricted_Access then
2028          raise Program_Error with
2029            "Position cursor designates wrong container";
2030       end if;
2031
2032       if Position.Node = Root_Node (Container) then
2033          raise Program_Error with "Position cursor designates root";
2034       end if;
2035
2036       if Position.Node.Element = null then
2037          raise Program_Error with "Node has no element";
2038       end if;
2039
2040       --  Implement Vet for multiway tree???
2041       --  pragma Assert (Vet (Position),
2042       --                 "Position cursor in Constant_Reference is bad");
2043
2044       return (Element => Position.Node.Element.all'Access);
2045    end Reference;
2046
2047    --------------------
2048    -- Remove_Subtree --
2049    --------------------
2050
2051    procedure Remove_Subtree (Subtree : Tree_Node_Access) is
2052       C : Children_Type renames Subtree.Parent.Children;
2053
2054    begin
2055       --  This is a utility operation to remove a subtree node from its
2056       --  parent's list of children.
2057
2058       if C.First = Subtree then
2059          pragma Assert (Subtree.Prev = null);
2060
2061          if C.Last = Subtree then
2062             pragma Assert (Subtree.Next = null);
2063             C.First := null;
2064             C.Last := null;
2065
2066          else
2067             C.First := Subtree.Next;
2068             C.First.Prev := null;
2069          end if;
2070
2071       elsif C.Last = Subtree then
2072          pragma Assert (Subtree.Next = null);
2073          C.Last := Subtree.Prev;
2074          C.Last.Next := null;
2075
2076       else
2077          Subtree.Prev.Next := Subtree.Next;
2078          Subtree.Next.Prev := Subtree.Prev;
2079       end if;
2080    end Remove_Subtree;
2081
2082    ----------------------
2083    -- Replace_Element --
2084    ----------------------
2085
2086    procedure Replace_Element
2087      (Container : in out Tree;
2088       Position  : Cursor;
2089       New_Item  : Element_Type)
2090    is
2091       E, X : Element_Access;
2092
2093    begin
2094       if Position = No_Element then
2095          raise Constraint_Error with "Position cursor has no element";
2096       end if;
2097
2098       if Position.Container /= Container'Unrestricted_Access then
2099          raise Program_Error with "Position cursor not in container";
2100       end if;
2101
2102       if Is_Root (Position) then
2103          raise Program_Error with "Position cursor designates root";
2104       end if;
2105
2106       if Container.Lock > 0 then
2107          raise Program_Error
2108            with "attempt to tamper with elements (tree is locked)";
2109       end if;
2110
2111       E := new Element_Type'(New_Item);
2112
2113       X := Position.Node.Element;
2114       Position.Node.Element := E;
2115
2116       Free_Element (X);
2117    end Replace_Element;
2118
2119    ------------------------------
2120    -- Reverse_Iterate_Children --
2121    ------------------------------
2122
2123    procedure Reverse_Iterate_Children
2124      (Parent  : Cursor;
2125       Process : not null access procedure (Position : Cursor))
2126    is
2127    begin
2128       if Parent = No_Element then
2129          raise Constraint_Error with "Parent cursor has no element";
2130       end if;
2131
2132       declare
2133          B : Natural renames Parent.Container.Busy;
2134          C : Tree_Node_Access;
2135
2136       begin
2137          B := B + 1;
2138
2139          C := Parent.Node.Children.Last;
2140          while C /= null loop
2141             Process (Position => Cursor'(Parent.Container, Node => C));
2142             C := C.Prev;
2143          end loop;
2144
2145          B := B - 1;
2146
2147       exception
2148          when others =>
2149             B := B - 1;
2150             raise;
2151       end;
2152    end Reverse_Iterate_Children;
2153
2154    ----------
2155    -- Root --
2156    ----------
2157
2158    function Root (Container : Tree) return Cursor is
2159    begin
2160       return (Container'Unrestricted_Access, Root_Node (Container));
2161    end Root;
2162
2163    ---------------
2164    -- Root_Node --
2165    ---------------
2166
2167    function Root_Node (Container : Tree) return Tree_Node_Access is
2168    begin
2169       return Container.Root'Unrestricted_Access;
2170    end Root_Node;
2171
2172    ---------------------
2173    -- Splice_Children --
2174    ---------------------
2175
2176    procedure Splice_Children
2177      (Target          : in out Tree;
2178       Target_Parent   : Cursor;
2179       Before          : Cursor;
2180       Source          : in out Tree;
2181       Source_Parent   : Cursor)
2182    is
2183       Count : Count_Type;
2184
2185    begin
2186       if Target_Parent = No_Element then
2187          raise Constraint_Error with "Target_Parent cursor has no element";
2188       end if;
2189
2190       if Target_Parent.Container /= Target'Unrestricted_Access then
2191          raise Program_Error
2192            with "Target_Parent cursor not in Target container";
2193       end if;
2194
2195       if Before /= No_Element then
2196          if Before.Container /= Target'Unrestricted_Access then
2197             raise Program_Error
2198               with "Before cursor not in Target container";
2199          end if;
2200
2201          if Before.Node.Parent /= Target_Parent.Node then
2202             raise Constraint_Error
2203               with "Before cursor not child of Target_Parent";
2204          end if;
2205       end if;
2206
2207       if Source_Parent = No_Element then
2208          raise Constraint_Error with "Source_Parent cursor has no element";
2209       end if;
2210
2211       if Source_Parent.Container /= Source'Unrestricted_Access then
2212          raise Program_Error
2213            with "Source_Parent cursor not in Source container";
2214       end if;
2215
2216       if Target'Address = Source'Address then
2217          if Target_Parent = Source_Parent then
2218             return;
2219          end if;
2220
2221          if Target.Busy > 0 then
2222             raise Program_Error
2223               with "attempt to tamper with cursors (Target tree is busy)";
2224          end if;
2225
2226          if Is_Reachable (From => Target_Parent.Node,
2227                           To   => Source_Parent.Node)
2228          then
2229             raise Constraint_Error
2230               with "Source_Parent is ancestor of Target_Parent";
2231          end if;
2232
2233          Splice_Children
2234            (Target_Parent => Target_Parent.Node,
2235             Before        => Before.Node,
2236             Source_Parent => Source_Parent.Node);
2237
2238          return;
2239       end if;
2240
2241       if Target.Busy > 0 then
2242          raise Program_Error
2243            with "attempt to tamper with cursors (Target tree is busy)";
2244       end if;
2245
2246       if Source.Busy > 0 then
2247          raise Program_Error
2248            with "attempt to tamper with cursors (Source tree is busy)";
2249       end if;
2250
2251       --  We cache the count of the nodes we have allocated, so that operation
2252       --  Node_Count can execute in O(1) time. But that means we must count the
2253       --  nodes in the subtree we remove from Source and insert into Target, in
2254       --  order to keep the count accurate.
2255
2256       Count := Subtree_Node_Count (Source_Parent.Node);
2257       pragma Assert (Count >= 1);
2258
2259       Count := Count - 1;  -- because Source_Parent node does not move
2260
2261       Splice_Children
2262         (Target_Parent => Target_Parent.Node,
2263          Before        => Before.Node,
2264          Source_Parent => Source_Parent.Node);
2265
2266       Source.Count := Source.Count - Count;
2267       Target.Count := Target.Count + Count;
2268    end Splice_Children;
2269
2270    procedure Splice_Children
2271      (Container       : in out Tree;
2272       Target_Parent   : Cursor;
2273       Before          : Cursor;
2274       Source_Parent   : Cursor)
2275    is
2276    begin
2277       if Target_Parent = No_Element then
2278          raise Constraint_Error with "Target_Parent cursor has no element";
2279       end if;
2280
2281       if Target_Parent.Container /= Container'Unrestricted_Access then
2282          raise Program_Error
2283            with "Target_Parent cursor not in container";
2284       end if;
2285
2286       if Before /= No_Element then
2287          if Before.Container /= Container'Unrestricted_Access then
2288             raise Program_Error
2289               with "Before cursor not in container";
2290          end if;
2291
2292          if Before.Node.Parent /= Target_Parent.Node then
2293             raise Constraint_Error
2294               with "Before cursor not child of Target_Parent";
2295          end if;
2296       end if;
2297
2298       if Source_Parent = No_Element then
2299          raise Constraint_Error with "Source_Parent cursor has no element";
2300       end if;
2301
2302       if Source_Parent.Container /= Container'Unrestricted_Access then
2303          raise Program_Error
2304            with "Source_Parent cursor not in container";
2305       end if;
2306
2307       if Target_Parent = Source_Parent then
2308          return;
2309       end if;
2310
2311       if Container.Busy > 0 then
2312          raise Program_Error
2313            with "attempt to tamper with cursors (tree is busy)";
2314       end if;
2315
2316       if Is_Reachable (From => Target_Parent.Node,
2317                        To   => Source_Parent.Node)
2318       then
2319          raise Constraint_Error
2320            with "Source_Parent is ancestor of Target_Parent";
2321       end if;
2322
2323       Splice_Children
2324         (Target_Parent => Target_Parent.Node,
2325          Before        => Before.Node,
2326          Source_Parent => Source_Parent.Node);
2327    end Splice_Children;
2328
2329    procedure Splice_Children
2330      (Target_Parent : Tree_Node_Access;
2331       Before        : Tree_Node_Access;
2332       Source_Parent : Tree_Node_Access)
2333    is
2334       CC : constant Children_Type := Source_Parent.Children;
2335       C  : Tree_Node_Access;
2336
2337    begin
2338       --  This is a utility operation to remove the children from Source parent
2339       --  and insert them into Target parent.
2340
2341       Source_Parent.Children := Children_Type'(others => null);
2342
2343       --  Fix up the Parent pointers of each child to designate its new Target
2344       --  parent.
2345
2346       C := CC.First;
2347       while C /= null loop
2348          C.Parent := Target_Parent;
2349          C := C.Next;
2350       end loop;
2351
2352       Insert_Subtree_List
2353         (First  => CC.First,
2354          Last   => CC.Last,
2355          Parent => Target_Parent,
2356          Before => Before);
2357    end Splice_Children;
2358
2359    --------------------
2360    -- Splice_Subtree --
2361    --------------------
2362
2363    procedure Splice_Subtree
2364      (Target   : in out Tree;
2365       Parent   : Cursor;
2366       Before   : Cursor;
2367       Source   : in out Tree;
2368       Position : in out Cursor)
2369    is
2370       Subtree_Count : Count_Type;
2371
2372    begin
2373       if Parent = No_Element then
2374          raise Constraint_Error with "Parent cursor has no element";
2375       end if;
2376
2377       if Parent.Container /= Target'Unrestricted_Access then
2378          raise Program_Error with "Parent cursor not in Target container";
2379       end if;
2380
2381       if Before /= No_Element then
2382          if Before.Container /= Target'Unrestricted_Access then
2383             raise Program_Error with "Before cursor not in Target container";
2384          end if;
2385
2386          if Before.Node.Parent /= Parent.Node then
2387             raise Constraint_Error with "Before cursor not child of Parent";
2388          end if;
2389       end if;
2390
2391       if Position = No_Element then
2392          raise Constraint_Error with "Position cursor has no element";
2393       end if;
2394
2395       if Position.Container /= Source'Unrestricted_Access then
2396          raise Program_Error with "Position cursor not in Source container";
2397       end if;
2398
2399       if Is_Root (Position) then
2400          raise Program_Error with "Position cursor designates root";
2401       end if;
2402
2403       if Target'Address = Source'Address then
2404          if Position.Node.Parent = Parent.Node then
2405             if Position.Node = Before.Node then
2406                return;
2407             end if;
2408
2409             if Position.Node.Next = Before.Node then
2410                return;
2411             end if;
2412          end if;
2413
2414          if Target.Busy > 0 then
2415             raise Program_Error
2416               with "attempt to tamper with cursors (Target tree is busy)";
2417          end if;
2418
2419          if Is_Reachable (From => Parent.Node, To => Position.Node) then
2420             raise Constraint_Error with "Position is ancestor of Parent";
2421          end if;
2422
2423          Remove_Subtree (Position.Node);
2424
2425          Position.Node.Parent := Parent.Node;
2426          Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2427
2428          return;
2429       end if;
2430
2431       if Target.Busy > 0 then
2432          raise Program_Error
2433            with "attempt to tamper with cursors (Target tree is busy)";
2434       end if;
2435
2436       if Source.Busy > 0 then
2437          raise Program_Error
2438            with "attempt to tamper with cursors (Source tree is busy)";
2439       end if;
2440
2441       --  This is an unfortunate feature of this API: we must count the nodes
2442       --  in the subtree that we remove from the source tree, which is an O(n)
2443       --  operation. It would have been better if the Tree container did not
2444       --  have a Node_Count selector; a user that wants the number of nodes in
2445       --  the tree could simply call Subtree_Node_Count, with the understanding
2446       --  that such an operation is O(n).
2447       --
2448       --  Of course, we could choose to implement the Node_Count selector as an
2449       --  O(n) operation, which would turn this splice operation into an O(1)
2450       --  operation. ???
2451
2452       Subtree_Count := Subtree_Node_Count (Position.Node);
2453       pragma Assert (Subtree_Count <= Source.Count);
2454
2455       Remove_Subtree (Position.Node);
2456       Source.Count := Source.Count - Subtree_Count;
2457
2458       Position.Node.Parent := Parent.Node;
2459       Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2460
2461       Target.Count := Target.Count + Subtree_Count;
2462
2463       Position.Container := Target'Unrestricted_Access;
2464    end Splice_Subtree;
2465
2466    procedure Splice_Subtree
2467      (Container : in out Tree;
2468       Parent    : Cursor;
2469       Before    : Cursor;
2470       Position  : Cursor)
2471    is
2472    begin
2473       if Parent = No_Element then
2474          raise Constraint_Error with "Parent cursor has no element";
2475       end if;
2476
2477       if Parent.Container /= Container'Unrestricted_Access then
2478          raise Program_Error with "Parent cursor not in container";
2479       end if;
2480
2481       if Before /= No_Element then
2482          if Before.Container /= Container'Unrestricted_Access then
2483             raise Program_Error with "Before cursor not in container";
2484          end if;
2485
2486          if Before.Node.Parent /= Parent.Node then
2487             raise Constraint_Error with "Before cursor not child of Parent";
2488          end if;
2489       end if;
2490
2491       if Position = No_Element then
2492          raise Constraint_Error with "Position cursor has no element";
2493       end if;
2494
2495       if Position.Container /= Container'Unrestricted_Access then
2496          raise Program_Error with "Position cursor not in container";
2497       end if;
2498
2499       if Is_Root (Position) then
2500
2501          --  Should this be PE instead?  Need ARG confirmation.  ???
2502
2503          raise Constraint_Error with "Position cursor designates root";
2504       end if;
2505
2506       if Position.Node.Parent = Parent.Node then
2507          if Position.Node = Before.Node then
2508             return;
2509          end if;
2510
2511          if Position.Node.Next = Before.Node then
2512             return;
2513          end if;
2514       end if;
2515
2516       if Container.Busy > 0 then
2517          raise Program_Error
2518            with "attempt to tamper with cursors (tree is busy)";
2519       end if;
2520
2521       if Is_Reachable (From => Parent.Node, To => Position.Node) then
2522          raise Constraint_Error with "Position is ancestor of Parent";
2523       end if;
2524
2525       Remove_Subtree (Position.Node);
2526
2527       Position.Node.Parent := Parent.Node;
2528       Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2529    end Splice_Subtree;
2530
2531    ------------------------
2532    -- Subtree_Node_Count --
2533    ------------------------
2534
2535    function Subtree_Node_Count (Position : Cursor) return Count_Type is
2536    begin
2537       if Position = No_Element then
2538          return 0;
2539       end if;
2540
2541       return Subtree_Node_Count (Position.Node);
2542    end Subtree_Node_Count;
2543
2544    function Subtree_Node_Count
2545      (Subtree : Tree_Node_Access) return Count_Type
2546    is
2547       Result : Count_Type;
2548       Node   : Tree_Node_Access;
2549
2550    begin
2551       Result := 1;
2552       Node := Subtree.Children.First;
2553       while Node /= null loop
2554          Result := Result + Subtree_Node_Count (Node);
2555          Node := Node.Next;
2556       end loop;
2557
2558       return Result;
2559    end Subtree_Node_Count;
2560
2561    ----------
2562    -- Swap --
2563    ----------
2564
2565    procedure Swap
2566      (Container : in out Tree;
2567       I, J      : Cursor)
2568    is
2569    begin
2570       if I = No_Element then
2571          raise Constraint_Error with "I cursor has no element";
2572       end if;
2573
2574       if I.Container /= Container'Unrestricted_Access then
2575          raise Program_Error with "I cursor not in container";
2576       end if;
2577
2578       if Is_Root (I) then
2579          raise Program_Error with "I cursor designates root";
2580       end if;
2581
2582       if I = J then -- make this test sooner???
2583          return;
2584       end if;
2585
2586       if J = No_Element then
2587          raise Constraint_Error with "J cursor has no element";
2588       end if;
2589
2590       if J.Container /= Container'Unrestricted_Access then
2591          raise Program_Error with "J cursor not in container";
2592       end if;
2593
2594       if Is_Root (J) then
2595          raise Program_Error with "J cursor designates root";
2596       end if;
2597
2598       if Container.Lock > 0 then
2599          raise Program_Error
2600            with "attempt to tamper with elements (tree is locked)";
2601       end if;
2602
2603       declare
2604          EI : constant Element_Access := I.Node.Element;
2605
2606       begin
2607          I.Node.Element := J.Node.Element;
2608          J.Node.Element := EI;
2609       end;
2610    end Swap;
2611
2612    --------------------
2613    -- Update_Element --
2614    --------------------
2615
2616    procedure Update_Element
2617      (Container : in out Tree;
2618       Position  : Cursor;
2619       Process   : not null access procedure (Element : in out Element_Type))
2620    is
2621    begin
2622       if Position = No_Element then
2623          raise Constraint_Error with "Position cursor has no element";
2624       end if;
2625
2626       if Position.Container /= Container'Unrestricted_Access then
2627          raise Program_Error with "Position cursor not in container";
2628       end if;
2629
2630       if Is_Root (Position) then
2631          raise Program_Error with "Position cursor designates root";
2632       end if;
2633
2634       declare
2635          T : Tree renames Position.Container.all'Unrestricted_Access.all;
2636          B : Natural renames T.Busy;
2637          L : Natural renames T.Lock;
2638
2639       begin
2640          B := B + 1;
2641          L := L + 1;
2642
2643          Process (Position.Node.Element.all);
2644
2645          L := L - 1;
2646          B := B - 1;
2647
2648       exception
2649          when others =>
2650             L := L - 1;
2651             B := B - 1;
2652             raise;
2653       end;
2654    end Update_Element;
2655
2656    -----------
2657    -- Write --
2658    -----------
2659
2660    procedure Write
2661      (Stream    : not null access Root_Stream_Type'Class;
2662       Container : Tree)
2663    is
2664       procedure Write_Children (Subtree : Tree_Node_Access);
2665       procedure Write_Subtree (Subtree : Tree_Node_Access);
2666
2667       --------------------
2668       -- Write_Children --
2669       --------------------
2670
2671       procedure Write_Children (Subtree : Tree_Node_Access) is
2672          CC : Children_Type renames Subtree.Children;
2673          C  : Tree_Node_Access;
2674
2675       begin
2676          Count_Type'Write (Stream, Child_Count (CC));
2677
2678          C := CC.First;
2679          while C /= null loop
2680             Write_Subtree (C);
2681             C := C.Next;
2682          end loop;
2683       end Write_Children;
2684
2685       -------------------
2686       -- Write_Subtree --
2687       -------------------
2688
2689       procedure Write_Subtree (Subtree : Tree_Node_Access) is
2690       begin
2691          Element_Type'Output (Stream, Subtree.Element.all);
2692          Write_Children (Subtree);
2693       end Write_Subtree;
2694
2695    --  Start of processing for Write
2696
2697    begin
2698       Count_Type'Write (Stream, Container.Count);
2699
2700       if Container.Count = 0 then
2701          return;
2702       end if;
2703
2704       Write_Children (Root_Node (Container));
2705    end Write;
2706
2707    procedure Write
2708      (Stream   : not null access Root_Stream_Type'Class;
2709       Position : Cursor)
2710    is
2711    begin
2712       raise Program_Error with "attempt to write tree cursor to stream";
2713    end Write;
2714
2715    procedure Write
2716      (Stream : not null access Root_Stream_Type'Class;
2717       Item   : Reference_Type)
2718    is
2719    begin
2720       raise Program_Error with "attempt to stream reference";
2721    end Write;
2722
2723    procedure Write
2724      (Stream : not null access Root_Stream_Type'Class;
2725       Item   : Constant_Reference_Type)
2726    is
2727    begin
2728       raise Program_Error with "attempt to stream reference";
2729    end Write;
2730
2731 end Ada.Containers.Indefinite_Multiway_Trees;