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