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