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