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