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