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