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