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