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