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