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