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