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