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