1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Finalization; use Ada.Finalization; 31 32with System; use type System.Address; 33 34package body Ada.Containers.Bounded_Multiway_Trees is 35 36 -------------------- 37 -- Root_Iterator -- 38 -------------------- 39 40 type Root_Iterator is abstract new Limited_Controlled and 41 Tree_Iterator_Interfaces.Forward_Iterator with 42 record 43 Container : Tree_Access; 44 Subtree : Count_Type; 45 end record; 46 47 overriding procedure Finalize (Object : in out Root_Iterator); 48 49 ----------------------- 50 -- Subtree_Iterator -- 51 ----------------------- 52 53 type Subtree_Iterator is new Root_Iterator with null record; 54 55 overriding function First (Object : Subtree_Iterator) return Cursor; 56 57 overriding function Next 58 (Object : Subtree_Iterator; 59 Position : Cursor) return Cursor; 60 61 --------------------- 62 -- Child_Iterator -- 63 --------------------- 64 65 type Child_Iterator is new Root_Iterator and 66 Tree_Iterator_Interfaces.Reversible_Iterator with null record; 67 68 overriding function First (Object : Child_Iterator) return Cursor; 69 70 overriding function Next 71 (Object : Child_Iterator; 72 Position : Cursor) return Cursor; 73 74 overriding function Last (Object : Child_Iterator) return Cursor; 75 76 overriding function Previous 77 (Object : Child_Iterator; 78 Position : Cursor) return Cursor; 79 80 ----------------------- 81 -- Local Subprograms -- 82 ----------------------- 83 84 procedure Initialize_Node (Container : in out Tree; Index : Count_Type); 85 procedure Initialize_Root (Container : in out Tree); 86 87 procedure Allocate_Node 88 (Container : in out Tree; 89 Initialize_Element : not null access procedure (Index : Count_Type); 90 New_Node : out Count_Type); 91 92 procedure Allocate_Node 93 (Container : in out Tree; 94 New_Item : Element_Type; 95 New_Node : out Count_Type); 96 97 procedure Allocate_Node 98 (Container : in out Tree; 99 New_Node : out Count_Type); 100 101 procedure Allocate_Node 102 (Container : in out Tree; 103 Stream : not null access Root_Stream_Type'Class; 104 New_Node : out Count_Type); 105 106 procedure Deallocate_Node 107 (Container : in out Tree; 108 X : Count_Type); 109 110 procedure Deallocate_Children 111 (Container : in out Tree; 112 Subtree : Count_Type; 113 Count : in out Count_Type); 114 115 procedure Deallocate_Subtree 116 (Container : in out Tree; 117 Subtree : Count_Type; 118 Count : in out Count_Type); 119 120 function Equal_Children 121 (Left_Tree : Tree; 122 Left_Subtree : Count_Type; 123 Right_Tree : Tree; 124 Right_Subtree : Count_Type) return Boolean; 125 126 function Equal_Subtree 127 (Left_Tree : Tree; 128 Left_Subtree : Count_Type; 129 Right_Tree : Tree; 130 Right_Subtree : Count_Type) return Boolean; 131 132 procedure Iterate_Children 133 (Container : Tree; 134 Subtree : Count_Type; 135 Process : not null access procedure (Position : Cursor)); 136 137 procedure Iterate_Subtree 138 (Container : Tree; 139 Subtree : Count_Type; 140 Process : not null access procedure (Position : Cursor)); 141 142 procedure Copy_Children 143 (Source : Tree; 144 Source_Parent : Count_Type; 145 Target : in out Tree; 146 Target_Parent : Count_Type; 147 Count : in out Count_Type); 148 149 procedure Copy_Subtree 150 (Source : Tree; 151 Source_Subtree : Count_Type; 152 Target : in out Tree; 153 Target_Parent : Count_Type; 154 Target_Subtree : out Count_Type; 155 Count : in out Count_Type); 156 157 function Find_In_Children 158 (Container : Tree; 159 Subtree : Count_Type; 160 Item : Element_Type) return Count_Type; 161 162 function Find_In_Subtree 163 (Container : Tree; 164 Subtree : Count_Type; 165 Item : Element_Type) return Count_Type; 166 167 function Child_Count 168 (Container : Tree; 169 Parent : Count_Type) return Count_Type; 170 171 function Subtree_Node_Count 172 (Container : Tree; 173 Subtree : Count_Type) return Count_Type; 174 175 function Is_Reachable 176 (Container : Tree; 177 From, To : Count_Type) return Boolean; 178 179 function Root_Node (Container : Tree) return Count_Type; 180 181 procedure Remove_Subtree 182 (Container : in out Tree; 183 Subtree : Count_Type); 184 185 procedure Insert_Subtree_Node 186 (Container : in out Tree; 187 Subtree : Count_Type'Base; 188 Parent : Count_Type; 189 Before : Count_Type'Base); 190 191 procedure Insert_Subtree_List 192 (Container : in out Tree; 193 First : Count_Type'Base; 194 Last : Count_Type'Base; 195 Parent : Count_Type; 196 Before : Count_Type'Base); 197 198 procedure Splice_Children 199 (Container : in out Tree; 200 Target_Parent : Count_Type; 201 Before : Count_Type'Base; 202 Source_Parent : Count_Type); 203 204 procedure Splice_Children 205 (Target : in out Tree; 206 Target_Parent : Count_Type; 207 Before : Count_Type'Base; 208 Source : in out Tree; 209 Source_Parent : Count_Type); 210 211 procedure Splice_Subtree 212 (Target : in out Tree; 213 Parent : Count_Type; 214 Before : Count_Type'Base; 215 Source : in out Tree; 216 Position : in out Count_Type); -- source on input, target on output 217 218 --------- 219 -- "=" -- 220 --------- 221 222 function "=" (Left, Right : Tree) return Boolean is 223 begin 224 if Left'Address = Right'Address then 225 return True; 226 end if; 227 228 if Left.Count /= Right.Count then 229 return False; 230 end if; 231 232 if Left.Count = 0 then 233 return True; 234 end if; 235 236 return Equal_Children 237 (Left_Tree => Left, 238 Left_Subtree => Root_Node (Left), 239 Right_Tree => Right, 240 Right_Subtree => Root_Node (Right)); 241 end "="; 242 243 ------------------- 244 -- Allocate_Node -- 245 ------------------- 246 247 procedure Allocate_Node 248 (Container : in out Tree; 249 Initialize_Element : not null access procedure (Index : Count_Type); 250 New_Node : out Count_Type) 251 is 252 begin 253 if Container.Free >= 0 then 254 New_Node := Container.Free; 255 pragma Assert (New_Node in Container.Elements'Range); 256 257 -- We always perform the assignment first, before we change container 258 -- state, in order to defend against exceptions duration assignment. 259 260 Initialize_Element (New_Node); 261 262 Container.Free := Container.Nodes (New_Node).Next; 263 264 else 265 -- A negative free store value means that the links of the nodes in 266 -- the free store have not been initialized. In this case, the nodes 267 -- are physically contiguous in the array, starting at the index that 268 -- is the absolute value of the Container.Free, and continuing until 269 -- the end of the array (Nodes'Last). 270 271 New_Node := abs Container.Free; 272 pragma Assert (New_Node in Container.Elements'Range); 273 274 -- As above, we perform this assignment first, before modifying any 275 -- container state. 276 277 Initialize_Element (New_Node); 278 279 Container.Free := Container.Free - 1; 280 281 if abs Container.Free > Container.Capacity then 282 Container.Free := 0; 283 end if; 284 end if; 285 286 Initialize_Node (Container, New_Node); 287 end Allocate_Node; 288 289 procedure Allocate_Node 290 (Container : in out Tree; 291 New_Item : Element_Type; 292 New_Node : out Count_Type) 293 is 294 procedure Initialize_Element (Index : Count_Type); 295 296 procedure Initialize_Element (Index : Count_Type) is 297 begin 298 Container.Elements (Index) := New_Item; 299 end Initialize_Element; 300 301 begin 302 Allocate_Node (Container, Initialize_Element'Access, New_Node); 303 end Allocate_Node; 304 305 procedure Allocate_Node 306 (Container : in out Tree; 307 Stream : not null access Root_Stream_Type'Class; 308 New_Node : out Count_Type) 309 is 310 procedure Initialize_Element (Index : Count_Type); 311 312 procedure Initialize_Element (Index : Count_Type) is 313 begin 314 Element_Type'Read (Stream, Container.Elements (Index)); 315 end Initialize_Element; 316 317 begin 318 Allocate_Node (Container, Initialize_Element'Access, New_Node); 319 end Allocate_Node; 320 321 procedure Allocate_Node 322 (Container : in out Tree; 323 New_Node : out Count_Type) 324 is 325 procedure Initialize_Element (Index : Count_Type) is null; 326 begin 327 Allocate_Node (Container, Initialize_Element'Access, New_Node); 328 end Allocate_Node; 329 330 ------------------- 331 -- Ancestor_Find -- 332 ------------------- 333 334 function Ancestor_Find 335 (Position : Cursor; 336 Item : Element_Type) return Cursor 337 is 338 R, N : Count_Type; 339 340 begin 341 if Position = No_Element then 342 raise Constraint_Error with "Position cursor has no element"; 343 end if; 344 345 -- Commented-out pending ruling by ARG. ??? 346 347 -- if Position.Container /= Container'Unrestricted_Access then 348 -- raise Program_Error with "Position cursor not in container"; 349 -- end if; 350 351 -- AI-0136 says to raise PE if Position equals the root node. This does 352 -- not seem correct, as this value is just the limiting condition of the 353 -- search. For now we omit this check, pending a ruling from the ARG. 354 -- ??? 355 -- 356 -- if Is_Root (Position) then 357 -- raise Program_Error with "Position cursor designates root"; 358 -- end if; 359 360 R := Root_Node (Position.Container.all); 361 N := Position.Node; 362 while N /= R loop 363 if Position.Container.Elements (N) = Item then 364 return Cursor'(Position.Container, N); 365 end if; 366 367 N := Position.Container.Nodes (N).Parent; 368 end loop; 369 370 return No_Element; 371 end Ancestor_Find; 372 373 ------------------ 374 -- Append_Child -- 375 ------------------ 376 377 procedure Append_Child 378 (Container : in out Tree; 379 Parent : Cursor; 380 New_Item : Element_Type; 381 Count : Count_Type := 1) 382 is 383 Nodes : Tree_Node_Array renames Container.Nodes; 384 First, Last : Count_Type; 385 386 begin 387 if Parent = No_Element then 388 raise Constraint_Error with "Parent cursor has no element"; 389 end if; 390 391 if Parent.Container /= Container'Unrestricted_Access then 392 raise Program_Error with "Parent cursor not in container"; 393 end if; 394 395 if Count = 0 then 396 return; 397 end if; 398 399 if Container.Count > Container.Capacity - Count then 400 raise Constraint_Error 401 with "requested count exceeds available storage"; 402 end if; 403 404 if Container.Busy > 0 then 405 raise Program_Error 406 with "attempt to tamper with cursors (tree is busy)"; 407 end if; 408 409 if Container.Count = 0 then 410 Initialize_Root (Container); 411 end if; 412 413 Allocate_Node (Container, New_Item, First); 414 Nodes (First).Parent := Parent.Node; 415 416 Last := First; 417 for J in Count_Type'(2) .. Count loop 418 Allocate_Node (Container, New_Item, Nodes (Last).Next); 419 Nodes (Nodes (Last).Next).Parent := Parent.Node; 420 Nodes (Nodes (Last).Next).Prev := Last; 421 422 Last := Nodes (Last).Next; 423 end loop; 424 425 Insert_Subtree_List 426 (Container => Container, 427 First => First, 428 Last => Last, 429 Parent => Parent.Node, 430 Before => No_Node); -- means "insert at end of list" 431 432 Container.Count := Container.Count + Count; 433 end Append_Child; 434 435 ------------ 436 -- Assign -- 437 ------------ 438 439 procedure Assign (Target : in out Tree; Source : Tree) is 440 Target_Count : Count_Type; 441 442 begin 443 if Target'Address = Source'Address then 444 return; 445 end if; 446 447 if Target.Capacity < Source.Count then 448 raise Capacity_Error -- ??? 449 with "Target capacity is less than Source count"; 450 end if; 451 452 Target.Clear; -- Checks busy bit 453 454 if Source.Count = 0 then 455 return; 456 end if; 457 458 Initialize_Root (Target); 459 460 -- Copy_Children returns the number of nodes that it allocates, but it 461 -- does this by incrementing the count value passed in, so we must 462 -- initialize the count before calling Copy_Children. 463 464 Target_Count := 0; 465 466 Copy_Children 467 (Source => Source, 468 Source_Parent => Root_Node (Source), 469 Target => Target, 470 Target_Parent => Root_Node (Target), 471 Count => Target_Count); 472 473 pragma Assert (Target_Count = Source.Count); 474 Target.Count := Source.Count; 475 end Assign; 476 477 ----------------- 478 -- Child_Count -- 479 ----------------- 480 481 function Child_Count (Parent : Cursor) return Count_Type is 482 begin 483 if Parent = No_Element then 484 return 0; 485 486 elsif Parent.Container.Count = 0 then 487 pragma Assert (Is_Root (Parent)); 488 return 0; 489 490 else 491 return Child_Count (Parent.Container.all, Parent.Node); 492 end if; 493 end Child_Count; 494 495 function Child_Count 496 (Container : Tree; 497 Parent : Count_Type) return Count_Type 498 is 499 NN : Tree_Node_Array renames Container.Nodes; 500 CC : Children_Type renames NN (Parent).Children; 501 502 Result : Count_Type; 503 Node : Count_Type'Base; 504 505 begin 506 Result := 0; 507 Node := CC.First; 508 while Node > 0 loop 509 Result := Result + 1; 510 Node := NN (Node).Next; 511 end loop; 512 513 return Result; 514 end Child_Count; 515 516 ----------------- 517 -- Child_Depth -- 518 ----------------- 519 520 function Child_Depth (Parent, Child : Cursor) return Count_Type is 521 Result : Count_Type; 522 N : Count_Type'Base; 523 524 begin 525 if Parent = No_Element then 526 raise Constraint_Error with "Parent cursor has no element"; 527 end if; 528 529 if Child = No_Element then 530 raise Constraint_Error with "Child cursor has no element"; 531 end if; 532 533 if Parent.Container /= Child.Container then 534 raise Program_Error with "Parent and Child in different containers"; 535 end if; 536 537 if Parent.Container.Count = 0 then 538 pragma Assert (Is_Root (Parent)); 539 pragma Assert (Child = Parent); 540 return 0; 541 end if; 542 543 Result := 0; 544 N := Child.Node; 545 while N /= Parent.Node loop 546 Result := Result + 1; 547 N := Parent.Container.Nodes (N).Parent; 548 549 if N < 0 then 550 raise Program_Error with "Parent is not ancestor of Child"; 551 end if; 552 end loop; 553 554 return Result; 555 end Child_Depth; 556 557 ----------- 558 -- Clear -- 559 ----------- 560 561 procedure Clear (Container : in out Tree) is 562 Container_Count : constant Count_Type := Container.Count; 563 Count : Count_Type; 564 565 begin 566 if Container.Busy > 0 then 567 raise Program_Error 568 with "attempt to tamper with cursors (tree is busy)"; 569 end if; 570 571 if Container_Count = 0 then 572 return; 573 end if; 574 575 Container.Count := 0; 576 577 -- Deallocate_Children returns the number of nodes that it deallocates, 578 -- but it does this by incrementing the count value that is passed in, 579 -- so we must first initialize the count return value before calling it. 580 581 Count := 0; 582 583 Deallocate_Children 584 (Container => Container, 585 Subtree => Root_Node (Container), 586 Count => Count); 587 588 pragma Assert (Count = Container_Count); 589 end Clear; 590 591 ------------------------ 592 -- Constant_Reference -- 593 ------------------------ 594 595 function Constant_Reference 596 (Container : aliased Tree; 597 Position : Cursor) return Constant_Reference_Type 598 is 599 begin 600 if Position.Container = null then 601 raise Constraint_Error with 602 "Position cursor has no element"; 603 end if; 604 605 if Position.Container /= Container'Unrestricted_Access then 606 raise Program_Error with 607 "Position cursor designates wrong container"; 608 end if; 609 610 if Position.Node = Root_Node (Container) then 611 raise Program_Error with "Position cursor designates root"; 612 end if; 613 614 -- Implement Vet for multiway tree??? 615 -- pragma Assert (Vet (Position), 616 -- "Position cursor in Constant_Reference is bad"); 617 618 return (Element => Container.Elements (Position.Node)'Access); 619 end Constant_Reference; 620 621 -------------- 622 -- Contains -- 623 -------------- 624 625 function Contains 626 (Container : Tree; 627 Item : Element_Type) return Boolean 628 is 629 begin 630 return Find (Container, Item) /= No_Element; 631 end Contains; 632 633 ---------- 634 -- Copy -- 635 ---------- 636 637 function Copy 638 (Source : Tree; 639 Capacity : Count_Type := 0) return Tree 640 is 641 C : Count_Type; 642 643 begin 644 if Capacity = 0 then 645 C := Source.Count; 646 elsif Capacity >= Source.Count then 647 C := Capacity; 648 else 649 raise Capacity_Error with "Capacity value too small"; 650 end if; 651 652 return Target : Tree (Capacity => C) do 653 Initialize_Root (Target); 654 655 if Source.Count = 0 then 656 return; 657 end if; 658 659 Copy_Children 660 (Source => Source, 661 Source_Parent => Root_Node (Source), 662 Target => Target, 663 Target_Parent => Root_Node (Target), 664 Count => Target.Count); 665 666 pragma Assert (Target.Count = Source.Count); 667 end return; 668 end Copy; 669 670 ------------------- 671 -- Copy_Children -- 672 ------------------- 673 674 procedure Copy_Children 675 (Source : Tree; 676 Source_Parent : Count_Type; 677 Target : in out Tree; 678 Target_Parent : Count_Type; 679 Count : in out Count_Type) 680 is 681 S_Nodes : Tree_Node_Array renames Source.Nodes; 682 S_Node : Tree_Node_Type renames S_Nodes (Source_Parent); 683 684 T_Nodes : Tree_Node_Array renames Target.Nodes; 685 T_Node : Tree_Node_Type renames T_Nodes (Target_Parent); 686 687 pragma Assert (T_Node.Children.First <= 0); 688 pragma Assert (T_Node.Children.Last <= 0); 689 690 T_CC : Children_Type; 691 C : Count_Type'Base; 692 693 begin 694 -- We special-case the first allocation, in order to establish the 695 -- representation invariants for type Children_Type. 696 697 C := S_Node.Children.First; 698 699 if C <= 0 then -- source parent has no children 700 return; 701 end if; 702 703 Copy_Subtree 704 (Source => Source, 705 Source_Subtree => C, 706 Target => Target, 707 Target_Parent => Target_Parent, 708 Target_Subtree => T_CC.First, 709 Count => Count); 710 711 T_CC.Last := T_CC.First; 712 713 -- The representation invariants for the Children_Type list have been 714 -- established, so we can now copy the remaining children of Source. 715 716 C := S_Nodes (C).Next; 717 while C > 0 loop 718 Copy_Subtree 719 (Source => Source, 720 Source_Subtree => C, 721 Target => Target, 722 Target_Parent => Target_Parent, 723 Target_Subtree => T_Nodes (T_CC.Last).Next, 724 Count => Count); 725 726 T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last; 727 T_CC.Last := T_Nodes (T_CC.Last).Next; 728 729 C := S_Nodes (C).Next; 730 end loop; 731 732 -- We add the newly-allocated children to their parent list only after 733 -- the allocation has succeeded, in order to preserve invariants of the 734 -- parent. 735 736 T_Node.Children := T_CC; 737 end Copy_Children; 738 739 ------------------ 740 -- Copy_Subtree -- 741 ------------------ 742 743 procedure Copy_Subtree 744 (Target : in out Tree; 745 Parent : Cursor; 746 Before : Cursor; 747 Source : Cursor) 748 is 749 Target_Subtree : Count_Type; 750 Target_Count : Count_Type; 751 752 begin 753 if Parent = No_Element then 754 raise Constraint_Error with "Parent cursor has no element"; 755 end if; 756 757 if Parent.Container /= Target'Unrestricted_Access then 758 raise Program_Error with "Parent cursor not in container"; 759 end if; 760 761 if Before /= No_Element then 762 if Before.Container /= Target'Unrestricted_Access then 763 raise Program_Error with "Before cursor not in container"; 764 end if; 765 766 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then 767 raise Constraint_Error with "Before cursor not child of Parent"; 768 end if; 769 end if; 770 771 if Source = No_Element then 772 return; 773 end if; 774 775 if Is_Root (Source) then 776 raise Constraint_Error with "Source cursor designates root"; 777 end if; 778 779 if Target.Count = 0 then 780 Initialize_Root (Target); 781 end if; 782 783 -- Copy_Subtree returns a count of the number of nodes that it 784 -- allocates, but it works by incrementing the value that is passed 785 -- in. We must therefore initialize the count value before calling 786 -- Copy_Subtree. 787 788 Target_Count := 0; 789 790 Copy_Subtree 791 (Source => Source.Container.all, 792 Source_Subtree => Source.Node, 793 Target => Target, 794 Target_Parent => Parent.Node, 795 Target_Subtree => Target_Subtree, 796 Count => Target_Count); 797 798 Insert_Subtree_Node 799 (Container => Target, 800 Subtree => Target_Subtree, 801 Parent => Parent.Node, 802 Before => Before.Node); 803 804 Target.Count := Target.Count + Target_Count; 805 end Copy_Subtree; 806 807 procedure Copy_Subtree 808 (Source : Tree; 809 Source_Subtree : Count_Type; 810 Target : in out Tree; 811 Target_Parent : Count_Type; 812 Target_Subtree : out Count_Type; 813 Count : in out Count_Type) 814 is 815 T_Nodes : Tree_Node_Array renames Target.Nodes; 816 817 begin 818 -- First we allocate the root of the target subtree. 819 820 Allocate_Node 821 (Container => Target, 822 New_Item => Source.Elements (Source_Subtree), 823 New_Node => Target_Subtree); 824 825 T_Nodes (Target_Subtree).Parent := Target_Parent; 826 Count := Count + 1; 827 828 -- We now have a new subtree (for the Target tree), containing only a 829 -- copy of the corresponding element in the Source subtree. Next we copy 830 -- the children of the Source subtree as children of the new Target 831 -- subtree. 832 833 Copy_Children 834 (Source => Source, 835 Source_Parent => Source_Subtree, 836 Target => Target, 837 Target_Parent => Target_Subtree, 838 Count => Count); 839 end Copy_Subtree; 840 841 ------------------------- 842 -- Deallocate_Children -- 843 ------------------------- 844 845 procedure Deallocate_Children 846 (Container : in out Tree; 847 Subtree : Count_Type; 848 Count : in out Count_Type) 849 is 850 Nodes : Tree_Node_Array renames Container.Nodes; 851 Node : Tree_Node_Type renames Nodes (Subtree); -- parent 852 CC : Children_Type renames Node.Children; 853 C : Count_Type'Base; 854 855 begin 856 while CC.First > 0 loop 857 C := CC.First; 858 CC.First := Nodes (C).Next; 859 860 Deallocate_Subtree (Container, C, Count); 861 end loop; 862 863 CC.Last := 0; 864 end Deallocate_Children; 865 866 --------------------- 867 -- Deallocate_Node -- 868 --------------------- 869 870 procedure Deallocate_Node 871 (Container : in out Tree; 872 X : Count_Type) 873 is 874 NN : Tree_Node_Array renames Container.Nodes; 875 pragma Assert (X > 0); 876 pragma Assert (X <= NN'Last); 877 878 N : Tree_Node_Type renames NN (X); 879 pragma Assert (N.Parent /= X); -- node is active 880 881 begin 882 -- The tree container actually contains two lists: one for the "active" 883 -- nodes that contain elements that have been inserted onto the tree, 884 -- and another for the "inactive" nodes of the free store, from which 885 -- nodes are allocated when a new child is inserted in the tree. 886 887 -- We desire that merely declaring a tree object should have only 888 -- minimal cost; specially, we want to avoid having to initialize the 889 -- free store (to fill in the links), especially if the capacity of the 890 -- tree object is large. 891 892 -- The head of the free list is indicated by Container.Free. If its 893 -- value is non-negative, then the free store has been initialized in 894 -- the "normal" way: Container.Free points to the head of the list of 895 -- free (inactive) nodes, and the value 0 means the free list is 896 -- empty. Each node on the free list has been initialized to point to 897 -- the next free node (via its Next component), and the value 0 means 898 -- that this is the last node of the free list. 899 900 -- If Container.Free is negative, then the links on the free store have 901 -- not been initialized. In this case the link values are implied: the 902 -- free store comprises the components of the node array started with 903 -- the absolute value of Container.Free, and continuing until the end of 904 -- the array (Nodes'Last). 905 906 -- We prefer to lazy-init the free store (in fact, we would prefer to 907 -- not initialize it at all, because such initialization is an O(n) 908 -- operation). The time when we need to actually initialize the nodes in 909 -- the free store is when the node that becomes inactive is not at the 910 -- end of the active list. The free store would then be discontigous and 911 -- so its nodes would need to be linked in the traditional way. 912 913 -- It might be possible to perform an optimization here. Suppose that 914 -- the free store can be represented as having two parts: one comprising 915 -- the non-contiguous inactive nodes linked together in the normal way, 916 -- and the other comprising the contiguous inactive nodes (that are not 917 -- linked together, at the end of the nodes array). This would allow us 918 -- to never have to initialize the free store, except in a lazy way as 919 -- nodes become inactive. ??? 920 921 -- When an element is deleted from the list container, its node becomes 922 -- inactive, and so we set its Parent and Prev components to an 923 -- impossible value (the index of the node itself), to indicate that it 924 -- is now inactive. This provides a useful way to detect a dangling 925 -- cursor reference. 926 927 N.Parent := X; -- Node is deallocated (not on active list) 928 N.Prev := X; 929 930 if Container.Free >= 0 then 931 -- The free store has previously been initialized. All we need to do 932 -- here is link the newly-free'd node onto the free list. 933 934 N.Next := Container.Free; 935 Container.Free := X; 936 937 elsif X + 1 = abs Container.Free then 938 -- The free store has not been initialized, and the node becoming 939 -- inactive immediately precedes the start of the free store. All 940 -- we need to do is move the start of the free store back by one. 941 942 N.Next := X; -- Not strictly necessary, but marginally safer 943 Container.Free := Container.Free + 1; 944 945 else 946 -- The free store has not been initialized, and the node becoming 947 -- inactive does not immediately precede the free store. Here we 948 -- first initialize the free store (meaning the links are given 949 -- values in the traditional way), and then link the newly-free'd 950 -- node onto the head of the free store. 951 952 -- See the comments above for an optimization opportunity. If the 953 -- next link for a node on the free store is negative, then this 954 -- means the remaining nodes on the free store are physically 955 -- contiguous, starting at the absolute value of that index value. 956 -- ??? 957 958 Container.Free := abs Container.Free; 959 960 if Container.Free > Container.Capacity then 961 Container.Free := 0; 962 963 else 964 for J in Container.Free .. Container.Capacity - 1 loop 965 NN (J).Next := J + 1; 966 end loop; 967 968 NN (Container.Capacity).Next := 0; 969 end if; 970 971 NN (X).Next := Container.Free; 972 Container.Free := X; 973 end if; 974 end Deallocate_Node; 975 976 ------------------------ 977 -- Deallocate_Subtree -- 978 ------------------------ 979 980 procedure Deallocate_Subtree 981 (Container : in out Tree; 982 Subtree : Count_Type; 983 Count : in out Count_Type) 984 is 985 begin 986 Deallocate_Children (Container, Subtree, Count); 987 Deallocate_Node (Container, Subtree); 988 Count := Count + 1; 989 end Deallocate_Subtree; 990 991 --------------------- 992 -- Delete_Children -- 993 --------------------- 994 995 procedure Delete_Children 996 (Container : in out Tree; 997 Parent : Cursor) 998 is 999 Count : Count_Type; 1000 1001 begin 1002 if Parent = No_Element then 1003 raise Constraint_Error with "Parent cursor has no element"; 1004 end if; 1005 1006 if Parent.Container /= Container'Unrestricted_Access then 1007 raise Program_Error with "Parent cursor not in container"; 1008 end if; 1009 1010 if Container.Busy > 0 then 1011 raise Program_Error 1012 with "attempt to tamper with cursors (tree is busy)"; 1013 end if; 1014 1015 if Container.Count = 0 then 1016 pragma Assert (Is_Root (Parent)); 1017 return; 1018 end if; 1019 1020 -- Deallocate_Children returns a count of the number of nodes that it 1021 -- deallocates, but it works by incrementing the value that is passed 1022 -- in. We must therefore initialize the count value before calling 1023 -- Deallocate_Children. 1024 1025 Count := 0; 1026 1027 Deallocate_Children (Container, Parent.Node, Count); 1028 pragma Assert (Count <= Container.Count); 1029 1030 Container.Count := Container.Count - Count; 1031 end Delete_Children; 1032 1033 ----------------- 1034 -- Delete_Leaf -- 1035 ----------------- 1036 1037 procedure Delete_Leaf 1038 (Container : in out Tree; 1039 Position : in out Cursor) 1040 is 1041 X : Count_Type; 1042 1043 begin 1044 if Position = No_Element then 1045 raise Constraint_Error with "Position cursor has no element"; 1046 end if; 1047 1048 if Position.Container /= Container'Unrestricted_Access then 1049 raise Program_Error with "Position cursor not in container"; 1050 end if; 1051 1052 if Is_Root (Position) then 1053 raise Program_Error with "Position cursor designates root"; 1054 end if; 1055 1056 if not Is_Leaf (Position) then 1057 raise Constraint_Error with "Position cursor does not designate leaf"; 1058 end if; 1059 1060 if Container.Busy > 0 then 1061 raise Program_Error 1062 with "attempt to tamper with cursors (tree is busy)"; 1063 end if; 1064 1065 X := Position.Node; 1066 Position := No_Element; 1067 1068 Remove_Subtree (Container, X); 1069 Container.Count := Container.Count - 1; 1070 1071 Deallocate_Node (Container, X); 1072 end Delete_Leaf; 1073 1074 -------------------- 1075 -- Delete_Subtree -- 1076 -------------------- 1077 1078 procedure Delete_Subtree 1079 (Container : in out Tree; 1080 Position : in out Cursor) 1081 is 1082 X : Count_Type; 1083 Count : Count_Type; 1084 1085 begin 1086 if Position = No_Element then 1087 raise Constraint_Error with "Position cursor has no element"; 1088 end if; 1089 1090 if Position.Container /= Container'Unrestricted_Access then 1091 raise Program_Error with "Position cursor not in container"; 1092 end if; 1093 1094 if Is_Root (Position) then 1095 raise Program_Error with "Position cursor designates root"; 1096 end if; 1097 1098 if Container.Busy > 0 then 1099 raise Program_Error 1100 with "attempt to tamper with cursors (tree is busy)"; 1101 end if; 1102 1103 X := Position.Node; 1104 Position := No_Element; 1105 1106 Remove_Subtree (Container, X); 1107 1108 -- Deallocate_Subtree returns a count of the number of nodes that it 1109 -- deallocates, but it works by incrementing the value that is passed 1110 -- in. We must therefore initialize the count value before calling 1111 -- Deallocate_Subtree. 1112 1113 Count := 0; 1114 1115 Deallocate_Subtree (Container, X, Count); 1116 pragma Assert (Count <= Container.Count); 1117 1118 Container.Count := Container.Count - Count; 1119 end Delete_Subtree; 1120 1121 ----------- 1122 -- Depth -- 1123 ----------- 1124 1125 function Depth (Position : Cursor) return Count_Type is 1126 Result : Count_Type; 1127 N : Count_Type'Base; 1128 1129 begin 1130 if Position = No_Element then 1131 return 0; 1132 end if; 1133 1134 if Is_Root (Position) then 1135 return 1; 1136 end if; 1137 1138 Result := 0; 1139 N := Position.Node; 1140 while N >= 0 loop 1141 N := Position.Container.Nodes (N).Parent; 1142 Result := Result + 1; 1143 end loop; 1144 1145 return Result; 1146 end Depth; 1147 1148 ------------- 1149 -- Element -- 1150 ------------- 1151 1152 function Element (Position : Cursor) return Element_Type is 1153 begin 1154 if Position.Container = null then 1155 raise Constraint_Error with "Position cursor has no element"; 1156 end if; 1157 1158 if Position.Node = Root_Node (Position.Container.all) then 1159 raise Program_Error with "Position cursor designates root"; 1160 end if; 1161 1162 return Position.Container.Elements (Position.Node); 1163 end Element; 1164 1165 -------------------- 1166 -- Equal_Children -- 1167 -------------------- 1168 1169 function Equal_Children 1170 (Left_Tree : Tree; 1171 Left_Subtree : Count_Type; 1172 Right_Tree : Tree; 1173 Right_Subtree : Count_Type) return Boolean 1174 is 1175 L_NN : Tree_Node_Array renames Left_Tree.Nodes; 1176 R_NN : Tree_Node_Array renames Right_Tree.Nodes; 1177 1178 Left_Children : Children_Type renames L_NN (Left_Subtree).Children; 1179 Right_Children : Children_Type renames R_NN (Right_Subtree).Children; 1180 1181 L, R : Count_Type'Base; 1182 1183 begin 1184 if Child_Count (Left_Tree, Left_Subtree) 1185 /= Child_Count (Right_Tree, Right_Subtree) 1186 then 1187 return False; 1188 end if; 1189 1190 L := Left_Children.First; 1191 R := Right_Children.First; 1192 while L > 0 loop 1193 if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then 1194 return False; 1195 end if; 1196 1197 L := L_NN (L).Next; 1198 R := R_NN (R).Next; 1199 end loop; 1200 1201 return True; 1202 end Equal_Children; 1203 1204 ------------------- 1205 -- Equal_Subtree -- 1206 ------------------- 1207 1208 function Equal_Subtree 1209 (Left_Position : Cursor; 1210 Right_Position : Cursor) return Boolean 1211 is 1212 begin 1213 if Left_Position = No_Element then 1214 raise Constraint_Error with "Left cursor has no element"; 1215 end if; 1216 1217 if Right_Position = No_Element then 1218 raise Constraint_Error with "Right cursor has no element"; 1219 end if; 1220 1221 if Left_Position = Right_Position then 1222 return True; 1223 end if; 1224 1225 if Is_Root (Left_Position) then 1226 if not Is_Root (Right_Position) then 1227 return False; 1228 end if; 1229 1230 if Left_Position.Container.Count = 0 then 1231 return Right_Position.Container.Count = 0; 1232 end if; 1233 1234 if Right_Position.Container.Count = 0 then 1235 return False; 1236 end if; 1237 1238 return Equal_Children 1239 (Left_Tree => Left_Position.Container.all, 1240 Left_Subtree => Left_Position.Node, 1241 Right_Tree => Right_Position.Container.all, 1242 Right_Subtree => Right_Position.Node); 1243 end if; 1244 1245 if Is_Root (Right_Position) then 1246 return False; 1247 end if; 1248 1249 return Equal_Subtree 1250 (Left_Tree => Left_Position.Container.all, 1251 Left_Subtree => Left_Position.Node, 1252 Right_Tree => Right_Position.Container.all, 1253 Right_Subtree => Right_Position.Node); 1254 end Equal_Subtree; 1255 1256 function Equal_Subtree 1257 (Left_Tree : Tree; 1258 Left_Subtree : Count_Type; 1259 Right_Tree : Tree; 1260 Right_Subtree : Count_Type) return Boolean 1261 is 1262 begin 1263 if Left_Tree.Elements (Left_Subtree) /= 1264 Right_Tree.Elements (Right_Subtree) 1265 then 1266 return False; 1267 end if; 1268 1269 return Equal_Children 1270 (Left_Tree => Left_Tree, 1271 Left_Subtree => Left_Subtree, 1272 Right_Tree => Right_Tree, 1273 Right_Subtree => Right_Subtree); 1274 end Equal_Subtree; 1275 1276 -------------- 1277 -- Finalize -- 1278 -------------- 1279 1280 procedure Finalize (Object : in out Root_Iterator) is 1281 B : Natural renames Object.Container.Busy; 1282 begin 1283 B := B - 1; 1284 end Finalize; 1285 1286 ---------- 1287 -- Find -- 1288 ---------- 1289 1290 function Find 1291 (Container : Tree; 1292 Item : Element_Type) return Cursor 1293 is 1294 Node : Count_Type; 1295 1296 begin 1297 if Container.Count = 0 then 1298 return No_Element; 1299 end if; 1300 1301 Node := Find_In_Children (Container, Root_Node (Container), Item); 1302 1303 if Node = 0 then 1304 return No_Element; 1305 end if; 1306 1307 return Cursor'(Container'Unrestricted_Access, Node); 1308 end Find; 1309 1310 ----------- 1311 -- First -- 1312 ----------- 1313 1314 overriding function First (Object : Subtree_Iterator) return Cursor is 1315 begin 1316 if Object.Subtree = Root_Node (Object.Container.all) then 1317 return First_Child (Root (Object.Container.all)); 1318 else 1319 return Cursor'(Object.Container, Object.Subtree); 1320 end if; 1321 end First; 1322 1323 overriding function First (Object : Child_Iterator) return Cursor is 1324 begin 1325 return First_Child (Cursor'(Object.Container, Object.Subtree)); 1326 end First; 1327 1328 ----------------- 1329 -- First_Child -- 1330 ----------------- 1331 1332 function First_Child (Parent : Cursor) return Cursor is 1333 Node : Count_Type'Base; 1334 1335 begin 1336 if Parent = No_Element then 1337 raise Constraint_Error with "Parent cursor has no element"; 1338 end if; 1339 1340 if Parent.Container.Count = 0 then 1341 pragma Assert (Is_Root (Parent)); 1342 return No_Element; 1343 end if; 1344 1345 Node := Parent.Container.Nodes (Parent.Node).Children.First; 1346 1347 if Node <= 0 then 1348 return No_Element; 1349 end if; 1350 1351 return Cursor'(Parent.Container, Node); 1352 end First_Child; 1353 1354 ------------------------- 1355 -- First_Child_Element -- 1356 ------------------------- 1357 1358 function First_Child_Element (Parent : Cursor) return Element_Type is 1359 begin 1360 return Element (First_Child (Parent)); 1361 end First_Child_Element; 1362 1363 ---------------------- 1364 -- Find_In_Children -- 1365 ---------------------- 1366 1367 function Find_In_Children 1368 (Container : Tree; 1369 Subtree : Count_Type; 1370 Item : Element_Type) return Count_Type 1371 is 1372 N : Count_Type'Base; 1373 Result : Count_Type; 1374 1375 begin 1376 N := Container.Nodes (Subtree).Children.First; 1377 while N > 0 loop 1378 Result := Find_In_Subtree (Container, N, Item); 1379 1380 if Result > 0 then 1381 return Result; 1382 end if; 1383 1384 N := Container.Nodes (N).Next; 1385 end loop; 1386 1387 return 0; 1388 end Find_In_Children; 1389 1390 --------------------- 1391 -- Find_In_Subtree -- 1392 --------------------- 1393 1394 function Find_In_Subtree 1395 (Position : Cursor; 1396 Item : Element_Type) return Cursor 1397 is 1398 Result : Count_Type; 1399 1400 begin 1401 if Position = No_Element then 1402 raise Constraint_Error with "Position cursor has no element"; 1403 end if; 1404 1405 -- Commented-out pending ruling by ARG. ??? 1406 1407 -- if Position.Container /= Container'Unrestricted_Access then 1408 -- raise Program_Error with "Position cursor not in container"; 1409 -- end if; 1410 1411 if Position.Container.Count = 0 then 1412 pragma Assert (Is_Root (Position)); 1413 return No_Element; 1414 end if; 1415 1416 if Is_Root (Position) then 1417 Result := Find_In_Children 1418 (Container => Position.Container.all, 1419 Subtree => Position.Node, 1420 Item => Item); 1421 1422 else 1423 Result := Find_In_Subtree 1424 (Container => Position.Container.all, 1425 Subtree => Position.Node, 1426 Item => Item); 1427 end if; 1428 1429 if Result = 0 then 1430 return No_Element; 1431 end if; 1432 1433 return Cursor'(Position.Container, Result); 1434 end Find_In_Subtree; 1435 1436 function Find_In_Subtree 1437 (Container : Tree; 1438 Subtree : Count_Type; 1439 Item : Element_Type) return Count_Type 1440 is 1441 begin 1442 if Container.Elements (Subtree) = Item then 1443 return Subtree; 1444 end if; 1445 1446 return Find_In_Children (Container, Subtree, Item); 1447 end Find_In_Subtree; 1448 1449 ----------------- 1450 -- Has_Element -- 1451 ----------------- 1452 1453 function Has_Element (Position : Cursor) return Boolean is 1454 begin 1455 if Position = No_Element then 1456 return False; 1457 end if; 1458 1459 return Position.Node /= Root_Node (Position.Container.all); 1460 end Has_Element; 1461 1462 --------------------- 1463 -- Initialize_Node -- 1464 --------------------- 1465 1466 procedure Initialize_Node 1467 (Container : in out Tree; 1468 Index : Count_Type) 1469 is 1470 begin 1471 Container.Nodes (Index) := 1472 (Parent => No_Node, 1473 Prev => 0, 1474 Next => 0, 1475 Children => (others => 0)); 1476 end Initialize_Node; 1477 1478 --------------------- 1479 -- Initialize_Root -- 1480 --------------------- 1481 1482 procedure Initialize_Root (Container : in out Tree) is 1483 begin 1484 Initialize_Node (Container, Root_Node (Container)); 1485 end Initialize_Root; 1486 1487 ------------------ 1488 -- Insert_Child -- 1489 ------------------ 1490 1491 procedure Insert_Child 1492 (Container : in out Tree; 1493 Parent : Cursor; 1494 Before : Cursor; 1495 New_Item : Element_Type; 1496 Count : Count_Type := 1) 1497 is 1498 Position : Cursor; 1499 pragma Unreferenced (Position); 1500 1501 begin 1502 Insert_Child (Container, Parent, Before, New_Item, Position, Count); 1503 end Insert_Child; 1504 1505 procedure Insert_Child 1506 (Container : in out Tree; 1507 Parent : Cursor; 1508 Before : Cursor; 1509 New_Item : Element_Type; 1510 Position : out Cursor; 1511 Count : Count_Type := 1) 1512 is 1513 Nodes : Tree_Node_Array renames Container.Nodes; 1514 Last : Count_Type; 1515 1516 begin 1517 if Parent = No_Element then 1518 raise Constraint_Error with "Parent cursor has no element"; 1519 end if; 1520 1521 if Parent.Container /= Container'Unrestricted_Access then 1522 raise Program_Error with "Parent cursor not in container"; 1523 end if; 1524 1525 if Before /= No_Element then 1526 if Before.Container /= Container'Unrestricted_Access then 1527 raise Program_Error with "Before cursor not in container"; 1528 end if; 1529 1530 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then 1531 raise Constraint_Error with "Parent cursor not parent of Before"; 1532 end if; 1533 end if; 1534 1535 if Count = 0 then 1536 Position := No_Element; -- Need ruling from ARG ??? 1537 return; 1538 end if; 1539 1540 if Container.Count > Container.Capacity - Count then 1541 raise Constraint_Error 1542 with "requested count exceeds available storage"; 1543 end if; 1544 1545 if Container.Busy > 0 then 1546 raise Program_Error 1547 with "attempt to tamper with cursors (tree is busy)"; 1548 end if; 1549 1550 if Container.Count = 0 then 1551 Initialize_Root (Container); 1552 end if; 1553 1554 Allocate_Node (Container, New_Item, Position.Node); 1555 Nodes (Position.Node).Parent := Parent.Node; 1556 1557 Last := Position.Node; 1558 for J in Count_Type'(2) .. Count loop 1559 Allocate_Node (Container, New_Item, Nodes (Last).Next); 1560 Nodes (Nodes (Last).Next).Parent := Parent.Node; 1561 Nodes (Nodes (Last).Next).Prev := Last; 1562 1563 Last := Nodes (Last).Next; 1564 end loop; 1565 1566 Insert_Subtree_List 1567 (Container => Container, 1568 First => Position.Node, 1569 Last => Last, 1570 Parent => Parent.Node, 1571 Before => Before.Node); 1572 1573 Container.Count := Container.Count + Count; 1574 1575 Position.Container := Parent.Container; 1576 end Insert_Child; 1577 1578 procedure Insert_Child 1579 (Container : in out Tree; 1580 Parent : Cursor; 1581 Before : Cursor; 1582 Position : out Cursor; 1583 Count : Count_Type := 1) 1584 is 1585 Nodes : Tree_Node_Array renames Container.Nodes; 1586 Last : Count_Type; 1587 1588 begin 1589 if Parent = No_Element then 1590 raise Constraint_Error with "Parent cursor has no element"; 1591 end if; 1592 1593 if Parent.Container /= Container'Unrestricted_Access then 1594 raise Program_Error with "Parent cursor not in container"; 1595 end if; 1596 1597 if Before /= No_Element then 1598 if Before.Container /= Container'Unrestricted_Access then 1599 raise Program_Error with "Before cursor not in container"; 1600 end if; 1601 1602 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then 1603 raise Constraint_Error with "Parent cursor not parent of Before"; 1604 end if; 1605 end if; 1606 1607 if Count = 0 then 1608 Position := No_Element; -- Need ruling from ARG ??? 1609 return; 1610 end if; 1611 1612 if Container.Count > Container.Capacity - Count then 1613 raise Constraint_Error 1614 with "requested count exceeds available storage"; 1615 end if; 1616 1617 if Container.Busy > 0 then 1618 raise Program_Error 1619 with "attempt to tamper with cursors (tree is busy)"; 1620 end if; 1621 1622 if Container.Count = 0 then 1623 Initialize_Root (Container); 1624 end if; 1625 1626 Allocate_Node (Container, Position.Node); 1627 Nodes (Position.Node).Parent := Parent.Node; 1628 1629 Last := Position.Node; 1630 for J in Count_Type'(2) .. Count loop 1631 Allocate_Node (Container, Nodes (Last).Next); 1632 Nodes (Nodes (Last).Next).Parent := Parent.Node; 1633 Nodes (Nodes (Last).Next).Prev := Last; 1634 1635 Last := Nodes (Last).Next; 1636 end loop; 1637 1638 Insert_Subtree_List 1639 (Container => Container, 1640 First => Position.Node, 1641 Last => Last, 1642 Parent => Parent.Node, 1643 Before => Before.Node); 1644 1645 Container.Count := Container.Count + Count; 1646 1647 Position.Container := Parent.Container; 1648 end Insert_Child; 1649 1650 ------------------------- 1651 -- Insert_Subtree_List -- 1652 ------------------------- 1653 1654 procedure Insert_Subtree_List 1655 (Container : in out Tree; 1656 First : Count_Type'Base; 1657 Last : Count_Type'Base; 1658 Parent : Count_Type; 1659 Before : Count_Type'Base) 1660 is 1661 NN : Tree_Node_Array renames Container.Nodes; 1662 N : Tree_Node_Type renames NN (Parent); 1663 CC : Children_Type renames N.Children; 1664 1665 begin 1666 -- This is a simple utility operation to insert a list of nodes 1667 -- (First..Last) as children of Parent. The Before node specifies where 1668 -- the new children should be inserted relative to existing children. 1669 1670 if First <= 0 then 1671 pragma Assert (Last <= 0); 1672 return; 1673 end if; 1674 1675 pragma Assert (Last > 0); 1676 pragma Assert (Before <= 0 or else NN (Before).Parent = Parent); 1677 1678 if CC.First <= 0 then -- no existing children 1679 CC.First := First; 1680 NN (CC.First).Prev := 0; 1681 CC.Last := Last; 1682 NN (CC.Last).Next := 0; 1683 1684 elsif Before <= 0 then -- means "insert after existing nodes" 1685 NN (CC.Last).Next := First; 1686 NN (First).Prev := CC.Last; 1687 CC.Last := Last; 1688 NN (CC.Last).Next := 0; 1689 1690 elsif Before = CC.First then 1691 NN (Last).Next := CC.First; 1692 NN (CC.First).Prev := Last; 1693 CC.First := First; 1694 NN (CC.First).Prev := 0; 1695 1696 else 1697 NN (NN (Before).Prev).Next := First; 1698 NN (First).Prev := NN (Before).Prev; 1699 NN (Last).Next := Before; 1700 NN (Before).Prev := Last; 1701 end if; 1702 end Insert_Subtree_List; 1703 1704 ------------------------- 1705 -- Insert_Subtree_Node -- 1706 ------------------------- 1707 1708 procedure Insert_Subtree_Node 1709 (Container : in out Tree; 1710 Subtree : Count_Type'Base; 1711 Parent : Count_Type; 1712 Before : Count_Type'Base) 1713 is 1714 begin 1715 -- This is a simple wrapper operation to insert a single child into the 1716 -- Parent's children list. 1717 1718 Insert_Subtree_List 1719 (Container => Container, 1720 First => Subtree, 1721 Last => Subtree, 1722 Parent => Parent, 1723 Before => Before); 1724 end Insert_Subtree_Node; 1725 1726 -------------- 1727 -- Is_Empty -- 1728 -------------- 1729 1730 function Is_Empty (Container : Tree) return Boolean is 1731 begin 1732 return Container.Count = 0; 1733 end Is_Empty; 1734 1735 ------------- 1736 -- Is_Leaf -- 1737 ------------- 1738 1739 function Is_Leaf (Position : Cursor) return Boolean is 1740 begin 1741 if Position = No_Element then 1742 return False; 1743 end if; 1744 1745 if Position.Container.Count = 0 then 1746 pragma Assert (Is_Root (Position)); 1747 return True; 1748 end if; 1749 1750 return Position.Container.Nodes (Position.Node).Children.First <= 0; 1751 end Is_Leaf; 1752 1753 ------------------ 1754 -- Is_Reachable -- 1755 ------------------ 1756 1757 function Is_Reachable 1758 (Container : Tree; 1759 From, To : Count_Type) return Boolean 1760 is 1761 Idx : Count_Type; 1762 1763 begin 1764 Idx := From; 1765 while Idx >= 0 loop 1766 if Idx = To then 1767 return True; 1768 end if; 1769 1770 Idx := Container.Nodes (Idx).Parent; 1771 end loop; 1772 1773 return False; 1774 end Is_Reachable; 1775 1776 ------------- 1777 -- Is_Root -- 1778 ------------- 1779 1780 function Is_Root (Position : Cursor) return Boolean is 1781 begin 1782 return 1783 (if Position.Container = null then False 1784 else Position.Node = Root_Node (Position.Container.all)); 1785 end Is_Root; 1786 1787 ------------- 1788 -- Iterate -- 1789 ------------- 1790 1791 procedure Iterate 1792 (Container : Tree; 1793 Process : not null access procedure (Position : Cursor)) 1794 is 1795 B : Natural renames Container'Unrestricted_Access.all.Busy; 1796 1797 begin 1798 if Container.Count = 0 then 1799 return; 1800 end if; 1801 1802 B := B + 1; 1803 1804 Iterate_Children 1805 (Container => Container, 1806 Subtree => Root_Node (Container), 1807 Process => Process); 1808 1809 B := B - 1; 1810 1811 exception 1812 when others => 1813 B := B - 1; 1814 raise; 1815 end Iterate; 1816 1817 function Iterate (Container : Tree) 1818 return Tree_Iterator_Interfaces.Forward_Iterator'Class 1819 is 1820 begin 1821 return Iterate_Subtree (Root (Container)); 1822 end Iterate; 1823 1824 ---------------------- 1825 -- Iterate_Children -- 1826 ---------------------- 1827 1828 procedure Iterate_Children 1829 (Parent : Cursor; 1830 Process : not null access procedure (Position : Cursor)) 1831 is 1832 begin 1833 if Parent = No_Element then 1834 raise Constraint_Error with "Parent cursor has no element"; 1835 end if; 1836 1837 if Parent.Container.Count = 0 then 1838 pragma Assert (Is_Root (Parent)); 1839 return; 1840 end if; 1841 1842 declare 1843 B : Natural renames Parent.Container.Busy; 1844 C : Count_Type; 1845 NN : Tree_Node_Array renames Parent.Container.Nodes; 1846 1847 begin 1848 B := B + 1; 1849 1850 C := NN (Parent.Node).Children.First; 1851 while C > 0 loop 1852 Process (Cursor'(Parent.Container, Node => C)); 1853 C := NN (C).Next; 1854 end loop; 1855 1856 B := B - 1; 1857 1858 exception 1859 when others => 1860 B := B - 1; 1861 raise; 1862 end; 1863 end Iterate_Children; 1864 1865 procedure Iterate_Children 1866 (Container : Tree; 1867 Subtree : Count_Type; 1868 Process : not null access procedure (Position : Cursor)) 1869 is 1870 NN : Tree_Node_Array renames Container.Nodes; 1871 N : Tree_Node_Type renames NN (Subtree); 1872 C : Count_Type; 1873 1874 begin 1875 -- This is a helper function to recursively iterate over all the nodes 1876 -- in a subtree, in depth-first fashion. This particular helper just 1877 -- visits the children of this subtree, not the root of the subtree 1878 -- itself. This is useful when starting from the ultimate root of the 1879 -- entire tree (see Iterate), as that root does not have an element. 1880 1881 C := N.Children.First; 1882 while C > 0 loop 1883 Iterate_Subtree (Container, C, Process); 1884 C := NN (C).Next; 1885 end loop; 1886 end Iterate_Children; 1887 1888 function Iterate_Children 1889 (Container : Tree; 1890 Parent : Cursor) 1891 return Tree_Iterator_Interfaces.Reversible_Iterator'Class 1892 is 1893 C : constant Tree_Access := Container'Unrestricted_Access; 1894 B : Natural renames C.Busy; 1895 1896 begin 1897 if Parent = No_Element then 1898 raise Constraint_Error with "Parent cursor has no element"; 1899 end if; 1900 1901 if Parent.Container /= C then 1902 raise Program_Error with "Parent cursor not in container"; 1903 end if; 1904 1905 return It : constant Child_Iterator := 1906 Child_Iterator'(Limited_Controlled with 1907 Container => C, 1908 Subtree => Parent.Node) 1909 do 1910 B := B + 1; 1911 end return; 1912 end Iterate_Children; 1913 1914 --------------------- 1915 -- Iterate_Subtree -- 1916 --------------------- 1917 1918 function Iterate_Subtree 1919 (Position : Cursor) 1920 return Tree_Iterator_Interfaces.Forward_Iterator'Class 1921 is 1922 begin 1923 if Position = No_Element then 1924 raise Constraint_Error with "Position cursor has no element"; 1925 end if; 1926 1927 -- Implement Vet for multiway trees??? 1928 -- pragma Assert (Vet (Position), "bad subtree cursor"); 1929 1930 declare 1931 B : Natural renames Position.Container.Busy; 1932 begin 1933 return It : constant Subtree_Iterator := 1934 (Limited_Controlled with 1935 Container => Position.Container, 1936 Subtree => Position.Node) 1937 do 1938 B := B + 1; 1939 end return; 1940 end; 1941 end Iterate_Subtree; 1942 1943 procedure Iterate_Subtree 1944 (Position : Cursor; 1945 Process : not null access procedure (Position : Cursor)) 1946 is 1947 begin 1948 if Position = No_Element then 1949 raise Constraint_Error with "Position cursor has no element"; 1950 end if; 1951 1952 if Position.Container.Count = 0 then 1953 pragma Assert (Is_Root (Position)); 1954 return; 1955 end if; 1956 1957 declare 1958 T : Tree renames Position.Container.all; 1959 B : Natural renames T.Busy; 1960 1961 begin 1962 B := B + 1; 1963 1964 if Is_Root (Position) then 1965 Iterate_Children (T, Position.Node, Process); 1966 else 1967 Iterate_Subtree (T, Position.Node, Process); 1968 end if; 1969 1970 B := B - 1; 1971 1972 exception 1973 when others => 1974 B := B - 1; 1975 raise; 1976 end; 1977 end Iterate_Subtree; 1978 1979 procedure Iterate_Subtree 1980 (Container : Tree; 1981 Subtree : Count_Type; 1982 Process : not null access procedure (Position : Cursor)) 1983 is 1984 begin 1985 -- This is a helper function to recursively iterate over all the nodes 1986 -- in a subtree, in depth-first fashion. It first visits the root of the 1987 -- subtree, then visits its children. 1988 1989 Process (Cursor'(Container'Unrestricted_Access, Subtree)); 1990 Iterate_Children (Container, Subtree, Process); 1991 end Iterate_Subtree; 1992 1993 ---------- 1994 -- Last -- 1995 ---------- 1996 1997 overriding function Last (Object : Child_Iterator) return Cursor is 1998 begin 1999 return Last_Child (Cursor'(Object.Container, Object.Subtree)); 2000 end Last; 2001 2002 ---------------- 2003 -- Last_Child -- 2004 ---------------- 2005 2006 function Last_Child (Parent : Cursor) return Cursor is 2007 Node : Count_Type'Base; 2008 2009 begin 2010 if Parent = No_Element then 2011 raise Constraint_Error with "Parent cursor has no element"; 2012 end if; 2013 2014 if Parent.Container.Count = 0 then 2015 pragma Assert (Is_Root (Parent)); 2016 return No_Element; 2017 end if; 2018 2019 Node := Parent.Container.Nodes (Parent.Node).Children.Last; 2020 2021 if Node <= 0 then 2022 return No_Element; 2023 end if; 2024 2025 return Cursor'(Parent.Container, Node); 2026 end Last_Child; 2027 2028 ------------------------ 2029 -- Last_Child_Element -- 2030 ------------------------ 2031 2032 function Last_Child_Element (Parent : Cursor) return Element_Type is 2033 begin 2034 return Element (Last_Child (Parent)); 2035 end Last_Child_Element; 2036 2037 ---------- 2038 -- Move -- 2039 ---------- 2040 2041 procedure Move (Target : in out Tree; Source : in out Tree) is 2042 begin 2043 if Target'Address = Source'Address then 2044 return; 2045 end if; 2046 2047 if Source.Busy > 0 then 2048 raise Program_Error 2049 with "attempt to tamper with cursors of Source (tree is busy)"; 2050 end if; 2051 2052 Target.Assign (Source); 2053 Source.Clear; 2054 end Move; 2055 2056 ---------- 2057 -- Next -- 2058 ---------- 2059 2060 overriding function Next 2061 (Object : Subtree_Iterator; 2062 Position : Cursor) return Cursor 2063 is 2064 begin 2065 if Position.Container = null then 2066 return No_Element; 2067 end if; 2068 2069 if Position.Container /= Object.Container then 2070 raise Program_Error with 2071 "Position cursor of Next designates wrong tree"; 2072 end if; 2073 2074 pragma Assert (Object.Container.Count > 0); 2075 pragma Assert (Position.Node /= Root_Node (Object.Container.all)); 2076 2077 declare 2078 Nodes : Tree_Node_Array renames Object.Container.Nodes; 2079 Node : Count_Type; 2080 2081 begin 2082 Node := Position.Node; 2083 2084 if Nodes (Node).Children.First > 0 then 2085 return Cursor'(Object.Container, Nodes (Node).Children.First); 2086 end if; 2087 2088 while Node /= Object.Subtree loop 2089 if Nodes (Node).Next > 0 then 2090 return Cursor'(Object.Container, Nodes (Node).Next); 2091 end if; 2092 2093 Node := Nodes (Node).Parent; 2094 end loop; 2095 2096 return No_Element; 2097 end; 2098 end Next; 2099 2100 overriding function Next 2101 (Object : Child_Iterator; 2102 Position : Cursor) return Cursor 2103 is 2104 begin 2105 if Position.Container = null then 2106 return No_Element; 2107 end if; 2108 2109 if Position.Container /= Object.Container then 2110 raise Program_Error with 2111 "Position cursor of Next designates wrong tree"; 2112 end if; 2113 2114 pragma Assert (Object.Container.Count > 0); 2115 pragma Assert (Position.Node /= Root_Node (Object.Container.all)); 2116 2117 return Next_Sibling (Position); 2118 end Next; 2119 2120 ------------------ 2121 -- Next_Sibling -- 2122 ------------------ 2123 2124 function Next_Sibling (Position : Cursor) return Cursor is 2125 begin 2126 if Position = No_Element then 2127 return No_Element; 2128 end if; 2129 2130 if Position.Container.Count = 0 then 2131 pragma Assert (Is_Root (Position)); 2132 return No_Element; 2133 end if; 2134 2135 declare 2136 T : Tree renames Position.Container.all; 2137 NN : Tree_Node_Array renames T.Nodes; 2138 N : Tree_Node_Type renames NN (Position.Node); 2139 2140 begin 2141 if N.Next <= 0 then 2142 return No_Element; 2143 end if; 2144 2145 return Cursor'(Position.Container, N.Next); 2146 end; 2147 end Next_Sibling; 2148 2149 procedure Next_Sibling (Position : in out Cursor) is 2150 begin 2151 Position := Next_Sibling (Position); 2152 end Next_Sibling; 2153 2154 ---------------- 2155 -- Node_Count -- 2156 ---------------- 2157 2158 function Node_Count (Container : Tree) return Count_Type is 2159 begin 2160 -- Container.Count is the number of nodes we have actually allocated. We 2161 -- cache the value specifically so this Node_Count operation can execute 2162 -- in O(1) time, which makes it behave similarly to how the Length 2163 -- selector function behaves for other containers. 2164 -- 2165 -- The cached node count value only describes the nodes we have 2166 -- allocated; the root node itself is not included in that count. The 2167 -- Node_Count operation returns a value that includes the root node 2168 -- (because the RM says so), so we must add 1 to our cached value. 2169 2170 return 1 + Container.Count; 2171 end Node_Count; 2172 2173 ------------ 2174 -- Parent -- 2175 ------------ 2176 2177 function Parent (Position : Cursor) return Cursor is 2178 begin 2179 if Position = No_Element then 2180 return No_Element; 2181 end if; 2182 2183 if Position.Container.Count = 0 then 2184 pragma Assert (Is_Root (Position)); 2185 return No_Element; 2186 end if; 2187 2188 declare 2189 T : Tree renames Position.Container.all; 2190 NN : Tree_Node_Array renames T.Nodes; 2191 N : Tree_Node_Type renames NN (Position.Node); 2192 2193 begin 2194 if N.Parent < 0 then 2195 pragma Assert (Position.Node = Root_Node (T)); 2196 return No_Element; 2197 end if; 2198 2199 return Cursor'(Position.Container, N.Parent); 2200 end; 2201 end Parent; 2202 2203 ------------------- 2204 -- Prepend_Child -- 2205 ------------------- 2206 2207 procedure Prepend_Child 2208 (Container : in out Tree; 2209 Parent : Cursor; 2210 New_Item : Element_Type; 2211 Count : Count_Type := 1) 2212 is 2213 Nodes : Tree_Node_Array renames Container.Nodes; 2214 First, Last : Count_Type; 2215 2216 begin 2217 if Parent = No_Element then 2218 raise Constraint_Error with "Parent cursor has no element"; 2219 end if; 2220 2221 if Parent.Container /= Container'Unrestricted_Access then 2222 raise Program_Error with "Parent cursor not in container"; 2223 end if; 2224 2225 if Count = 0 then 2226 return; 2227 end if; 2228 2229 if Container.Count > Container.Capacity - Count then 2230 raise Constraint_Error 2231 with "requested count exceeds available storage"; 2232 end if; 2233 2234 if Container.Busy > 0 then 2235 raise Program_Error 2236 with "attempt to tamper with cursors (tree is busy)"; 2237 end if; 2238 2239 if Container.Count = 0 then 2240 Initialize_Root (Container); 2241 end if; 2242 2243 Allocate_Node (Container, New_Item, First); 2244 Nodes (First).Parent := Parent.Node; 2245 2246 Last := First; 2247 for J in Count_Type'(2) .. Count loop 2248 Allocate_Node (Container, New_Item, Nodes (Last).Next); 2249 Nodes (Nodes (Last).Next).Parent := Parent.Node; 2250 Nodes (Nodes (Last).Next).Prev := Last; 2251 2252 Last := Nodes (Last).Next; 2253 end loop; 2254 2255 Insert_Subtree_List 2256 (Container => Container, 2257 First => First, 2258 Last => Last, 2259 Parent => Parent.Node, 2260 Before => Nodes (Parent.Node).Children.First); 2261 2262 Container.Count := Container.Count + Count; 2263 end Prepend_Child; 2264 2265 -------------- 2266 -- Previous -- 2267 -------------- 2268 2269 overriding function Previous 2270 (Object : Child_Iterator; 2271 Position : Cursor) return Cursor 2272 is 2273 begin 2274 if Position.Container = null then 2275 return No_Element; 2276 end if; 2277 2278 if Position.Container /= Object.Container then 2279 raise Program_Error with 2280 "Position cursor of Previous designates wrong tree"; 2281 end if; 2282 2283 return Previous_Sibling (Position); 2284 end Previous; 2285 2286 ---------------------- 2287 -- Previous_Sibling -- 2288 ---------------------- 2289 2290 function Previous_Sibling (Position : Cursor) return Cursor is 2291 begin 2292 if Position = No_Element then 2293 return No_Element; 2294 end if; 2295 2296 if Position.Container.Count = 0 then 2297 pragma Assert (Is_Root (Position)); 2298 return No_Element; 2299 end if; 2300 2301 declare 2302 T : Tree renames Position.Container.all; 2303 NN : Tree_Node_Array renames T.Nodes; 2304 N : Tree_Node_Type renames NN (Position.Node); 2305 2306 begin 2307 if N.Prev <= 0 then 2308 return No_Element; 2309 end if; 2310 2311 return Cursor'(Position.Container, N.Prev); 2312 end; 2313 end Previous_Sibling; 2314 2315 procedure Previous_Sibling (Position : in out Cursor) is 2316 begin 2317 Position := Previous_Sibling (Position); 2318 end Previous_Sibling; 2319 2320 ------------------- 2321 -- Query_Element -- 2322 ------------------- 2323 2324 procedure Query_Element 2325 (Position : Cursor; 2326 Process : not null access procedure (Element : Element_Type)) 2327 is 2328 begin 2329 if Position = No_Element then 2330 raise Constraint_Error with "Position cursor has no element"; 2331 end if; 2332 2333 if Is_Root (Position) then 2334 raise Program_Error with "Position cursor designates root"; 2335 end if; 2336 2337 declare 2338 T : Tree renames Position.Container.all'Unrestricted_Access.all; 2339 B : Natural renames T.Busy; 2340 L : Natural renames T.Lock; 2341 2342 begin 2343 B := B + 1; 2344 L := L + 1; 2345 2346 Process (Element => T.Elements (Position.Node)); 2347 2348 L := L - 1; 2349 B := B - 1; 2350 2351 exception 2352 when others => 2353 L := L - 1; 2354 B := B - 1; 2355 raise; 2356 end; 2357 end Query_Element; 2358 2359 ---------- 2360 -- Read -- 2361 ---------- 2362 2363 procedure Read 2364 (Stream : not null access Root_Stream_Type'Class; 2365 Container : out Tree) 2366 is 2367 procedure Read_Children (Subtree : Count_Type); 2368 2369 function Read_Subtree 2370 (Parent : Count_Type) return Count_Type; 2371 2372 NN : Tree_Node_Array renames Container.Nodes; 2373 2374 Total_Count : Count_Type'Base; 2375 -- Value read from the stream that says how many elements follow 2376 2377 Read_Count : Count_Type'Base; 2378 -- Actual number of elements read from the stream 2379 2380 ------------------- 2381 -- Read_Children -- 2382 ------------------- 2383 2384 procedure Read_Children (Subtree : Count_Type) is 2385 Count : Count_Type'Base; 2386 -- number of child subtrees 2387 2388 CC : Children_Type; 2389 2390 begin 2391 Count_Type'Read (Stream, Count); 2392 2393 if Count < 0 then 2394 raise Program_Error with "attempt to read from corrupt stream"; 2395 end if; 2396 2397 if Count = 0 then 2398 return; 2399 end if; 2400 2401 CC.First := Read_Subtree (Parent => Subtree); 2402 CC.Last := CC.First; 2403 2404 for J in Count_Type'(2) .. Count loop 2405 NN (CC.Last).Next := Read_Subtree (Parent => Subtree); 2406 NN (NN (CC.Last).Next).Prev := CC.Last; 2407 CC.Last := NN (CC.Last).Next; 2408 end loop; 2409 2410 -- Now that the allocation and reads have completed successfully, it 2411 -- is safe to link the children to their parent. 2412 2413 NN (Subtree).Children := CC; 2414 end Read_Children; 2415 2416 ------------------ 2417 -- Read_Subtree -- 2418 ------------------ 2419 2420 function Read_Subtree 2421 (Parent : Count_Type) return Count_Type 2422 is 2423 Subtree : Count_Type; 2424 2425 begin 2426 Allocate_Node (Container, Stream, Subtree); 2427 Container.Nodes (Subtree).Parent := Parent; 2428 2429 Read_Count := Read_Count + 1; 2430 2431 Read_Children (Subtree); 2432 2433 return Subtree; 2434 end Read_Subtree; 2435 2436 -- Start of processing for Read 2437 2438 begin 2439 Container.Clear; -- checks busy bit 2440 2441 Count_Type'Read (Stream, Total_Count); 2442 2443 if Total_Count < 0 then 2444 raise Program_Error with "attempt to read from corrupt stream"; 2445 end if; 2446 2447 if Total_Count = 0 then 2448 return; 2449 end if; 2450 2451 if Total_Count > Container.Capacity then 2452 raise Capacity_Error -- ??? 2453 with "node count in stream exceeds container capacity"; 2454 end if; 2455 2456 Initialize_Root (Container); 2457 2458 Read_Count := 0; 2459 2460 Read_Children (Root_Node (Container)); 2461 2462 if Read_Count /= Total_Count then 2463 raise Program_Error with "attempt to read from corrupt stream"; 2464 end if; 2465 2466 Container.Count := Total_Count; 2467 end Read; 2468 2469 procedure Read 2470 (Stream : not null access Root_Stream_Type'Class; 2471 Position : out Cursor) 2472 is 2473 begin 2474 raise Program_Error with "attempt to read tree cursor from stream"; 2475 end Read; 2476 2477 procedure Read 2478 (Stream : not null access Root_Stream_Type'Class; 2479 Item : out Reference_Type) 2480 is 2481 begin 2482 raise Program_Error with "attempt to stream reference"; 2483 end Read; 2484 2485 procedure Read 2486 (Stream : not null access Root_Stream_Type'Class; 2487 Item : out Constant_Reference_Type) 2488 is 2489 begin 2490 raise Program_Error with "attempt to stream reference"; 2491 end Read; 2492 2493 --------------- 2494 -- Reference -- 2495 --------------- 2496 2497 function Reference 2498 (Container : aliased in out Tree; 2499 Position : Cursor) return Reference_Type 2500 is 2501 begin 2502 if Position.Container = null then 2503 raise Constraint_Error with 2504 "Position cursor has no element"; 2505 end if; 2506 2507 if Position.Container /= Container'Unrestricted_Access then 2508 raise Program_Error with 2509 "Position cursor designates wrong container"; 2510 end if; 2511 2512 if Position.Node = Root_Node (Container) then 2513 raise Program_Error with "Position cursor designates root"; 2514 end if; 2515 2516 -- Implement Vet for multiway tree??? 2517 -- pragma Assert (Vet (Position), 2518 -- "Position cursor in Constant_Reference is bad"); 2519 2520 return (Element => Container.Elements (Position.Node)'Access); 2521 end Reference; 2522 2523 -------------------- 2524 -- Remove_Subtree -- 2525 -------------------- 2526 2527 procedure Remove_Subtree 2528 (Container : in out Tree; 2529 Subtree : Count_Type) 2530 is 2531 NN : Tree_Node_Array renames Container.Nodes; 2532 N : Tree_Node_Type renames NN (Subtree); 2533 CC : Children_Type renames NN (N.Parent).Children; 2534 2535 begin 2536 -- This is a utility operation to remove a subtree node from its 2537 -- parent's list of children. 2538 2539 if CC.First = Subtree then 2540 pragma Assert (N.Prev <= 0); 2541 2542 if CC.Last = Subtree then 2543 pragma Assert (N.Next <= 0); 2544 CC.First := 0; 2545 CC.Last := 0; 2546 2547 else 2548 CC.First := N.Next; 2549 NN (CC.First).Prev := 0; 2550 end if; 2551 2552 elsif CC.Last = Subtree then 2553 pragma Assert (N.Next <= 0); 2554 CC.Last := N.Prev; 2555 NN (CC.Last).Next := 0; 2556 2557 else 2558 NN (N.Prev).Next := N.Next; 2559 NN (N.Next).Prev := N.Prev; 2560 end if; 2561 end Remove_Subtree; 2562 2563 ---------------------- 2564 -- Replace_Element -- 2565 ---------------------- 2566 2567 procedure Replace_Element 2568 (Container : in out Tree; 2569 Position : Cursor; 2570 New_Item : Element_Type) 2571 is 2572 begin 2573 if Position = No_Element then 2574 raise Constraint_Error with "Position cursor has no element"; 2575 end if; 2576 2577 if Position.Container /= Container'Unrestricted_Access then 2578 raise Program_Error with "Position cursor not in container"; 2579 end if; 2580 2581 if Is_Root (Position) then 2582 raise Program_Error with "Position cursor designates root"; 2583 end if; 2584 2585 if Container.Lock > 0 then 2586 raise Program_Error 2587 with "attempt to tamper with elements (tree is locked)"; 2588 end if; 2589 2590 Container.Elements (Position.Node) := New_Item; 2591 end Replace_Element; 2592 2593 ------------------------------ 2594 -- Reverse_Iterate_Children -- 2595 ------------------------------ 2596 2597 procedure Reverse_Iterate_Children 2598 (Parent : Cursor; 2599 Process : not null access procedure (Position : Cursor)) 2600 is 2601 begin 2602 if Parent = No_Element then 2603 raise Constraint_Error with "Parent cursor has no element"; 2604 end if; 2605 2606 if Parent.Container.Count = 0 then 2607 pragma Assert (Is_Root (Parent)); 2608 return; 2609 end if; 2610 2611 declare 2612 NN : Tree_Node_Array renames Parent.Container.Nodes; 2613 B : Natural renames Parent.Container.Busy; 2614 C : Count_Type; 2615 2616 begin 2617 B := B + 1; 2618 2619 C := NN (Parent.Node).Children.Last; 2620 while C > 0 loop 2621 Process (Cursor'(Parent.Container, Node => C)); 2622 C := NN (C).Prev; 2623 end loop; 2624 2625 B := B - 1; 2626 2627 exception 2628 when others => 2629 B := B - 1; 2630 raise; 2631 end; 2632 end Reverse_Iterate_Children; 2633 2634 ---------- 2635 -- Root -- 2636 ---------- 2637 2638 function Root (Container : Tree) return Cursor is 2639 begin 2640 return (Container'Unrestricted_Access, Root_Node (Container)); 2641 end Root; 2642 2643 --------------- 2644 -- Root_Node -- 2645 --------------- 2646 2647 function Root_Node (Container : Tree) return Count_Type is 2648 pragma Unreferenced (Container); 2649 2650 begin 2651 return 0; 2652 end Root_Node; 2653 2654 --------------------- 2655 -- Splice_Children -- 2656 --------------------- 2657 2658 procedure Splice_Children 2659 (Target : in out Tree; 2660 Target_Parent : Cursor; 2661 Before : Cursor; 2662 Source : in out Tree; 2663 Source_Parent : Cursor) 2664 is 2665 begin 2666 if Target_Parent = No_Element then 2667 raise Constraint_Error with "Target_Parent cursor has no element"; 2668 end if; 2669 2670 if Target_Parent.Container /= Target'Unrestricted_Access then 2671 raise Program_Error 2672 with "Target_Parent cursor not in Target container"; 2673 end if; 2674 2675 if Before /= No_Element then 2676 if Before.Container /= Target'Unrestricted_Access then 2677 raise Program_Error 2678 with "Before cursor not in Target container"; 2679 end if; 2680 2681 if Target.Nodes (Before.Node).Parent /= Target_Parent.Node then 2682 raise Constraint_Error 2683 with "Before cursor not child of Target_Parent"; 2684 end if; 2685 end if; 2686 2687 if Source_Parent = No_Element then 2688 raise Constraint_Error with "Source_Parent cursor has no element"; 2689 end if; 2690 2691 if Source_Parent.Container /= Source'Unrestricted_Access then 2692 raise Program_Error 2693 with "Source_Parent cursor not in Source container"; 2694 end if; 2695 2696 if Source.Count = 0 then 2697 pragma Assert (Is_Root (Source_Parent)); 2698 return; 2699 end if; 2700 2701 if Target'Address = Source'Address then 2702 if Target_Parent = Source_Parent then 2703 return; 2704 end if; 2705 2706 if Target.Busy > 0 then 2707 raise Program_Error 2708 with "attempt to tamper with cursors (Target tree is busy)"; 2709 end if; 2710 2711 if Is_Reachable (Container => Target, 2712 From => Target_Parent.Node, 2713 To => Source_Parent.Node) 2714 then 2715 raise Constraint_Error 2716 with "Source_Parent is ancestor of Target_Parent"; 2717 end if; 2718 2719 Splice_Children 2720 (Container => Target, 2721 Target_Parent => Target_Parent.Node, 2722 Before => Before.Node, 2723 Source_Parent => Source_Parent.Node); 2724 2725 return; 2726 end if; 2727 2728 if Target.Busy > 0 then 2729 raise Program_Error 2730 with "attempt to tamper with cursors (Target tree is busy)"; 2731 end if; 2732 2733 if Source.Busy > 0 then 2734 raise Program_Error 2735 with "attempt to tamper with cursors (Source tree is busy)"; 2736 end if; 2737 2738 if Target.Count = 0 then 2739 Initialize_Root (Target); 2740 end if; 2741 2742 Splice_Children 2743 (Target => Target, 2744 Target_Parent => Target_Parent.Node, 2745 Before => Before.Node, 2746 Source => Source, 2747 Source_Parent => Source_Parent.Node); 2748 end Splice_Children; 2749 2750 procedure Splice_Children 2751 (Container : in out Tree; 2752 Target_Parent : Cursor; 2753 Before : Cursor; 2754 Source_Parent : Cursor) 2755 is 2756 begin 2757 if Target_Parent = No_Element then 2758 raise Constraint_Error with "Target_Parent cursor has no element"; 2759 end if; 2760 2761 if Target_Parent.Container /= Container'Unrestricted_Access then 2762 raise Program_Error 2763 with "Target_Parent cursor not in container"; 2764 end if; 2765 2766 if Before /= No_Element then 2767 if Before.Container /= Container'Unrestricted_Access then 2768 raise Program_Error 2769 with "Before cursor not in container"; 2770 end if; 2771 2772 if Container.Nodes (Before.Node).Parent /= Target_Parent.Node then 2773 raise Constraint_Error 2774 with "Before cursor not child of Target_Parent"; 2775 end if; 2776 end if; 2777 2778 if Source_Parent = No_Element then 2779 raise Constraint_Error with "Source_Parent cursor has no element"; 2780 end if; 2781 2782 if Source_Parent.Container /= Container'Unrestricted_Access then 2783 raise Program_Error 2784 with "Source_Parent cursor not in container"; 2785 end if; 2786 2787 if Target_Parent = Source_Parent then 2788 return; 2789 end if; 2790 2791 pragma Assert (Container.Count > 0); 2792 2793 if Container.Busy > 0 then 2794 raise Program_Error 2795 with "attempt to tamper with cursors (tree is busy)"; 2796 end if; 2797 2798 if Is_Reachable (Container => Container, 2799 From => Target_Parent.Node, 2800 To => Source_Parent.Node) 2801 then 2802 raise Constraint_Error 2803 with "Source_Parent is ancestor of Target_Parent"; 2804 end if; 2805 2806 Splice_Children 2807 (Container => Container, 2808 Target_Parent => Target_Parent.Node, 2809 Before => Before.Node, 2810 Source_Parent => Source_Parent.Node); 2811 end Splice_Children; 2812 2813 procedure Splice_Children 2814 (Container : in out Tree; 2815 Target_Parent : Count_Type; 2816 Before : Count_Type'Base; 2817 Source_Parent : Count_Type) 2818 is 2819 NN : Tree_Node_Array renames Container.Nodes; 2820 CC : constant Children_Type := NN (Source_Parent).Children; 2821 C : Count_Type'Base; 2822 2823 begin 2824 -- This is a utility operation to remove the children from Source parent 2825 -- and insert them into Target parent. 2826 2827 NN (Source_Parent).Children := Children_Type'(others => 0); 2828 2829 -- Fix up the Parent pointers of each child to designate its new Target 2830 -- parent. 2831 2832 C := CC.First; 2833 while C > 0 loop 2834 NN (C).Parent := Target_Parent; 2835 C := NN (C).Next; 2836 end loop; 2837 2838 Insert_Subtree_List 2839 (Container => Container, 2840 First => CC.First, 2841 Last => CC.Last, 2842 Parent => Target_Parent, 2843 Before => Before); 2844 end Splice_Children; 2845 2846 procedure Splice_Children 2847 (Target : in out Tree; 2848 Target_Parent : Count_Type; 2849 Before : Count_Type'Base; 2850 Source : in out Tree; 2851 Source_Parent : Count_Type) 2852 is 2853 S_NN : Tree_Node_Array renames Source.Nodes; 2854 S_CC : Children_Type renames S_NN (Source_Parent).Children; 2855 2856 Target_Count, Source_Count : Count_Type; 2857 T, S : Count_Type'Base; 2858 2859 begin 2860 -- This is a utility operation to copy the children from the Source 2861 -- parent and insert them as children of the Target parent, and then 2862 -- delete them from the Source. (This is not a true splice operation, 2863 -- but it is the best we can do in a bounded form.) The Before position 2864 -- specifies where among the Target parent's exising children the new 2865 -- children are inserted. 2866 2867 -- Before we attempt the insertion, we must count the sources nodes in 2868 -- order to determine whether the target have enough storage 2869 -- available. Note that calculating this value is an O(n) operation. 2870 2871 -- Here is an optimization opportunity: iterate of each children the 2872 -- source explicitly, and keep a running count of the total number of 2873 -- nodes. Compare the running total to the capacity of the target each 2874 -- pass through the loop. This is more efficient than summing the counts 2875 -- of child subtree (which is what Subtree_Node_Count does) and then 2876 -- comparing that total sum to the target's capacity. ??? 2877 2878 -- Here is another possibility. We currently treat the splice as an 2879 -- all-or-nothing proposition: either we can insert all of children of 2880 -- the source, or we raise exception with modifying the target. The 2881 -- price for not causing side-effect is an O(n) determination of the 2882 -- source count. If we are willing to tolerate side-effect, then we 2883 -- could loop over the children of the source, counting that subtree and 2884 -- then immediately inserting it in the target. The issue here is that 2885 -- the test for available storage could fail during some later pass, 2886 -- after children have already been inserted into target. ??? 2887 2888 Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1; 2889 2890 if Source_Count = 0 then 2891 return; 2892 end if; 2893 2894 if Target.Count > Target.Capacity - Source_Count then 2895 raise Capacity_Error -- ??? 2896 with "Source count exceeds available storage on Target"; 2897 end if; 2898 2899 -- Copy_Subtree returns a count of the number of nodes it inserts, but 2900 -- it does this by incrementing the value passed in. Therefore we must 2901 -- initialize the count before calling Copy_Subtree. 2902 2903 Target_Count := 0; 2904 2905 S := S_CC.First; 2906 while S > 0 loop 2907 Copy_Subtree 2908 (Source => Source, 2909 Source_Subtree => S, 2910 Target => Target, 2911 Target_Parent => Target_Parent, 2912 Target_Subtree => T, 2913 Count => Target_Count); 2914 2915 Insert_Subtree_Node 2916 (Container => Target, 2917 Subtree => T, 2918 Parent => Target_Parent, 2919 Before => Before); 2920 2921 S := S_NN (S).Next; 2922 end loop; 2923 2924 pragma Assert (Target_Count = Source_Count); 2925 Target.Count := Target.Count + Target_Count; 2926 2927 -- As with Copy_Subtree, operation Deallocate_Children returns a count 2928 -- of the number of nodes it deallocates, but it works by incrementing 2929 -- the value passed in. We must therefore initialize the count before 2930 -- calling it. 2931 2932 Source_Count := 0; 2933 2934 Deallocate_Children (Source, Source_Parent, Source_Count); 2935 pragma Assert (Source_Count = Target_Count); 2936 2937 Source.Count := Source.Count - Source_Count; 2938 end Splice_Children; 2939 2940 -------------------- 2941 -- Splice_Subtree -- 2942 -------------------- 2943 2944 procedure Splice_Subtree 2945 (Target : in out Tree; 2946 Parent : Cursor; 2947 Before : Cursor; 2948 Source : in out Tree; 2949 Position : in out Cursor) 2950 is 2951 begin 2952 if Parent = No_Element then 2953 raise Constraint_Error with "Parent cursor has no element"; 2954 end if; 2955 2956 if Parent.Container /= Target'Unrestricted_Access then 2957 raise Program_Error with "Parent cursor not in Target container"; 2958 end if; 2959 2960 if Before /= No_Element then 2961 if Before.Container /= Target'Unrestricted_Access then 2962 raise Program_Error with "Before cursor not in Target container"; 2963 end if; 2964 2965 if Target.Nodes (Before.Node).Parent /= Parent.Node then 2966 raise Constraint_Error with "Before cursor not child of Parent"; 2967 end if; 2968 end if; 2969 2970 if Position = No_Element then 2971 raise Constraint_Error with "Position cursor has no element"; 2972 end if; 2973 2974 if Position.Container /= Source'Unrestricted_Access then 2975 raise Program_Error with "Position cursor not in Source container"; 2976 end if; 2977 2978 if Is_Root (Position) then 2979 raise Program_Error with "Position cursor designates root"; 2980 end if; 2981 2982 if Target'Address = Source'Address then 2983 if Target.Nodes (Position.Node).Parent = Parent.Node then 2984 if Before = No_Element then 2985 if Target.Nodes (Position.Node).Next <= 0 then -- last child 2986 return; 2987 end if; 2988 2989 elsif Position.Node = Before.Node then 2990 return; 2991 2992 elsif Target.Nodes (Position.Node).Next = Before.Node then 2993 return; 2994 end if; 2995 end if; 2996 2997 if Target.Busy > 0 then 2998 raise Program_Error 2999 with "attempt to tamper with cursors (Target tree is busy)"; 3000 end if; 3001 3002 if Is_Reachable (Container => Target, 3003 From => Parent.Node, 3004 To => Position.Node) 3005 then 3006 raise Constraint_Error with "Position is ancestor of Parent"; 3007 end if; 3008 3009 Remove_Subtree (Target, Position.Node); 3010 3011 Target.Nodes (Position.Node).Parent := Parent.Node; 3012 Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node); 3013 3014 return; 3015 end if; 3016 3017 if Target.Busy > 0 then 3018 raise Program_Error 3019 with "attempt to tamper with cursors (Target tree is busy)"; 3020 end if; 3021 3022 if Source.Busy > 0 then 3023 raise Program_Error 3024 with "attempt to tamper with cursors (Source tree is busy)"; 3025 end if; 3026 3027 if Target.Count = 0 then 3028 Initialize_Root (Target); 3029 end if; 3030 3031 Splice_Subtree 3032 (Target => Target, 3033 Parent => Parent.Node, 3034 Before => Before.Node, 3035 Source => Source, 3036 Position => Position.Node); -- modified during call 3037 3038 Position.Container := Target'Unrestricted_Access; 3039 end Splice_Subtree; 3040 3041 procedure Splice_Subtree 3042 (Container : in out Tree; 3043 Parent : Cursor; 3044 Before : Cursor; 3045 Position : Cursor) 3046 is 3047 begin 3048 if Parent = No_Element then 3049 raise Constraint_Error with "Parent cursor has no element"; 3050 end if; 3051 3052 if Parent.Container /= Container'Unrestricted_Access then 3053 raise Program_Error with "Parent cursor not in container"; 3054 end if; 3055 3056 if Before /= No_Element then 3057 if Before.Container /= Container'Unrestricted_Access then 3058 raise Program_Error with "Before cursor not in container"; 3059 end if; 3060 3061 if Container.Nodes (Before.Node).Parent /= Parent.Node then 3062 raise Constraint_Error with "Before cursor not child of Parent"; 3063 end if; 3064 end if; 3065 3066 if Position = No_Element then 3067 raise Constraint_Error with "Position cursor has no element"; 3068 end if; 3069 3070 if Position.Container /= Container'Unrestricted_Access then 3071 raise Program_Error with "Position cursor not in container"; 3072 end if; 3073 3074 if Is_Root (Position) then 3075 3076 -- Should this be PE instead? Need ARG confirmation. ??? 3077 3078 raise Constraint_Error with "Position cursor designates root"; 3079 end if; 3080 3081 if Container.Nodes (Position.Node).Parent = Parent.Node then 3082 if Before = No_Element then 3083 if Container.Nodes (Position.Node).Next <= 0 then -- last child 3084 return; 3085 end if; 3086 3087 elsif Position.Node = Before.Node then 3088 return; 3089 3090 elsif Container.Nodes (Position.Node).Next = Before.Node then 3091 return; 3092 end if; 3093 end if; 3094 3095 if Container.Busy > 0 then 3096 raise Program_Error 3097 with "attempt to tamper with cursors (tree is busy)"; 3098 end if; 3099 3100 if Is_Reachable (Container => Container, 3101 From => Parent.Node, 3102 To => Position.Node) 3103 then 3104 raise Constraint_Error with "Position is ancestor of Parent"; 3105 end if; 3106 3107 Remove_Subtree (Container, Position.Node); 3108 Container.Nodes (Position.Node).Parent := Parent.Node; 3109 Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node); 3110 end Splice_Subtree; 3111 3112 procedure Splice_Subtree 3113 (Target : in out Tree; 3114 Parent : Count_Type; 3115 Before : Count_Type'Base; 3116 Source : in out Tree; 3117 Position : in out Count_Type) -- Source on input, Target on output 3118 is 3119 Source_Count : Count_Type := Subtree_Node_Count (Source, Position); 3120 pragma Assert (Source_Count >= 1); 3121 3122 Target_Subtree : Count_Type; 3123 Target_Count : Count_Type; 3124 3125 begin 3126 -- This is a utility operation to do the heavy lifting associated with 3127 -- splicing a subtree from one tree to another. Note that "splicing" 3128 -- is a bit of a misnomer here in the case of a bounded tree, because 3129 -- the elements must be copied from the source to the target. 3130 3131 if Target.Count > Target.Capacity - Source_Count then 3132 raise Capacity_Error -- ??? 3133 with "Source count exceeds available storage on Target"; 3134 end if; 3135 3136 -- Copy_Subtree returns a count of the number of nodes it inserts, but 3137 -- it does this by incrementing the value passed in. Therefore we must 3138 -- initialize the count before calling Copy_Subtree. 3139 3140 Target_Count := 0; 3141 3142 Copy_Subtree 3143 (Source => Source, 3144 Source_Subtree => Position, 3145 Target => Target, 3146 Target_Parent => Parent, 3147 Target_Subtree => Target_Subtree, 3148 Count => Target_Count); 3149 3150 pragma Assert (Target_Count = Source_Count); 3151 3152 -- Now link the newly-allocated subtree into the target. 3153 3154 Insert_Subtree_Node 3155 (Container => Target, 3156 Subtree => Target_Subtree, 3157 Parent => Parent, 3158 Before => Before); 3159 3160 Target.Count := Target.Count + Target_Count; 3161 3162 -- The manipulation of the Target container is complete. Now we remove 3163 -- the subtree from the Source container. 3164 3165 Remove_Subtree (Source, Position); -- unlink the subtree 3166 3167 -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of 3168 -- the number of nodes it deallocates, but it works by incrementing the 3169 -- value passed in. We must therefore initialize the count before 3170 -- calling it. 3171 3172 Source_Count := 0; 3173 3174 Deallocate_Subtree (Source, Position, Source_Count); 3175 pragma Assert (Source_Count = Target_Count); 3176 3177 Source.Count := Source.Count - Source_Count; 3178 3179 Position := Target_Subtree; 3180 end Splice_Subtree; 3181 3182 ------------------------ 3183 -- Subtree_Node_Count -- 3184 ------------------------ 3185 3186 function Subtree_Node_Count (Position : Cursor) return Count_Type is 3187 begin 3188 if Position = No_Element then 3189 return 0; 3190 end if; 3191 3192 if Position.Container.Count = 0 then 3193 pragma Assert (Is_Root (Position)); 3194 return 1; 3195 end if; 3196 3197 return Subtree_Node_Count (Position.Container.all, Position.Node); 3198 end Subtree_Node_Count; 3199 3200 function Subtree_Node_Count 3201 (Container : Tree; 3202 Subtree : Count_Type) return Count_Type 3203 is 3204 Result : Count_Type; 3205 Node : Count_Type'Base; 3206 3207 begin 3208 Result := 1; 3209 Node := Container.Nodes (Subtree).Children.First; 3210 while Node > 0 loop 3211 Result := Result + Subtree_Node_Count (Container, Node); 3212 Node := Container.Nodes (Node).Next; 3213 end loop; 3214 return Result; 3215 end Subtree_Node_Count; 3216 3217 ---------- 3218 -- Swap -- 3219 ---------- 3220 3221 procedure Swap 3222 (Container : in out Tree; 3223 I, J : Cursor) 3224 is 3225 begin 3226 if I = No_Element then 3227 raise Constraint_Error with "I cursor has no element"; 3228 end if; 3229 3230 if I.Container /= Container'Unrestricted_Access then 3231 raise Program_Error with "I cursor not in container"; 3232 end if; 3233 3234 if Is_Root (I) then 3235 raise Program_Error with "I cursor designates root"; 3236 end if; 3237 3238 if I = J then -- make this test sooner??? 3239 return; 3240 end if; 3241 3242 if J = No_Element then 3243 raise Constraint_Error with "J cursor has no element"; 3244 end if; 3245 3246 if J.Container /= Container'Unrestricted_Access then 3247 raise Program_Error with "J cursor not in container"; 3248 end if; 3249 3250 if Is_Root (J) then 3251 raise Program_Error with "J cursor designates root"; 3252 end if; 3253 3254 if Container.Lock > 0 then 3255 raise Program_Error 3256 with "attempt to tamper with elements (tree is locked)"; 3257 end if; 3258 3259 declare 3260 EE : Element_Array renames Container.Elements; 3261 EI : constant Element_Type := EE (I.Node); 3262 3263 begin 3264 EE (I.Node) := EE (J.Node); 3265 EE (J.Node) := EI; 3266 end; 3267 end Swap; 3268 3269 -------------------- 3270 -- Update_Element -- 3271 -------------------- 3272 3273 procedure Update_Element 3274 (Container : in out Tree; 3275 Position : Cursor; 3276 Process : not null access procedure (Element : in out Element_Type)) 3277 is 3278 begin 3279 if Position = No_Element then 3280 raise Constraint_Error with "Position cursor has no element"; 3281 end if; 3282 3283 if Position.Container /= Container'Unrestricted_Access then 3284 raise Program_Error with "Position cursor not in container"; 3285 end if; 3286 3287 if Is_Root (Position) then 3288 raise Program_Error with "Position cursor designates root"; 3289 end if; 3290 3291 declare 3292 T : Tree renames Position.Container.all'Unrestricted_Access.all; 3293 B : Natural renames T.Busy; 3294 L : Natural renames T.Lock; 3295 3296 begin 3297 B := B + 1; 3298 L := L + 1; 3299 3300 Process (Element => T.Elements (Position.Node)); 3301 3302 L := L - 1; 3303 B := B - 1; 3304 3305 exception 3306 when others => 3307 L := L - 1; 3308 B := B - 1; 3309 raise; 3310 end; 3311 end Update_Element; 3312 3313 ----------- 3314 -- Write -- 3315 ----------- 3316 3317 procedure Write 3318 (Stream : not null access Root_Stream_Type'Class; 3319 Container : Tree) 3320 is 3321 procedure Write_Children (Subtree : Count_Type); 3322 procedure Write_Subtree (Subtree : Count_Type); 3323 3324 -------------------- 3325 -- Write_Children -- 3326 -------------------- 3327 3328 procedure Write_Children (Subtree : Count_Type) is 3329 CC : Children_Type renames Container.Nodes (Subtree).Children; 3330 C : Count_Type'Base; 3331 3332 begin 3333 Count_Type'Write (Stream, Child_Count (Container, Subtree)); 3334 3335 C := CC.First; 3336 while C > 0 loop 3337 Write_Subtree (C); 3338 C := Container.Nodes (C).Next; 3339 end loop; 3340 end Write_Children; 3341 3342 ------------------- 3343 -- Write_Subtree -- 3344 ------------------- 3345 3346 procedure Write_Subtree (Subtree : Count_Type) is 3347 begin 3348 Element_Type'Write (Stream, Container.Elements (Subtree)); 3349 Write_Children (Subtree); 3350 end Write_Subtree; 3351 3352 -- Start of processing for Write 3353 3354 begin 3355 Count_Type'Write (Stream, Container.Count); 3356 3357 if Container.Count = 0 then 3358 return; 3359 end if; 3360 3361 Write_Children (Root_Node (Container)); 3362 end Write; 3363 3364 procedure Write 3365 (Stream : not null access Root_Stream_Type'Class; 3366 Position : Cursor) 3367 is 3368 begin 3369 raise Program_Error with "attempt to write tree cursor to stream"; 3370 end Write; 3371 3372 procedure Write 3373 (Stream : not null access Root_Stream_Type'Class; 3374 Item : Reference_Type) 3375 is 3376 begin 3377 raise Program_Error with "attempt to stream reference"; 3378 end Write; 3379 3380 procedure Write 3381 (Stream : not null access Root_Stream_Type'Class; 3382 Item : Constant_Reference_Type) 3383 is 3384 begin 3385 raise Program_Error with "attempt to stream reference"; 3386 end Write; 3387 3388end Ada.Containers.Bounded_Multiway_Trees; 3389