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