1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011-2013, 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 Capacity_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 Capacity_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 New_Item : Element_Type; 1589 pragma Unmodified (New_Item); 1590 -- OK to reference, see below 1591 1592 begin 1593 if Parent = No_Element then 1594 raise Constraint_Error with "Parent cursor has no element"; 1595 end if; 1596 1597 if Parent.Container /= Container'Unrestricted_Access then 1598 raise Program_Error with "Parent cursor not in container"; 1599 end if; 1600 1601 if Before /= No_Element then 1602 if Before.Container /= Container'Unrestricted_Access then 1603 raise Program_Error with "Before cursor not in container"; 1604 end if; 1605 1606 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then 1607 raise Constraint_Error with "Parent cursor not parent of Before"; 1608 end if; 1609 end if; 1610 1611 if Count = 0 then 1612 Position := No_Element; -- Need ruling from ARG ??? 1613 return; 1614 end if; 1615 1616 if Container.Count > Container.Capacity - Count then 1617 raise Capacity_Error 1618 with "requested count exceeds available storage"; 1619 end if; 1620 1621 if Container.Busy > 0 then 1622 raise Program_Error 1623 with "attempt to tamper with cursors (tree is busy)"; 1624 end if; 1625 1626 if Container.Count = 0 then 1627 Initialize_Root (Container); 1628 end if; 1629 1630 -- There is no explicit element provided, but in an instance the element 1631 -- type may be a scalar with a Default_Value aspect, or a composite 1632 -- type with such a scalar component, or components with default 1633 -- initialization, so insert the specified number of possibly 1634 -- initialized elements at the given position. 1635 1636 Allocate_Node (Container, New_Item, Position.Node); 1637 Nodes (Position.Node).Parent := Parent.Node; 1638 1639 Last := Position.Node; 1640 for J in Count_Type'(2) .. Count loop 1641 Allocate_Node (Container, Nodes (Last).Next); 1642 Nodes (Nodes (Last).Next).Parent := Parent.Node; 1643 Nodes (Nodes (Last).Next).Prev := Last; 1644 1645 Last := Nodes (Last).Next; 1646 end loop; 1647 1648 Insert_Subtree_List 1649 (Container => Container, 1650 First => Position.Node, 1651 Last => Last, 1652 Parent => Parent.Node, 1653 Before => Before.Node); 1654 1655 Container.Count := Container.Count + Count; 1656 1657 Position.Container := Parent.Container; 1658 end Insert_Child; 1659 1660 ------------------------- 1661 -- Insert_Subtree_List -- 1662 ------------------------- 1663 1664 procedure Insert_Subtree_List 1665 (Container : in out Tree; 1666 First : Count_Type'Base; 1667 Last : Count_Type'Base; 1668 Parent : Count_Type; 1669 Before : Count_Type'Base) 1670 is 1671 NN : Tree_Node_Array renames Container.Nodes; 1672 N : Tree_Node_Type renames NN (Parent); 1673 CC : Children_Type renames N.Children; 1674 1675 begin 1676 -- This is a simple utility operation to insert a list of nodes 1677 -- (First..Last) as children of Parent. The Before node specifies where 1678 -- the new children should be inserted relative to existing children. 1679 1680 if First <= 0 then 1681 pragma Assert (Last <= 0); 1682 return; 1683 end if; 1684 1685 pragma Assert (Last > 0); 1686 pragma Assert (Before <= 0 or else NN (Before).Parent = Parent); 1687 1688 if CC.First <= 0 then -- no existing children 1689 CC.First := First; 1690 NN (CC.First).Prev := 0; 1691 CC.Last := Last; 1692 NN (CC.Last).Next := 0; 1693 1694 elsif Before <= 0 then -- means "insert after existing nodes" 1695 NN (CC.Last).Next := First; 1696 NN (First).Prev := CC.Last; 1697 CC.Last := Last; 1698 NN (CC.Last).Next := 0; 1699 1700 elsif Before = CC.First then 1701 NN (Last).Next := CC.First; 1702 NN (CC.First).Prev := Last; 1703 CC.First := First; 1704 NN (CC.First).Prev := 0; 1705 1706 else 1707 NN (NN (Before).Prev).Next := First; 1708 NN (First).Prev := NN (Before).Prev; 1709 NN (Last).Next := Before; 1710 NN (Before).Prev := Last; 1711 end if; 1712 end Insert_Subtree_List; 1713 1714 ------------------------- 1715 -- Insert_Subtree_Node -- 1716 ------------------------- 1717 1718 procedure Insert_Subtree_Node 1719 (Container : in out Tree; 1720 Subtree : Count_Type'Base; 1721 Parent : Count_Type; 1722 Before : Count_Type'Base) 1723 is 1724 begin 1725 -- This is a simple wrapper operation to insert a single child into the 1726 -- Parent's children list. 1727 1728 Insert_Subtree_List 1729 (Container => Container, 1730 First => Subtree, 1731 Last => Subtree, 1732 Parent => Parent, 1733 Before => Before); 1734 end Insert_Subtree_Node; 1735 1736 -------------- 1737 -- Is_Empty -- 1738 -------------- 1739 1740 function Is_Empty (Container : Tree) return Boolean is 1741 begin 1742 return Container.Count = 0; 1743 end Is_Empty; 1744 1745 ------------- 1746 -- Is_Leaf -- 1747 ------------- 1748 1749 function Is_Leaf (Position : Cursor) return Boolean is 1750 begin 1751 if Position = No_Element then 1752 return False; 1753 end if; 1754 1755 if Position.Container.Count = 0 then 1756 pragma Assert (Is_Root (Position)); 1757 return True; 1758 end if; 1759 1760 return Position.Container.Nodes (Position.Node).Children.First <= 0; 1761 end Is_Leaf; 1762 1763 ------------------ 1764 -- Is_Reachable -- 1765 ------------------ 1766 1767 function Is_Reachable 1768 (Container : Tree; 1769 From, To : Count_Type) return Boolean 1770 is 1771 Idx : Count_Type; 1772 1773 begin 1774 Idx := From; 1775 while Idx >= 0 loop 1776 if Idx = To then 1777 return True; 1778 end if; 1779 1780 Idx := Container.Nodes (Idx).Parent; 1781 end loop; 1782 1783 return False; 1784 end Is_Reachable; 1785 1786 ------------- 1787 -- Is_Root -- 1788 ------------- 1789 1790 function Is_Root (Position : Cursor) return Boolean is 1791 begin 1792 return 1793 (if Position.Container = null then False 1794 else Position.Node = Root_Node (Position.Container.all)); 1795 end Is_Root; 1796 1797 ------------- 1798 -- Iterate -- 1799 ------------- 1800 1801 procedure Iterate 1802 (Container : Tree; 1803 Process : not null access procedure (Position : Cursor)) 1804 is 1805 B : Natural renames Container'Unrestricted_Access.all.Busy; 1806 1807 begin 1808 if Container.Count = 0 then 1809 return; 1810 end if; 1811 1812 B := B + 1; 1813 1814 Iterate_Children 1815 (Container => Container, 1816 Subtree => Root_Node (Container), 1817 Process => Process); 1818 1819 B := B - 1; 1820 1821 exception 1822 when others => 1823 B := B - 1; 1824 raise; 1825 end Iterate; 1826 1827 function Iterate (Container : Tree) 1828 return Tree_Iterator_Interfaces.Forward_Iterator'Class 1829 is 1830 begin 1831 return Iterate_Subtree (Root (Container)); 1832 end Iterate; 1833 1834 ---------------------- 1835 -- Iterate_Children -- 1836 ---------------------- 1837 1838 procedure Iterate_Children 1839 (Parent : Cursor; 1840 Process : not null access procedure (Position : Cursor)) 1841 is 1842 begin 1843 if Parent = No_Element then 1844 raise Constraint_Error with "Parent cursor has no element"; 1845 end if; 1846 1847 if Parent.Container.Count = 0 then 1848 pragma Assert (Is_Root (Parent)); 1849 return; 1850 end if; 1851 1852 declare 1853 B : Natural renames Parent.Container.Busy; 1854 C : Count_Type; 1855 NN : Tree_Node_Array renames Parent.Container.Nodes; 1856 1857 begin 1858 B := B + 1; 1859 1860 C := NN (Parent.Node).Children.First; 1861 while C > 0 loop 1862 Process (Cursor'(Parent.Container, Node => C)); 1863 C := NN (C).Next; 1864 end loop; 1865 1866 B := B - 1; 1867 1868 exception 1869 when others => 1870 B := B - 1; 1871 raise; 1872 end; 1873 end Iterate_Children; 1874 1875 procedure Iterate_Children 1876 (Container : Tree; 1877 Subtree : Count_Type; 1878 Process : not null access procedure (Position : Cursor)) 1879 is 1880 NN : Tree_Node_Array renames Container.Nodes; 1881 N : Tree_Node_Type renames NN (Subtree); 1882 C : Count_Type; 1883 1884 begin 1885 -- This is a helper function to recursively iterate over all the nodes 1886 -- in a subtree, in depth-first fashion. This particular helper just 1887 -- visits the children of this subtree, not the root of the subtree 1888 -- itself. This is useful when starting from the ultimate root of the 1889 -- entire tree (see Iterate), as that root does not have an element. 1890 1891 C := N.Children.First; 1892 while C > 0 loop 1893 Iterate_Subtree (Container, C, Process); 1894 C := NN (C).Next; 1895 end loop; 1896 end Iterate_Children; 1897 1898 function Iterate_Children 1899 (Container : Tree; 1900 Parent : Cursor) 1901 return Tree_Iterator_Interfaces.Reversible_Iterator'Class 1902 is 1903 C : constant Tree_Access := Container'Unrestricted_Access; 1904 B : Natural renames C.Busy; 1905 1906 begin 1907 if Parent = No_Element then 1908 raise Constraint_Error with "Parent cursor has no element"; 1909 end if; 1910 1911 if Parent.Container /= C then 1912 raise Program_Error with "Parent cursor not in container"; 1913 end if; 1914 1915 return It : constant Child_Iterator := 1916 Child_Iterator'(Limited_Controlled with 1917 Container => C, 1918 Subtree => Parent.Node) 1919 do 1920 B := B + 1; 1921 end return; 1922 end Iterate_Children; 1923 1924 --------------------- 1925 -- Iterate_Subtree -- 1926 --------------------- 1927 1928 function Iterate_Subtree 1929 (Position : Cursor) 1930 return Tree_Iterator_Interfaces.Forward_Iterator'Class 1931 is 1932 begin 1933 if Position = No_Element then 1934 raise Constraint_Error with "Position cursor has no element"; 1935 end if; 1936 1937 -- Implement Vet for multiway trees??? 1938 -- pragma Assert (Vet (Position), "bad subtree cursor"); 1939 1940 declare 1941 B : Natural renames Position.Container.Busy; 1942 begin 1943 return It : constant Subtree_Iterator := 1944 (Limited_Controlled with 1945 Container => Position.Container, 1946 Subtree => Position.Node) 1947 do 1948 B := B + 1; 1949 end return; 1950 end; 1951 end Iterate_Subtree; 1952 1953 procedure Iterate_Subtree 1954 (Position : Cursor; 1955 Process : not null access procedure (Position : Cursor)) 1956 is 1957 begin 1958 if Position = No_Element then 1959 raise Constraint_Error with "Position cursor has no element"; 1960 end if; 1961 1962 if Position.Container.Count = 0 then 1963 pragma Assert (Is_Root (Position)); 1964 return; 1965 end if; 1966 1967 declare 1968 T : Tree renames Position.Container.all; 1969 B : Natural renames T.Busy; 1970 1971 begin 1972 B := B + 1; 1973 1974 if Is_Root (Position) then 1975 Iterate_Children (T, Position.Node, Process); 1976 else 1977 Iterate_Subtree (T, Position.Node, Process); 1978 end if; 1979 1980 B := B - 1; 1981 1982 exception 1983 when others => 1984 B := B - 1; 1985 raise; 1986 end; 1987 end Iterate_Subtree; 1988 1989 procedure Iterate_Subtree 1990 (Container : Tree; 1991 Subtree : Count_Type; 1992 Process : not null access procedure (Position : Cursor)) 1993 is 1994 begin 1995 -- This is a helper function to recursively iterate over all the nodes 1996 -- in a subtree, in depth-first fashion. It first visits the root of the 1997 -- subtree, then visits its children. 1998 1999 Process (Cursor'(Container'Unrestricted_Access, Subtree)); 2000 Iterate_Children (Container, Subtree, Process); 2001 end Iterate_Subtree; 2002 2003 ---------- 2004 -- Last -- 2005 ---------- 2006 2007 overriding function Last (Object : Child_Iterator) return Cursor is 2008 begin 2009 return Last_Child (Cursor'(Object.Container, Object.Subtree)); 2010 end Last; 2011 2012 ---------------- 2013 -- Last_Child -- 2014 ---------------- 2015 2016 function Last_Child (Parent : Cursor) return Cursor is 2017 Node : Count_Type'Base; 2018 2019 begin 2020 if Parent = No_Element then 2021 raise Constraint_Error with "Parent cursor has no element"; 2022 end if; 2023 2024 if Parent.Container.Count = 0 then 2025 pragma Assert (Is_Root (Parent)); 2026 return No_Element; 2027 end if; 2028 2029 Node := Parent.Container.Nodes (Parent.Node).Children.Last; 2030 2031 if Node <= 0 then 2032 return No_Element; 2033 end if; 2034 2035 return Cursor'(Parent.Container, Node); 2036 end Last_Child; 2037 2038 ------------------------ 2039 -- Last_Child_Element -- 2040 ------------------------ 2041 2042 function Last_Child_Element (Parent : Cursor) return Element_Type is 2043 begin 2044 return Element (Last_Child (Parent)); 2045 end Last_Child_Element; 2046 2047 ---------- 2048 -- Move -- 2049 ---------- 2050 2051 procedure Move (Target : in out Tree; Source : in out Tree) is 2052 begin 2053 if Target'Address = Source'Address then 2054 return; 2055 end if; 2056 2057 if Source.Busy > 0 then 2058 raise Program_Error 2059 with "attempt to tamper with cursors of Source (tree is busy)"; 2060 end if; 2061 2062 Target.Assign (Source); 2063 Source.Clear; 2064 end Move; 2065 2066 ---------- 2067 -- Next -- 2068 ---------- 2069 2070 overriding function Next 2071 (Object : Subtree_Iterator; 2072 Position : Cursor) return Cursor 2073 is 2074 begin 2075 if Position.Container = null then 2076 return No_Element; 2077 end if; 2078 2079 if Position.Container /= Object.Container then 2080 raise Program_Error with 2081 "Position cursor of Next designates wrong tree"; 2082 end if; 2083 2084 pragma Assert (Object.Container.Count > 0); 2085 pragma Assert (Position.Node /= Root_Node (Object.Container.all)); 2086 2087 declare 2088 Nodes : Tree_Node_Array renames Object.Container.Nodes; 2089 Node : Count_Type; 2090 2091 begin 2092 Node := Position.Node; 2093 2094 if Nodes (Node).Children.First > 0 then 2095 return Cursor'(Object.Container, Nodes (Node).Children.First); 2096 end if; 2097 2098 while Node /= Object.Subtree loop 2099 if Nodes (Node).Next > 0 then 2100 return Cursor'(Object.Container, Nodes (Node).Next); 2101 end if; 2102 2103 Node := Nodes (Node).Parent; 2104 end loop; 2105 2106 return No_Element; 2107 end; 2108 end Next; 2109 2110 overriding function Next 2111 (Object : Child_Iterator; 2112 Position : Cursor) return Cursor 2113 is 2114 begin 2115 if Position.Container = null then 2116 return No_Element; 2117 end if; 2118 2119 if Position.Container /= Object.Container then 2120 raise Program_Error with 2121 "Position cursor of Next designates wrong tree"; 2122 end if; 2123 2124 pragma Assert (Object.Container.Count > 0); 2125 pragma Assert (Position.Node /= Root_Node (Object.Container.all)); 2126 2127 return Next_Sibling (Position); 2128 end Next; 2129 2130 ------------------ 2131 -- Next_Sibling -- 2132 ------------------ 2133 2134 function Next_Sibling (Position : Cursor) return Cursor is 2135 begin 2136 if Position = No_Element then 2137 return No_Element; 2138 end if; 2139 2140 if Position.Container.Count = 0 then 2141 pragma Assert (Is_Root (Position)); 2142 return No_Element; 2143 end if; 2144 2145 declare 2146 T : Tree renames Position.Container.all; 2147 NN : Tree_Node_Array renames T.Nodes; 2148 N : Tree_Node_Type renames NN (Position.Node); 2149 2150 begin 2151 if N.Next <= 0 then 2152 return No_Element; 2153 end if; 2154 2155 return Cursor'(Position.Container, N.Next); 2156 end; 2157 end Next_Sibling; 2158 2159 procedure Next_Sibling (Position : in out Cursor) is 2160 begin 2161 Position := Next_Sibling (Position); 2162 end Next_Sibling; 2163 2164 ---------------- 2165 -- Node_Count -- 2166 ---------------- 2167 2168 function Node_Count (Container : Tree) return Count_Type is 2169 begin 2170 -- Container.Count is the number of nodes we have actually allocated. We 2171 -- cache the value specifically so this Node_Count operation can execute 2172 -- in O(1) time, which makes it behave similarly to how the Length 2173 -- selector function behaves for other containers. 2174 -- 2175 -- The cached node count value only describes the nodes we have 2176 -- allocated; the root node itself is not included in that count. The 2177 -- Node_Count operation returns a value that includes the root node 2178 -- (because the RM says so), so we must add 1 to our cached value. 2179 2180 return 1 + Container.Count; 2181 end Node_Count; 2182 2183 ------------ 2184 -- Parent -- 2185 ------------ 2186 2187 function Parent (Position : Cursor) return Cursor is 2188 begin 2189 if Position = No_Element then 2190 return No_Element; 2191 end if; 2192 2193 if Position.Container.Count = 0 then 2194 pragma Assert (Is_Root (Position)); 2195 return No_Element; 2196 end if; 2197 2198 declare 2199 T : Tree renames Position.Container.all; 2200 NN : Tree_Node_Array renames T.Nodes; 2201 N : Tree_Node_Type renames NN (Position.Node); 2202 2203 begin 2204 if N.Parent < 0 then 2205 pragma Assert (Position.Node = Root_Node (T)); 2206 return No_Element; 2207 end if; 2208 2209 return Cursor'(Position.Container, N.Parent); 2210 end; 2211 end Parent; 2212 2213 ------------------- 2214 -- Prepend_Child -- 2215 ------------------- 2216 2217 procedure Prepend_Child 2218 (Container : in out Tree; 2219 Parent : Cursor; 2220 New_Item : Element_Type; 2221 Count : Count_Type := 1) 2222 is 2223 Nodes : Tree_Node_Array renames Container.Nodes; 2224 First, Last : Count_Type; 2225 2226 begin 2227 if Parent = No_Element then 2228 raise Constraint_Error with "Parent cursor has no element"; 2229 end if; 2230 2231 if Parent.Container /= Container'Unrestricted_Access then 2232 raise Program_Error with "Parent cursor not in container"; 2233 end if; 2234 2235 if Count = 0 then 2236 return; 2237 end if; 2238 2239 if Container.Count > Container.Capacity - Count then 2240 raise Capacity_Error 2241 with "requested count exceeds available storage"; 2242 end if; 2243 2244 if Container.Busy > 0 then 2245 raise Program_Error 2246 with "attempt to tamper with cursors (tree is busy)"; 2247 end if; 2248 2249 if Container.Count = 0 then 2250 Initialize_Root (Container); 2251 end if; 2252 2253 Allocate_Node (Container, New_Item, First); 2254 Nodes (First).Parent := Parent.Node; 2255 2256 Last := First; 2257 for J in Count_Type'(2) .. Count loop 2258 Allocate_Node (Container, New_Item, Nodes (Last).Next); 2259 Nodes (Nodes (Last).Next).Parent := Parent.Node; 2260 Nodes (Nodes (Last).Next).Prev := Last; 2261 2262 Last := Nodes (Last).Next; 2263 end loop; 2264 2265 Insert_Subtree_List 2266 (Container => Container, 2267 First => First, 2268 Last => Last, 2269 Parent => Parent.Node, 2270 Before => Nodes (Parent.Node).Children.First); 2271 2272 Container.Count := Container.Count + Count; 2273 end Prepend_Child; 2274 2275 -------------- 2276 -- Previous -- 2277 -------------- 2278 2279 overriding function Previous 2280 (Object : Child_Iterator; 2281 Position : Cursor) return Cursor 2282 is 2283 begin 2284 if Position.Container = null then 2285 return No_Element; 2286 end if; 2287 2288 if Position.Container /= Object.Container then 2289 raise Program_Error with 2290 "Position cursor of Previous designates wrong tree"; 2291 end if; 2292 2293 return Previous_Sibling (Position); 2294 end Previous; 2295 2296 ---------------------- 2297 -- Previous_Sibling -- 2298 ---------------------- 2299 2300 function Previous_Sibling (Position : Cursor) return Cursor is 2301 begin 2302 if Position = No_Element then 2303 return No_Element; 2304 end if; 2305 2306 if Position.Container.Count = 0 then 2307 pragma Assert (Is_Root (Position)); 2308 return No_Element; 2309 end if; 2310 2311 declare 2312 T : Tree renames Position.Container.all; 2313 NN : Tree_Node_Array renames T.Nodes; 2314 N : Tree_Node_Type renames NN (Position.Node); 2315 2316 begin 2317 if N.Prev <= 0 then 2318 return No_Element; 2319 end if; 2320 2321 return Cursor'(Position.Container, N.Prev); 2322 end; 2323 end Previous_Sibling; 2324 2325 procedure Previous_Sibling (Position : in out Cursor) is 2326 begin 2327 Position := Previous_Sibling (Position); 2328 end Previous_Sibling; 2329 2330 ------------------- 2331 -- Query_Element -- 2332 ------------------- 2333 2334 procedure Query_Element 2335 (Position : Cursor; 2336 Process : not null access procedure (Element : Element_Type)) 2337 is 2338 begin 2339 if Position = No_Element then 2340 raise Constraint_Error with "Position cursor has no element"; 2341 end if; 2342 2343 if Is_Root (Position) then 2344 raise Program_Error with "Position cursor designates root"; 2345 end if; 2346 2347 declare 2348 T : Tree renames Position.Container.all'Unrestricted_Access.all; 2349 B : Natural renames T.Busy; 2350 L : Natural renames T.Lock; 2351 2352 begin 2353 B := B + 1; 2354 L := L + 1; 2355 2356 Process (Element => T.Elements (Position.Node)); 2357 2358 L := L - 1; 2359 B := B - 1; 2360 2361 exception 2362 when others => 2363 L := L - 1; 2364 B := B - 1; 2365 raise; 2366 end; 2367 end Query_Element; 2368 2369 ---------- 2370 -- Read -- 2371 ---------- 2372 2373 procedure Read 2374 (Stream : not null access Root_Stream_Type'Class; 2375 Container : out Tree) 2376 is 2377 procedure Read_Children (Subtree : Count_Type); 2378 2379 function Read_Subtree 2380 (Parent : Count_Type) return Count_Type; 2381 2382 NN : Tree_Node_Array renames Container.Nodes; 2383 2384 Total_Count : Count_Type'Base; 2385 -- Value read from the stream that says how many elements follow 2386 2387 Read_Count : Count_Type'Base; 2388 -- Actual number of elements read from the stream 2389 2390 ------------------- 2391 -- Read_Children -- 2392 ------------------- 2393 2394 procedure Read_Children (Subtree : Count_Type) is 2395 Count : Count_Type'Base; 2396 -- number of child subtrees 2397 2398 CC : Children_Type; 2399 2400 begin 2401 Count_Type'Read (Stream, Count); 2402 2403 if Count < 0 then 2404 raise Program_Error with "attempt to read from corrupt stream"; 2405 end if; 2406 2407 if Count = 0 then 2408 return; 2409 end if; 2410 2411 CC.First := Read_Subtree (Parent => Subtree); 2412 CC.Last := CC.First; 2413 2414 for J in Count_Type'(2) .. Count loop 2415 NN (CC.Last).Next := Read_Subtree (Parent => Subtree); 2416 NN (NN (CC.Last).Next).Prev := CC.Last; 2417 CC.Last := NN (CC.Last).Next; 2418 end loop; 2419 2420 -- Now that the allocation and reads have completed successfully, it 2421 -- is safe to link the children to their parent. 2422 2423 NN (Subtree).Children := CC; 2424 end Read_Children; 2425 2426 ------------------ 2427 -- Read_Subtree -- 2428 ------------------ 2429 2430 function Read_Subtree 2431 (Parent : Count_Type) return Count_Type 2432 is 2433 Subtree : Count_Type; 2434 2435 begin 2436 Allocate_Node (Container, Stream, Subtree); 2437 Container.Nodes (Subtree).Parent := Parent; 2438 2439 Read_Count := Read_Count + 1; 2440 2441 Read_Children (Subtree); 2442 2443 return Subtree; 2444 end Read_Subtree; 2445 2446 -- Start of processing for Read 2447 2448 begin 2449 Container.Clear; -- checks busy bit 2450 2451 Count_Type'Read (Stream, Total_Count); 2452 2453 if Total_Count < 0 then 2454 raise Program_Error with "attempt to read from corrupt stream"; 2455 end if; 2456 2457 if Total_Count = 0 then 2458 return; 2459 end if; 2460 2461 if Total_Count > Container.Capacity then 2462 raise Capacity_Error -- ??? 2463 with "node count in stream exceeds container capacity"; 2464 end if; 2465 2466 Initialize_Root (Container); 2467 2468 Read_Count := 0; 2469 2470 Read_Children (Root_Node (Container)); 2471 2472 if Read_Count /= Total_Count then 2473 raise Program_Error with "attempt to read from corrupt stream"; 2474 end if; 2475 2476 Container.Count := Total_Count; 2477 end Read; 2478 2479 procedure Read 2480 (Stream : not null access Root_Stream_Type'Class; 2481 Position : out Cursor) 2482 is 2483 begin 2484 raise Program_Error with "attempt to read tree cursor from stream"; 2485 end Read; 2486 2487 procedure Read 2488 (Stream : not null access Root_Stream_Type'Class; 2489 Item : out Reference_Type) 2490 is 2491 begin 2492 raise Program_Error with "attempt to stream reference"; 2493 end Read; 2494 2495 procedure Read 2496 (Stream : not null access Root_Stream_Type'Class; 2497 Item : out Constant_Reference_Type) 2498 is 2499 begin 2500 raise Program_Error with "attempt to stream reference"; 2501 end Read; 2502 2503 --------------- 2504 -- Reference -- 2505 --------------- 2506 2507 function Reference 2508 (Container : aliased in out Tree; 2509 Position : Cursor) return Reference_Type 2510 is 2511 begin 2512 if Position.Container = null then 2513 raise Constraint_Error with 2514 "Position cursor has no element"; 2515 end if; 2516 2517 if Position.Container /= Container'Unrestricted_Access then 2518 raise Program_Error with 2519 "Position cursor designates wrong container"; 2520 end if; 2521 2522 if Position.Node = Root_Node (Container) then 2523 raise Program_Error with "Position cursor designates root"; 2524 end if; 2525 2526 -- Implement Vet for multiway tree??? 2527 -- pragma Assert (Vet (Position), 2528 -- "Position cursor in Constant_Reference is bad"); 2529 2530 return (Element => Container.Elements (Position.Node)'Access); 2531 end Reference; 2532 2533 -------------------- 2534 -- Remove_Subtree -- 2535 -------------------- 2536 2537 procedure Remove_Subtree 2538 (Container : in out Tree; 2539 Subtree : Count_Type) 2540 is 2541 NN : Tree_Node_Array renames Container.Nodes; 2542 N : Tree_Node_Type renames NN (Subtree); 2543 CC : Children_Type renames NN (N.Parent).Children; 2544 2545 begin 2546 -- This is a utility operation to remove a subtree node from its 2547 -- parent's list of children. 2548 2549 if CC.First = Subtree then 2550 pragma Assert (N.Prev <= 0); 2551 2552 if CC.Last = Subtree then 2553 pragma Assert (N.Next <= 0); 2554 CC.First := 0; 2555 CC.Last := 0; 2556 2557 else 2558 CC.First := N.Next; 2559 NN (CC.First).Prev := 0; 2560 end if; 2561 2562 elsif CC.Last = Subtree then 2563 pragma Assert (N.Next <= 0); 2564 CC.Last := N.Prev; 2565 NN (CC.Last).Next := 0; 2566 2567 else 2568 NN (N.Prev).Next := N.Next; 2569 NN (N.Next).Prev := N.Prev; 2570 end if; 2571 end Remove_Subtree; 2572 2573 ---------------------- 2574 -- Replace_Element -- 2575 ---------------------- 2576 2577 procedure Replace_Element 2578 (Container : in out Tree; 2579 Position : Cursor; 2580 New_Item : Element_Type) 2581 is 2582 begin 2583 if Position = No_Element then 2584 raise Constraint_Error with "Position cursor has no element"; 2585 end if; 2586 2587 if Position.Container /= Container'Unrestricted_Access then 2588 raise Program_Error with "Position cursor not in container"; 2589 end if; 2590 2591 if Is_Root (Position) then 2592 raise Program_Error with "Position cursor designates root"; 2593 end if; 2594 2595 if Container.Lock > 0 then 2596 raise Program_Error 2597 with "attempt to tamper with elements (tree is locked)"; 2598 end if; 2599 2600 Container.Elements (Position.Node) := New_Item; 2601 end Replace_Element; 2602 2603 ------------------------------ 2604 -- Reverse_Iterate_Children -- 2605 ------------------------------ 2606 2607 procedure Reverse_Iterate_Children 2608 (Parent : Cursor; 2609 Process : not null access procedure (Position : Cursor)) 2610 is 2611 begin 2612 if Parent = No_Element then 2613 raise Constraint_Error with "Parent cursor has no element"; 2614 end if; 2615 2616 if Parent.Container.Count = 0 then 2617 pragma Assert (Is_Root (Parent)); 2618 return; 2619 end if; 2620 2621 declare 2622 NN : Tree_Node_Array renames Parent.Container.Nodes; 2623 B : Natural renames Parent.Container.Busy; 2624 C : Count_Type; 2625 2626 begin 2627 B := B + 1; 2628 2629 C := NN (Parent.Node).Children.Last; 2630 while C > 0 loop 2631 Process (Cursor'(Parent.Container, Node => C)); 2632 C := NN (C).Prev; 2633 end loop; 2634 2635 B := B - 1; 2636 2637 exception 2638 when others => 2639 B := B - 1; 2640 raise; 2641 end; 2642 end Reverse_Iterate_Children; 2643 2644 ---------- 2645 -- Root -- 2646 ---------- 2647 2648 function Root (Container : Tree) return Cursor is 2649 begin 2650 return (Container'Unrestricted_Access, Root_Node (Container)); 2651 end Root; 2652 2653 --------------- 2654 -- Root_Node -- 2655 --------------- 2656 2657 function Root_Node (Container : Tree) return Count_Type is 2658 pragma Unreferenced (Container); 2659 2660 begin 2661 return 0; 2662 end Root_Node; 2663 2664 --------------------- 2665 -- Splice_Children -- 2666 --------------------- 2667 2668 procedure Splice_Children 2669 (Target : in out Tree; 2670 Target_Parent : Cursor; 2671 Before : Cursor; 2672 Source : in out Tree; 2673 Source_Parent : Cursor) 2674 is 2675 begin 2676 if Target_Parent = No_Element then 2677 raise Constraint_Error with "Target_Parent cursor has no element"; 2678 end if; 2679 2680 if Target_Parent.Container /= Target'Unrestricted_Access then 2681 raise Program_Error 2682 with "Target_Parent cursor not in Target container"; 2683 end if; 2684 2685 if Before /= No_Element then 2686 if Before.Container /= Target'Unrestricted_Access then 2687 raise Program_Error 2688 with "Before cursor not in Target container"; 2689 end if; 2690 2691 if Target.Nodes (Before.Node).Parent /= Target_Parent.Node then 2692 raise Constraint_Error 2693 with "Before cursor not child of Target_Parent"; 2694 end if; 2695 end if; 2696 2697 if Source_Parent = No_Element then 2698 raise Constraint_Error with "Source_Parent cursor has no element"; 2699 end if; 2700 2701 if Source_Parent.Container /= Source'Unrestricted_Access then 2702 raise Program_Error 2703 with "Source_Parent cursor not in Source container"; 2704 end if; 2705 2706 if Source.Count = 0 then 2707 pragma Assert (Is_Root (Source_Parent)); 2708 return; 2709 end if; 2710 2711 if Target'Address = Source'Address then 2712 if Target_Parent = Source_Parent then 2713 return; 2714 end if; 2715 2716 if Target.Busy > 0 then 2717 raise Program_Error 2718 with "attempt to tamper with cursors (Target tree is busy)"; 2719 end if; 2720 2721 if Is_Reachable (Container => Target, 2722 From => Target_Parent.Node, 2723 To => Source_Parent.Node) 2724 then 2725 raise Constraint_Error 2726 with "Source_Parent is ancestor of Target_Parent"; 2727 end if; 2728 2729 Splice_Children 2730 (Container => Target, 2731 Target_Parent => Target_Parent.Node, 2732 Before => Before.Node, 2733 Source_Parent => Source_Parent.Node); 2734 2735 return; 2736 end if; 2737 2738 if Target.Busy > 0 then 2739 raise Program_Error 2740 with "attempt to tamper with cursors (Target tree is busy)"; 2741 end if; 2742 2743 if Source.Busy > 0 then 2744 raise Program_Error 2745 with "attempt to tamper with cursors (Source tree is busy)"; 2746 end if; 2747 2748 if Target.Count = 0 then 2749 Initialize_Root (Target); 2750 end if; 2751 2752 Splice_Children 2753 (Target => Target, 2754 Target_Parent => Target_Parent.Node, 2755 Before => Before.Node, 2756 Source => Source, 2757 Source_Parent => Source_Parent.Node); 2758 end Splice_Children; 2759 2760 procedure Splice_Children 2761 (Container : in out Tree; 2762 Target_Parent : Cursor; 2763 Before : Cursor; 2764 Source_Parent : Cursor) 2765 is 2766 begin 2767 if Target_Parent = No_Element then 2768 raise Constraint_Error with "Target_Parent cursor has no element"; 2769 end if; 2770 2771 if Target_Parent.Container /= Container'Unrestricted_Access then 2772 raise Program_Error 2773 with "Target_Parent cursor not in container"; 2774 end if; 2775 2776 if Before /= No_Element then 2777 if Before.Container /= Container'Unrestricted_Access then 2778 raise Program_Error 2779 with "Before cursor not in container"; 2780 end if; 2781 2782 if Container.Nodes (Before.Node).Parent /= Target_Parent.Node then 2783 raise Constraint_Error 2784 with "Before cursor not child of Target_Parent"; 2785 end if; 2786 end if; 2787 2788 if Source_Parent = No_Element then 2789 raise Constraint_Error with "Source_Parent cursor has no element"; 2790 end if; 2791 2792 if Source_Parent.Container /= Container'Unrestricted_Access then 2793 raise Program_Error 2794 with "Source_Parent cursor not in container"; 2795 end if; 2796 2797 if Target_Parent = Source_Parent then 2798 return; 2799 end if; 2800 2801 pragma Assert (Container.Count > 0); 2802 2803 if Container.Busy > 0 then 2804 raise Program_Error 2805 with "attempt to tamper with cursors (tree is busy)"; 2806 end if; 2807 2808 if Is_Reachable (Container => Container, 2809 From => Target_Parent.Node, 2810 To => Source_Parent.Node) 2811 then 2812 raise Constraint_Error 2813 with "Source_Parent is ancestor of Target_Parent"; 2814 end if; 2815 2816 Splice_Children 2817 (Container => Container, 2818 Target_Parent => Target_Parent.Node, 2819 Before => Before.Node, 2820 Source_Parent => Source_Parent.Node); 2821 end Splice_Children; 2822 2823 procedure Splice_Children 2824 (Container : in out Tree; 2825 Target_Parent : Count_Type; 2826 Before : Count_Type'Base; 2827 Source_Parent : Count_Type) 2828 is 2829 NN : Tree_Node_Array renames Container.Nodes; 2830 CC : constant Children_Type := NN (Source_Parent).Children; 2831 C : Count_Type'Base; 2832 2833 begin 2834 -- This is a utility operation to remove the children from Source parent 2835 -- and insert them into Target parent. 2836 2837 NN (Source_Parent).Children := Children_Type'(others => 0); 2838 2839 -- Fix up the Parent pointers of each child to designate its new Target 2840 -- parent. 2841 2842 C := CC.First; 2843 while C > 0 loop 2844 NN (C).Parent := Target_Parent; 2845 C := NN (C).Next; 2846 end loop; 2847 2848 Insert_Subtree_List 2849 (Container => Container, 2850 First => CC.First, 2851 Last => CC.Last, 2852 Parent => Target_Parent, 2853 Before => Before); 2854 end Splice_Children; 2855 2856 procedure Splice_Children 2857 (Target : in out Tree; 2858 Target_Parent : Count_Type; 2859 Before : Count_Type'Base; 2860 Source : in out Tree; 2861 Source_Parent : Count_Type) 2862 is 2863 S_NN : Tree_Node_Array renames Source.Nodes; 2864 S_CC : Children_Type renames S_NN (Source_Parent).Children; 2865 2866 Target_Count, Source_Count : Count_Type; 2867 T, S : Count_Type'Base; 2868 2869 begin 2870 -- This is a utility operation to copy the children from the Source 2871 -- parent and insert them as children of the Target parent, and then 2872 -- delete them from the Source. (This is not a true splice operation, 2873 -- but it is the best we can do in a bounded form.) The Before position 2874 -- specifies where among the Target parent's exising children the new 2875 -- children are inserted. 2876 2877 -- Before we attempt the insertion, we must count the sources nodes in 2878 -- order to determine whether the target have enough storage 2879 -- available. Note that calculating this value is an O(n) operation. 2880 2881 -- Here is an optimization opportunity: iterate of each children the 2882 -- source explicitly, and keep a running count of the total number of 2883 -- nodes. Compare the running total to the capacity of the target each 2884 -- pass through the loop. This is more efficient than summing the counts 2885 -- of child subtree (which is what Subtree_Node_Count does) and then 2886 -- comparing that total sum to the target's capacity. ??? 2887 2888 -- Here is another possibility. We currently treat the splice as an 2889 -- all-or-nothing proposition: either we can insert all of children of 2890 -- the source, or we raise exception with modifying the target. The 2891 -- price for not causing side-effect is an O(n) determination of the 2892 -- source count. If we are willing to tolerate side-effect, then we 2893 -- could loop over the children of the source, counting that subtree and 2894 -- then immediately inserting it in the target. The issue here is that 2895 -- the test for available storage could fail during some later pass, 2896 -- after children have already been inserted into target. ??? 2897 2898 Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1; 2899 2900 if Source_Count = 0 then 2901 return; 2902 end if; 2903 2904 if Target.Count > Target.Capacity - Source_Count then 2905 raise Capacity_Error -- ??? 2906 with "Source count exceeds available storage on Target"; 2907 end if; 2908 2909 -- Copy_Subtree returns a count of the number of nodes it inserts, but 2910 -- it does this by incrementing the value passed in. Therefore we must 2911 -- initialize the count before calling Copy_Subtree. 2912 2913 Target_Count := 0; 2914 2915 S := S_CC.First; 2916 while S > 0 loop 2917 Copy_Subtree 2918 (Source => Source, 2919 Source_Subtree => S, 2920 Target => Target, 2921 Target_Parent => Target_Parent, 2922 Target_Subtree => T, 2923 Count => Target_Count); 2924 2925 Insert_Subtree_Node 2926 (Container => Target, 2927 Subtree => T, 2928 Parent => Target_Parent, 2929 Before => Before); 2930 2931 S := S_NN (S).Next; 2932 end loop; 2933 2934 pragma Assert (Target_Count = Source_Count); 2935 Target.Count := Target.Count + Target_Count; 2936 2937 -- As with Copy_Subtree, operation Deallocate_Children returns a count 2938 -- of the number of nodes it deallocates, but it works by incrementing 2939 -- the value passed in. We must therefore initialize the count before 2940 -- calling it. 2941 2942 Source_Count := 0; 2943 2944 Deallocate_Children (Source, Source_Parent, Source_Count); 2945 pragma Assert (Source_Count = Target_Count); 2946 2947 Source.Count := Source.Count - Source_Count; 2948 end Splice_Children; 2949 2950 -------------------- 2951 -- Splice_Subtree -- 2952 -------------------- 2953 2954 procedure Splice_Subtree 2955 (Target : in out Tree; 2956 Parent : Cursor; 2957 Before : Cursor; 2958 Source : in out Tree; 2959 Position : in out Cursor) 2960 is 2961 begin 2962 if Parent = No_Element then 2963 raise Constraint_Error with "Parent cursor has no element"; 2964 end if; 2965 2966 if Parent.Container /= Target'Unrestricted_Access then 2967 raise Program_Error with "Parent cursor not in Target container"; 2968 end if; 2969 2970 if Before /= No_Element then 2971 if Before.Container /= Target'Unrestricted_Access then 2972 raise Program_Error with "Before cursor not in Target container"; 2973 end if; 2974 2975 if Target.Nodes (Before.Node).Parent /= Parent.Node then 2976 raise Constraint_Error with "Before cursor not child of Parent"; 2977 end if; 2978 end if; 2979 2980 if Position = No_Element then 2981 raise Constraint_Error with "Position cursor has no element"; 2982 end if; 2983 2984 if Position.Container /= Source'Unrestricted_Access then 2985 raise Program_Error with "Position cursor not in Source container"; 2986 end if; 2987 2988 if Is_Root (Position) then 2989 raise Program_Error with "Position cursor designates root"; 2990 end if; 2991 2992 if Target'Address = Source'Address then 2993 if Target.Nodes (Position.Node).Parent = Parent.Node then 2994 if Before = No_Element then 2995 if Target.Nodes (Position.Node).Next <= 0 then -- last child 2996 return; 2997 end if; 2998 2999 elsif Position.Node = Before.Node then 3000 return; 3001 3002 elsif Target.Nodes (Position.Node).Next = Before.Node then 3003 return; 3004 end if; 3005 end if; 3006 3007 if Target.Busy > 0 then 3008 raise Program_Error 3009 with "attempt to tamper with cursors (Target tree is busy)"; 3010 end if; 3011 3012 if Is_Reachable (Container => Target, 3013 From => Parent.Node, 3014 To => Position.Node) 3015 then 3016 raise Constraint_Error with "Position is ancestor of Parent"; 3017 end if; 3018 3019 Remove_Subtree (Target, Position.Node); 3020 3021 Target.Nodes (Position.Node).Parent := Parent.Node; 3022 Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node); 3023 3024 return; 3025 end if; 3026 3027 if Target.Busy > 0 then 3028 raise Program_Error 3029 with "attempt to tamper with cursors (Target tree is busy)"; 3030 end if; 3031 3032 if Source.Busy > 0 then 3033 raise Program_Error 3034 with "attempt to tamper with cursors (Source tree is busy)"; 3035 end if; 3036 3037 if Target.Count = 0 then 3038 Initialize_Root (Target); 3039 end if; 3040 3041 Splice_Subtree 3042 (Target => Target, 3043 Parent => Parent.Node, 3044 Before => Before.Node, 3045 Source => Source, 3046 Position => Position.Node); -- modified during call 3047 3048 Position.Container := Target'Unrestricted_Access; 3049 end Splice_Subtree; 3050 3051 procedure Splice_Subtree 3052 (Container : in out Tree; 3053 Parent : Cursor; 3054 Before : Cursor; 3055 Position : Cursor) 3056 is 3057 begin 3058 if Parent = No_Element then 3059 raise Constraint_Error with "Parent cursor has no element"; 3060 end if; 3061 3062 if Parent.Container /= Container'Unrestricted_Access then 3063 raise Program_Error with "Parent cursor not in container"; 3064 end if; 3065 3066 if Before /= No_Element then 3067 if Before.Container /= Container'Unrestricted_Access then 3068 raise Program_Error with "Before cursor not in container"; 3069 end if; 3070 3071 if Container.Nodes (Before.Node).Parent /= Parent.Node then 3072 raise Constraint_Error with "Before cursor not child of Parent"; 3073 end if; 3074 end if; 3075 3076 if Position = No_Element then 3077 raise Constraint_Error with "Position cursor has no element"; 3078 end if; 3079 3080 if Position.Container /= Container'Unrestricted_Access then 3081 raise Program_Error with "Position cursor not in container"; 3082 end if; 3083 3084 if Is_Root (Position) then 3085 3086 -- Should this be PE instead? Need ARG confirmation. ??? 3087 3088 raise Constraint_Error with "Position cursor designates root"; 3089 end if; 3090 3091 if Container.Nodes (Position.Node).Parent = Parent.Node then 3092 if Before = No_Element then 3093 if Container.Nodes (Position.Node).Next <= 0 then -- last child 3094 return; 3095 end if; 3096 3097 elsif Position.Node = Before.Node then 3098 return; 3099 3100 elsif Container.Nodes (Position.Node).Next = Before.Node then 3101 return; 3102 end if; 3103 end if; 3104 3105 if Container.Busy > 0 then 3106 raise Program_Error 3107 with "attempt to tamper with cursors (tree is busy)"; 3108 end if; 3109 3110 if Is_Reachable (Container => Container, 3111 From => Parent.Node, 3112 To => Position.Node) 3113 then 3114 raise Constraint_Error with "Position is ancestor of Parent"; 3115 end if; 3116 3117 Remove_Subtree (Container, Position.Node); 3118 Container.Nodes (Position.Node).Parent := Parent.Node; 3119 Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node); 3120 end Splice_Subtree; 3121 3122 procedure Splice_Subtree 3123 (Target : in out Tree; 3124 Parent : Count_Type; 3125 Before : Count_Type'Base; 3126 Source : in out Tree; 3127 Position : in out Count_Type) -- Source on input, Target on output 3128 is 3129 Source_Count : Count_Type := Subtree_Node_Count (Source, Position); 3130 pragma Assert (Source_Count >= 1); 3131 3132 Target_Subtree : Count_Type; 3133 Target_Count : Count_Type; 3134 3135 begin 3136 -- This is a utility operation to do the heavy lifting associated with 3137 -- splicing a subtree from one tree to another. Note that "splicing" 3138 -- is a bit of a misnomer here in the case of a bounded tree, because 3139 -- the elements must be copied from the source to the target. 3140 3141 if Target.Count > Target.Capacity - Source_Count then 3142 raise Capacity_Error -- ??? 3143 with "Source count exceeds available storage on Target"; 3144 end if; 3145 3146 -- Copy_Subtree returns a count of the number of nodes it inserts, but 3147 -- it does this by incrementing the value passed in. Therefore we must 3148 -- initialize the count before calling Copy_Subtree. 3149 3150 Target_Count := 0; 3151 3152 Copy_Subtree 3153 (Source => Source, 3154 Source_Subtree => Position, 3155 Target => Target, 3156 Target_Parent => Parent, 3157 Target_Subtree => Target_Subtree, 3158 Count => Target_Count); 3159 3160 pragma Assert (Target_Count = Source_Count); 3161 3162 -- Now link the newly-allocated subtree into the target. 3163 3164 Insert_Subtree_Node 3165 (Container => Target, 3166 Subtree => Target_Subtree, 3167 Parent => Parent, 3168 Before => Before); 3169 3170 Target.Count := Target.Count + Target_Count; 3171 3172 -- The manipulation of the Target container is complete. Now we remove 3173 -- the subtree from the Source container. 3174 3175 Remove_Subtree (Source, Position); -- unlink the subtree 3176 3177 -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of 3178 -- the number of nodes it deallocates, but it works by incrementing the 3179 -- value passed in. We must therefore initialize the count before 3180 -- calling it. 3181 3182 Source_Count := 0; 3183 3184 Deallocate_Subtree (Source, Position, Source_Count); 3185 pragma Assert (Source_Count = Target_Count); 3186 3187 Source.Count := Source.Count - Source_Count; 3188 3189 Position := Target_Subtree; 3190 end Splice_Subtree; 3191 3192 ------------------------ 3193 -- Subtree_Node_Count -- 3194 ------------------------ 3195 3196 function Subtree_Node_Count (Position : Cursor) return Count_Type is 3197 begin 3198 if Position = No_Element then 3199 return 0; 3200 end if; 3201 3202 if Position.Container.Count = 0 then 3203 pragma Assert (Is_Root (Position)); 3204 return 1; 3205 end if; 3206 3207 return Subtree_Node_Count (Position.Container.all, Position.Node); 3208 end Subtree_Node_Count; 3209 3210 function Subtree_Node_Count 3211 (Container : Tree; 3212 Subtree : Count_Type) return Count_Type 3213 is 3214 Result : Count_Type; 3215 Node : Count_Type'Base; 3216 3217 begin 3218 Result := 1; 3219 Node := Container.Nodes (Subtree).Children.First; 3220 while Node > 0 loop 3221 Result := Result + Subtree_Node_Count (Container, Node); 3222 Node := Container.Nodes (Node).Next; 3223 end loop; 3224 return Result; 3225 end Subtree_Node_Count; 3226 3227 ---------- 3228 -- Swap -- 3229 ---------- 3230 3231 procedure Swap 3232 (Container : in out Tree; 3233 I, J : Cursor) 3234 is 3235 begin 3236 if I = No_Element then 3237 raise Constraint_Error with "I cursor has no element"; 3238 end if; 3239 3240 if I.Container /= Container'Unrestricted_Access then 3241 raise Program_Error with "I cursor not in container"; 3242 end if; 3243 3244 if Is_Root (I) then 3245 raise Program_Error with "I cursor designates root"; 3246 end if; 3247 3248 if I = J then -- make this test sooner??? 3249 return; 3250 end if; 3251 3252 if J = No_Element then 3253 raise Constraint_Error with "J cursor has no element"; 3254 end if; 3255 3256 if J.Container /= Container'Unrestricted_Access then 3257 raise Program_Error with "J cursor not in container"; 3258 end if; 3259 3260 if Is_Root (J) then 3261 raise Program_Error with "J cursor designates root"; 3262 end if; 3263 3264 if Container.Lock > 0 then 3265 raise Program_Error 3266 with "attempt to tamper with elements (tree is locked)"; 3267 end if; 3268 3269 declare 3270 EE : Element_Array renames Container.Elements; 3271 EI : constant Element_Type := EE (I.Node); 3272 3273 begin 3274 EE (I.Node) := EE (J.Node); 3275 EE (J.Node) := EI; 3276 end; 3277 end Swap; 3278 3279 -------------------- 3280 -- Update_Element -- 3281 -------------------- 3282 3283 procedure Update_Element 3284 (Container : in out Tree; 3285 Position : Cursor; 3286 Process : not null access procedure (Element : in out Element_Type)) 3287 is 3288 begin 3289 if Position = No_Element then 3290 raise Constraint_Error with "Position cursor has no element"; 3291 end if; 3292 3293 if Position.Container /= Container'Unrestricted_Access then 3294 raise Program_Error with "Position cursor not in container"; 3295 end if; 3296 3297 if Is_Root (Position) then 3298 raise Program_Error with "Position cursor designates root"; 3299 end if; 3300 3301 declare 3302 T : Tree renames Position.Container.all'Unrestricted_Access.all; 3303 B : Natural renames T.Busy; 3304 L : Natural renames T.Lock; 3305 3306 begin 3307 B := B + 1; 3308 L := L + 1; 3309 3310 Process (Element => T.Elements (Position.Node)); 3311 3312 L := L - 1; 3313 B := B - 1; 3314 3315 exception 3316 when others => 3317 L := L - 1; 3318 B := B - 1; 3319 raise; 3320 end; 3321 end Update_Element; 3322 3323 ----------- 3324 -- Write -- 3325 ----------- 3326 3327 procedure Write 3328 (Stream : not null access Root_Stream_Type'Class; 3329 Container : Tree) 3330 is 3331 procedure Write_Children (Subtree : Count_Type); 3332 procedure Write_Subtree (Subtree : Count_Type); 3333 3334 -------------------- 3335 -- Write_Children -- 3336 -------------------- 3337 3338 procedure Write_Children (Subtree : Count_Type) is 3339 CC : Children_Type renames Container.Nodes (Subtree).Children; 3340 C : Count_Type'Base; 3341 3342 begin 3343 Count_Type'Write (Stream, Child_Count (Container, Subtree)); 3344 3345 C := CC.First; 3346 while C > 0 loop 3347 Write_Subtree (C); 3348 C := Container.Nodes (C).Next; 3349 end loop; 3350 end Write_Children; 3351 3352 ------------------- 3353 -- Write_Subtree -- 3354 ------------------- 3355 3356 procedure Write_Subtree (Subtree : Count_Type) is 3357 begin 3358 Element_Type'Write (Stream, Container.Elements (Subtree)); 3359 Write_Children (Subtree); 3360 end Write_Subtree; 3361 3362 -- Start of processing for Write 3363 3364 begin 3365 Count_Type'Write (Stream, Container.Count); 3366 3367 if Container.Count = 0 then 3368 return; 3369 end if; 3370 3371 Write_Children (Root_Node (Container)); 3372 end Write; 3373 3374 procedure Write 3375 (Stream : not null access Root_Stream_Type'Class; 3376 Position : Cursor) 3377 is 3378 begin 3379 raise Program_Error with "attempt to write tree cursor to stream"; 3380 end Write; 3381 3382 procedure Write 3383 (Stream : not null access Root_Stream_Type'Class; 3384 Item : Reference_Type) 3385 is 3386 begin 3387 raise Program_Error with "attempt to stream reference"; 3388 end Write; 3389 3390 procedure Write 3391 (Stream : not null access Root_Stream_Type'Class; 3392 Item : Constant_Reference_Type) 3393 is 3394 begin 3395 raise Program_Error with "attempt to stream reference"; 3396 end Write; 3397 3398end Ada.Containers.Bounded_Multiway_Trees; 3399