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