gcc/ada/a-comutr.adb

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