gcc/ada/a-cimutr.adb

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