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