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