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