gcc/ada/a-cimutr.adb

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