gcc/ada/a-cimutr.adb

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