gcc/ada/a-comutr.adb

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