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