1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES --
9 -- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with System
; use type System
.Address
;
32 package body Ada
.Containers
.Bounded_Multiway_Trees
is
38 type Root_Iterator
is abstract new Limited_Controlled
and
39 Tree_Iterator_Interfaces
.Forward_Iterator
with
41 Container
: Tree_Access
;
45 overriding
procedure Finalize
(Object
: in out Root_Iterator
);
47 -----------------------
48 -- Subtree_Iterator --
49 -----------------------
51 type Subtree_Iterator
is new Root_Iterator
with null record;
53 overriding
function First
(Object
: Subtree_Iterator
) return Cursor
;
55 overriding
function Next
56 (Object
: Subtree_Iterator
;
57 Position
: Cursor
) return Cursor
;
63 type Child_Iterator
is new Root_Iterator
and
64 Tree_Iterator_Interfaces
.Reversible_Iterator
with null record;
66 overriding
function First
(Object
: Child_Iterator
) return Cursor
;
68 overriding
function Next
69 (Object
: Child_Iterator
;
70 Position
: Cursor
) return Cursor
;
72 overriding
function Last
(Object
: Child_Iterator
) return Cursor
;
74 overriding
function Previous
75 (Object
: Child_Iterator
;
76 Position
: Cursor
) return Cursor
;
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Initialize_Node
(Container
: in out Tree
; Index
: Count_Type
);
83 procedure Initialize_Root
(Container
: in out Tree
);
85 procedure Allocate_Node
86 (Container
: in out Tree
;
87 Initialize_Element
: not null access procedure (Index
: Count_Type
);
88 New_Node
: out Count_Type
);
90 procedure Allocate_Node
91 (Container
: in out Tree
;
92 New_Item
: Element_Type
;
93 New_Node
: out Count_Type
);
95 procedure Allocate_Node
96 (Container
: in out Tree
;
97 Stream
: not null access Root_Stream_Type
'Class;
98 New_Node
: out Count_Type
);
100 procedure Deallocate_Node
101 (Container
: in out Tree
;
104 procedure Deallocate_Children
105 (Container
: in out Tree
;
106 Subtree
: Count_Type
;
107 Count
: in out Count_Type
);
109 procedure Deallocate_Subtree
110 (Container
: in out Tree
;
111 Subtree
: Count_Type
;
112 Count
: in out Count_Type
);
114 function Equal_Children
116 Left_Subtree
: Count_Type
;
118 Right_Subtree
: Count_Type
) return Boolean;
120 function Equal_Subtree
122 Left_Subtree
: Count_Type
;
124 Right_Subtree
: Count_Type
) return Boolean;
126 procedure Iterate_Children
128 Subtree
: Count_Type
;
129 Process
: not null access procedure (Position
: Cursor
));
131 procedure Iterate_Subtree
133 Subtree
: Count_Type
;
134 Process
: not null access procedure (Position
: Cursor
));
136 procedure Copy_Children
138 Source_Parent
: Count_Type
;
139 Target
: in out Tree
;
140 Target_Parent
: Count_Type
;
141 Count
: in out Count_Type
);
143 procedure Copy_Subtree
145 Source_Subtree
: Count_Type
;
146 Target
: in out Tree
;
147 Target_Parent
: Count_Type
;
148 Target_Subtree
: out Count_Type
;
149 Count
: in out Count_Type
);
151 function Find_In_Children
153 Subtree
: Count_Type
;
154 Item
: Element_Type
) return Count_Type
;
156 function Find_In_Subtree
158 Subtree
: Count_Type
;
159 Item
: Element_Type
) return Count_Type
;
163 Parent
: Count_Type
) return Count_Type
;
165 function Subtree_Node_Count
167 Subtree
: Count_Type
) return Count_Type
;
169 function Is_Reachable
171 From
, To
: Count_Type
) return Boolean;
173 function Root_Node
(Container
: Tree
) return Count_Type
;
175 procedure Remove_Subtree
176 (Container
: in out Tree
;
177 Subtree
: Count_Type
);
179 procedure Insert_Subtree_Node
180 (Container
: in out Tree
;
181 Subtree
: Count_Type
'Base;
183 Before
: Count_Type
'Base);
185 procedure Insert_Subtree_List
186 (Container
: in out Tree
;
187 First
: Count_Type
'Base;
188 Last
: Count_Type
'Base;
190 Before
: Count_Type
'Base);
192 procedure Splice_Children
193 (Container
: in out Tree
;
194 Target_Parent
: Count_Type
;
195 Before
: Count_Type
'Base;
196 Source_Parent
: Count_Type
);
198 procedure Splice_Children
199 (Target
: in out Tree
;
200 Target_Parent
: Count_Type
;
201 Before
: Count_Type
'Base;
202 Source
: in out Tree
;
203 Source_Parent
: Count_Type
);
205 procedure Splice_Subtree
206 (Target
: in out Tree
;
208 Before
: Count_Type
'Base;
209 Source
: in out Tree
;
210 Position
: in out Count_Type
); -- source on input, target on output
216 function "=" (Left
, Right
: Tree
) return Boolean is
218 if Left
'Address = Right
'Address then
222 if Left
.Count
/= Right
.Count
then
226 if Left
.Count
= 0 then
230 return Equal_Children
232 Left_Subtree
=> Root_Node
(Left
),
234 Right_Subtree
=> Root_Node
(Right
));
241 procedure Adjust
(Control
: in out Reference_Control_Type
) is
243 if Control
.Container
/= null then
245 C
: Tree
renames Control
.Container
.all;
246 B
: Natural renames C
.Busy
;
247 L
: Natural renames C
.Lock
;
259 procedure Allocate_Node
260 (Container
: in out Tree
;
261 Initialize_Element
: not null access procedure (Index
: Count_Type
);
262 New_Node
: out Count_Type
)
265 if Container
.Free
>= 0 then
266 New_Node
:= Container
.Free
;
267 pragma Assert
(New_Node
in Container
.Elements
'Range);
269 -- We always perform the assignment first, before we change container
270 -- state, in order to defend against exceptions duration assignment.
272 Initialize_Element
(New_Node
);
274 Container
.Free
:= Container
.Nodes
(New_Node
).Next
;
277 -- A negative free store value means that the links of the nodes in
278 -- the free store have not been initialized. In this case, the nodes
279 -- are physically contiguous in the array, starting at the index that
280 -- is the absolute value of the Container.Free, and continuing until
281 -- the end of the array (Nodes'Last).
283 New_Node
:= abs Container
.Free
;
284 pragma Assert
(New_Node
in Container
.Elements
'Range);
286 -- As above, we perform this assignment first, before modifying any
289 Initialize_Element
(New_Node
);
291 Container
.Free
:= Container
.Free
- 1;
293 if abs Container
.Free
> Container
.Capacity
then
298 Initialize_Node
(Container
, New_Node
);
301 procedure Allocate_Node
302 (Container
: in out Tree
;
303 New_Item
: Element_Type
;
304 New_Node
: out Count_Type
)
306 procedure Initialize_Element
(Index
: Count_Type
);
308 procedure Initialize_Element
(Index
: Count_Type
) is
310 Container
.Elements
(Index
) := New_Item
;
311 end Initialize_Element
;
314 Allocate_Node
(Container
, Initialize_Element
'Access, New_Node
);
317 procedure Allocate_Node
318 (Container
: in out Tree
;
319 Stream
: not null access Root_Stream_Type
'Class;
320 New_Node
: out Count_Type
)
322 procedure Initialize_Element
(Index
: Count_Type
);
324 procedure Initialize_Element
(Index
: Count_Type
) is
326 Element_Type
'Read (Stream
, Container
.Elements
(Index
));
327 end Initialize_Element
;
330 Allocate_Node
(Container
, Initialize_Element
'Access, New_Node
);
337 function Ancestor_Find
339 Item
: Element_Type
) return Cursor
344 if Position
= No_Element
then
345 raise Constraint_Error
with "Position cursor has no element";
348 -- AI-0136 says to raise PE if Position equals the root node. This does
349 -- not seem correct, as this value is just the limiting condition of the
350 -- search. For now we omit this check, pending a ruling from the ARG.
353 -- if Is_Root (Position) then
354 -- raise Program_Error with "Position cursor designates root";
357 R
:= Root_Node
(Position
.Container
.all);
360 if Position
.Container
.Elements
(N
) = Item
then
361 return Cursor
'(Position.Container, N);
364 N := Position.Container.Nodes (N).Parent;
374 procedure Append_Child
375 (Container : in out Tree;
377 New_Item : Element_Type;
378 Count : Count_Type := 1)
380 Nodes : Tree_Node_Array renames Container.Nodes;
381 First, Last : Count_Type;
384 if Parent = No_Element then
385 raise Constraint_Error with "Parent cursor has no element";
388 if Parent.Container /= Container'Unrestricted_Access then
389 raise Program_Error with "Parent cursor not in container";
396 if Container.Count > Container.Capacity - Count then
398 with "requested count exceeds available storage";
401 if Container.Busy > 0 then
403 with "attempt to tamper with cursors (tree is busy)";
406 if Container.Count = 0 then
407 Initialize_Root (Container);
410 Allocate_Node (Container, New_Item, First);
411 Nodes (First).Parent := Parent.Node;
414 for J in Count_Type'(2) .. Count
loop
415 Allocate_Node
(Container
, New_Item
, Nodes
(Last
).Next
);
416 Nodes
(Nodes
(Last
).Next
).Parent
:= Parent
.Node
;
417 Nodes
(Nodes
(Last
).Next
).Prev
:= Last
;
419 Last
:= Nodes
(Last
).Next
;
423 (Container
=> Container
,
426 Parent
=> Parent
.Node
,
427 Before
=> No_Node
); -- means "insert at end of list"
429 Container
.Count
:= Container
.Count
+ Count
;
436 procedure Assign
(Target
: in out Tree
; Source
: Tree
) is
437 Target_Count
: Count_Type
;
440 if Target
'Address = Source
'Address then
444 if Target
.Capacity
< Source
.Count
then
445 raise Capacity_Error
-- ???
446 with "Target capacity is less than Source count";
449 Target
.Clear
; -- Checks busy bit
451 if Source
.Count
= 0 then
455 Initialize_Root
(Target
);
457 -- Copy_Children returns the number of nodes that it allocates, but it
458 -- does this by incrementing the count value passed in, so we must
459 -- initialize the count before calling Copy_Children.
465 Source_Parent
=> Root_Node
(Source
),
467 Target_Parent
=> Root_Node
(Target
),
468 Count
=> Target_Count
);
470 pragma Assert
(Target_Count
= Source
.Count
);
471 Target
.Count
:= Source
.Count
;
478 function Child_Count
(Parent
: Cursor
) return Count_Type
is
480 if Parent
= No_Element
then
483 elsif Parent
.Container
.Count
= 0 then
484 pragma Assert
(Is_Root
(Parent
));
488 return Child_Count
(Parent
.Container
.all, Parent
.Node
);
494 Parent
: Count_Type
) return Count_Type
496 NN
: Tree_Node_Array
renames Container
.Nodes
;
497 CC
: Children_Type
renames NN
(Parent
).Children
;
500 Node
: Count_Type
'Base;
506 Result
:= Result
+ 1;
507 Node
:= NN
(Node
).Next
;
517 function Child_Depth
(Parent
, Child
: Cursor
) return Count_Type
is
522 if Parent
= No_Element
then
523 raise Constraint_Error
with "Parent cursor has no element";
526 if Child
= No_Element
then
527 raise Constraint_Error
with "Child cursor has no element";
530 if Parent
.Container
/= Child
.Container
then
531 raise Program_Error
with "Parent and Child in different containers";
534 if Parent
.Container
.Count
= 0 then
535 pragma Assert
(Is_Root
(Parent
));
536 pragma Assert
(Child
= Parent
);
542 while N
/= Parent
.Node
loop
543 Result
:= Result
+ 1;
544 N
:= Parent
.Container
.Nodes
(N
).Parent
;
547 raise Program_Error
with "Parent is not ancestor of Child";
558 procedure Clear
(Container
: in out Tree
) is
559 Container_Count
: constant Count_Type
:= Container
.Count
;
563 if Container
.Busy
> 0 then
565 with "attempt to tamper with cursors (tree is busy)";
568 if Container_Count
= 0 then
572 Container
.Count
:= 0;
574 -- Deallocate_Children returns the number of nodes that it deallocates,
575 -- but it does this by incrementing the count value that is passed in,
576 -- so we must first initialize the count return value before calling it.
581 (Container
=> Container
,
582 Subtree
=> Root_Node
(Container
),
585 pragma Assert
(Count
= Container_Count
);
588 ------------------------
589 -- Constant_Reference --
590 ------------------------
592 function Constant_Reference
593 (Container
: aliased Tree
;
594 Position
: Cursor
) return Constant_Reference_Type
597 if Position
.Container
= null then
598 raise Constraint_Error
with
599 "Position cursor has no element";
602 if Position
.Container
/= Container
'Unrestricted_Access then
603 raise Program_Error
with
604 "Position cursor designates wrong container";
607 if Position
.Node
= Root_Node
(Container
) then
608 raise Program_Error
with "Position cursor designates root";
611 -- Implement Vet for multiway tree???
612 -- pragma Assert (Vet (Position),
613 -- "Position cursor in Constant_Reference is bad");
616 C
: Tree
renames Position
.Container
.all;
617 B
: Natural renames C
.Busy
;
618 L
: Natural renames C
.Lock
;
621 return R
: constant Constant_Reference_Type
:=
622 (Element
=> Container
.Elements
(Position
.Node
)'Access,
623 Control
=> (Controlled
with Container
'Unrestricted_Access))
629 end Constant_Reference
;
637 Item
: Element_Type
) return Boolean
640 return Find
(Container
, Item
) /= No_Element
;
649 Capacity
: Count_Type
:= 0) return Tree
656 elsif Capacity
>= Source
.Count
then
659 raise Capacity_Error
with "Capacity value too small";
662 return Target
: Tree
(Capacity
=> C
) do
663 Initialize_Root
(Target
);
665 if Source
.Count
= 0 then
671 Source_Parent
=> Root_Node
(Source
),
673 Target_Parent
=> Root_Node
(Target
),
674 Count
=> Target
.Count
);
676 pragma Assert
(Target
.Count
= Source
.Count
);
684 procedure Copy_Children
686 Source_Parent
: Count_Type
;
687 Target
: in out Tree
;
688 Target_Parent
: Count_Type
;
689 Count
: in out Count_Type
)
691 S_Nodes
: Tree_Node_Array
renames Source
.Nodes
;
692 S_Node
: Tree_Node_Type
renames S_Nodes
(Source_Parent
);
694 T_Nodes
: Tree_Node_Array
renames Target
.Nodes
;
695 T_Node
: Tree_Node_Type
renames T_Nodes
(Target_Parent
);
697 pragma Assert
(T_Node
.Children
.First
<= 0);
698 pragma Assert
(T_Node
.Children
.Last
<= 0);
700 T_CC
: Children_Type
;
704 -- We special-case the first allocation, in order to establish the
705 -- representation invariants for type Children_Type.
707 C
:= S_Node
.Children
.First
;
709 if C
<= 0 then -- source parent has no children
717 Target_Parent
=> Target_Parent
,
718 Target_Subtree
=> T_CC
.First
,
721 T_CC
.Last
:= T_CC
.First
;
723 -- The representation invariants for the Children_Type list have been
724 -- established, so we can now copy the remaining children of Source.
726 C
:= S_Nodes
(C
).Next
;
732 Target_Parent
=> Target_Parent
,
733 Target_Subtree
=> T_Nodes
(T_CC
.Last
).Next
,
736 T_Nodes
(T_Nodes
(T_CC
.Last
).Next
).Prev
:= T_CC
.Last
;
737 T_CC
.Last
:= T_Nodes
(T_CC
.Last
).Next
;
739 C
:= S_Nodes
(C
).Next
;
742 -- We add the newly-allocated children to their parent list only after
743 -- the allocation has succeeded, in order to preserve invariants of the
746 T_Node
.Children
:= T_CC
;
753 procedure Copy_Subtree
754 (Target
: in out Tree
;
759 Target_Subtree
: Count_Type
;
760 Target_Count
: Count_Type
;
763 if Parent
= No_Element
then
764 raise Constraint_Error
with "Parent cursor has no element";
767 if Parent
.Container
/= Target
'Unrestricted_Access then
768 raise Program_Error
with "Parent cursor not in container";
771 if Before
/= No_Element
then
772 if Before
.Container
/= Target
'Unrestricted_Access then
773 raise Program_Error
with "Before cursor not in container";
776 if Before
.Container
.Nodes
(Before
.Node
).Parent
/= Parent
.Node
then
777 raise Constraint_Error
with "Before cursor not child of Parent";
781 if Source
= No_Element
then
785 if Is_Root
(Source
) then
786 raise Constraint_Error
with "Source cursor designates root";
789 if Target
.Count
= 0 then
790 Initialize_Root
(Target
);
793 -- Copy_Subtree returns a count of the number of nodes that it
794 -- allocates, but it works by incrementing the value that is passed
795 -- in. We must therefore initialize the count value before calling
801 (Source
=> Source
.Container
.all,
802 Source_Subtree
=> Source
.Node
,
804 Target_Parent
=> Parent
.Node
,
805 Target_Subtree
=> Target_Subtree
,
806 Count
=> Target_Count
);
809 (Container
=> Target
,
810 Subtree
=> Target_Subtree
,
811 Parent
=> Parent
.Node
,
812 Before
=> Before
.Node
);
814 Target
.Count
:= Target
.Count
+ Target_Count
;
817 procedure Copy_Subtree
819 Source_Subtree
: Count_Type
;
820 Target
: in out Tree
;
821 Target_Parent
: Count_Type
;
822 Target_Subtree
: out Count_Type
;
823 Count
: in out Count_Type
)
825 T_Nodes
: Tree_Node_Array
renames Target
.Nodes
;
828 -- First we allocate the root of the target subtree.
831 (Container
=> Target
,
832 New_Item
=> Source
.Elements
(Source_Subtree
),
833 New_Node
=> Target_Subtree
);
835 T_Nodes
(Target_Subtree
).Parent
:= Target_Parent
;
838 -- We now have a new subtree (for the Target tree), containing only a
839 -- copy of the corresponding element in the Source subtree. Next we copy
840 -- the children of the Source subtree as children of the new Target
845 Source_Parent
=> Source_Subtree
,
847 Target_Parent
=> Target_Subtree
,
851 -------------------------
852 -- Deallocate_Children --
853 -------------------------
855 procedure Deallocate_Children
856 (Container
: in out Tree
;
857 Subtree
: Count_Type
;
858 Count
: in out Count_Type
)
860 Nodes
: Tree_Node_Array
renames Container
.Nodes
;
861 Node
: Tree_Node_Type
renames Nodes
(Subtree
); -- parent
862 CC
: Children_Type
renames Node
.Children
;
866 while CC
.First
> 0 loop
868 CC
.First
:= Nodes
(C
).Next
;
870 Deallocate_Subtree
(Container
, C
, Count
);
874 end Deallocate_Children
;
876 ---------------------
877 -- Deallocate_Node --
878 ---------------------
880 procedure Deallocate_Node
881 (Container
: in out Tree
;
884 NN
: Tree_Node_Array
renames Container
.Nodes
;
885 pragma Assert
(X
> 0);
886 pragma Assert
(X
<= NN
'Last);
888 N
: Tree_Node_Type
renames NN
(X
);
889 pragma Assert
(N
.Parent
/= X
); -- node is active
892 -- The tree container actually contains two lists: one for the "active"
893 -- nodes that contain elements that have been inserted onto the tree,
894 -- and another for the "inactive" nodes of the free store, from which
895 -- nodes are allocated when a new child is inserted in the tree.
897 -- We desire that merely declaring a tree object should have only
898 -- minimal cost; specially, we want to avoid having to initialize the
899 -- free store (to fill in the links), especially if the capacity of the
900 -- tree object is large.
902 -- The head of the free list is indicated by Container.Free. If its
903 -- value is non-negative, then the free store has been initialized in
904 -- the "normal" way: Container.Free points to the head of the list of
905 -- free (inactive) nodes, and the value 0 means the free list is
906 -- empty. Each node on the free list has been initialized to point to
907 -- the next free node (via its Next component), and the value 0 means
908 -- that this is the last node of the free list.
910 -- If Container.Free is negative, then the links on the free store have
911 -- not been initialized. In this case the link values are implied: the
912 -- free store comprises the components of the node array started with
913 -- the absolute value of Container.Free, and continuing until the end of
914 -- the array (Nodes'Last).
916 -- We prefer to lazy-init the free store (in fact, we would prefer to
917 -- not initialize it at all, because such initialization is an O(n)
918 -- operation). The time when we need to actually initialize the nodes in
919 -- the free store is when the node that becomes inactive is not at the
920 -- end of the active list. The free store would then be discontigous and
921 -- so its nodes would need to be linked in the traditional way.
923 -- It might be possible to perform an optimization here. Suppose that
924 -- the free store can be represented as having two parts: one comprising
925 -- the non-contiguous inactive nodes linked together in the normal way,
926 -- and the other comprising the contiguous inactive nodes (that are not
927 -- linked together, at the end of the nodes array). This would allow us
928 -- to never have to initialize the free store, except in a lazy way as
929 -- nodes become inactive. ???
931 -- When an element is deleted from the list container, its node becomes
932 -- inactive, and so we set its Parent and Prev components to an
933 -- impossible value (the index of the node itself), to indicate that it
934 -- is now inactive. This provides a useful way to detect a dangling
937 N
.Parent
:= X
; -- Node is deallocated (not on active list)
940 if Container
.Free
>= 0 then
941 -- The free store has previously been initialized. All we need to do
942 -- here is link the newly-free'd node onto the free list.
944 N
.Next
:= Container
.Free
;
947 elsif X
+ 1 = abs Container
.Free
then
948 -- The free store has not been initialized, and the node becoming
949 -- inactive immediately precedes the start of the free store. All
950 -- we need to do is move the start of the free store back by one.
952 N
.Next
:= X
; -- Not strictly necessary, but marginally safer
953 Container
.Free
:= Container
.Free
+ 1;
956 -- The free store has not been initialized, and the node becoming
957 -- inactive does not immediately precede the free store. Here we
958 -- first initialize the free store (meaning the links are given
959 -- values in the traditional way), and then link the newly-free'd
960 -- node onto the head of the free store.
962 -- See the comments above for an optimization opportunity. If the
963 -- next link for a node on the free store is negative, then this
964 -- means the remaining nodes on the free store are physically
965 -- contiguous, starting at the absolute value of that index value.
968 Container
.Free
:= abs Container
.Free
;
970 if Container
.Free
> Container
.Capacity
then
974 for J
in Container
.Free
.. Container
.Capacity
- 1 loop
975 NN
(J
).Next
:= J
+ 1;
978 NN
(Container
.Capacity
).Next
:= 0;
981 NN
(X
).Next
:= Container
.Free
;
986 ------------------------
987 -- Deallocate_Subtree --
988 ------------------------
990 procedure Deallocate_Subtree
991 (Container
: in out Tree
;
992 Subtree
: Count_Type
;
993 Count
: in out Count_Type
)
996 Deallocate_Children
(Container
, Subtree
, Count
);
997 Deallocate_Node
(Container
, Subtree
);
999 end Deallocate_Subtree
;
1001 ---------------------
1002 -- Delete_Children --
1003 ---------------------
1005 procedure Delete_Children
1006 (Container
: in out Tree
;
1012 if Parent
= No_Element
then
1013 raise Constraint_Error
with "Parent cursor has no element";
1016 if Parent
.Container
/= Container
'Unrestricted_Access then
1017 raise Program_Error
with "Parent cursor not in container";
1020 if Container
.Busy
> 0 then
1022 with "attempt to tamper with cursors (tree is busy)";
1025 if Container
.Count
= 0 then
1026 pragma Assert
(Is_Root
(Parent
));
1030 -- Deallocate_Children returns a count of the number of nodes that it
1031 -- deallocates, but it works by incrementing the value that is passed
1032 -- in. We must therefore initialize the count value before calling
1033 -- Deallocate_Children.
1037 Deallocate_Children
(Container
, Parent
.Node
, Count
);
1038 pragma Assert
(Count
<= Container
.Count
);
1040 Container
.Count
:= Container
.Count
- Count
;
1041 end Delete_Children
;
1047 procedure Delete_Leaf
1048 (Container
: in out Tree
;
1049 Position
: in out Cursor
)
1054 if Position
= No_Element
then
1055 raise Constraint_Error
with "Position cursor has no element";
1058 if Position
.Container
/= Container
'Unrestricted_Access then
1059 raise Program_Error
with "Position cursor not in container";
1062 if Is_Root
(Position
) then
1063 raise Program_Error
with "Position cursor designates root";
1066 if not Is_Leaf
(Position
) then
1067 raise Constraint_Error
with "Position cursor does not designate leaf";
1070 if Container
.Busy
> 0 then
1072 with "attempt to tamper with cursors (tree is busy)";
1076 Position
:= No_Element
;
1078 Remove_Subtree
(Container
, X
);
1079 Container
.Count
:= Container
.Count
- 1;
1081 Deallocate_Node
(Container
, X
);
1084 --------------------
1085 -- Delete_Subtree --
1086 --------------------
1088 procedure Delete_Subtree
1089 (Container
: in out Tree
;
1090 Position
: in out Cursor
)
1096 if Position
= No_Element
then
1097 raise Constraint_Error
with "Position cursor has no element";
1100 if Position
.Container
/= Container
'Unrestricted_Access then
1101 raise Program_Error
with "Position cursor not in container";
1104 if Is_Root
(Position
) then
1105 raise Program_Error
with "Position cursor designates root";
1108 if Container
.Busy
> 0 then
1110 with "attempt to tamper with cursors (tree is busy)";
1114 Position
:= No_Element
;
1116 Remove_Subtree
(Container
, X
);
1118 -- Deallocate_Subtree returns a count of the number of nodes that it
1119 -- deallocates, but it works by incrementing the value that is passed
1120 -- in. We must therefore initialize the count value before calling
1121 -- Deallocate_Subtree.
1125 Deallocate_Subtree
(Container
, X
, Count
);
1126 pragma Assert
(Count
<= Container
.Count
);
1128 Container
.Count
:= Container
.Count
- Count
;
1135 function Depth
(Position
: Cursor
) return Count_Type
is
1136 Result
: Count_Type
;
1137 N
: Count_Type
'Base;
1140 if Position
= No_Element
then
1144 if Is_Root
(Position
) then
1151 N
:= Position
.Container
.Nodes
(N
).Parent
;
1152 Result
:= Result
+ 1;
1162 function Element
(Position
: Cursor
) return Element_Type
is
1164 if Position
.Container
= null then
1165 raise Constraint_Error
with "Position cursor has no element";
1168 if Position
.Node
= Root_Node
(Position
.Container
.all) then
1169 raise Program_Error
with "Position cursor designates root";
1172 return Position
.Container
.Elements
(Position
.Node
);
1175 --------------------
1176 -- Equal_Children --
1177 --------------------
1179 function Equal_Children
1181 Left_Subtree
: Count_Type
;
1183 Right_Subtree
: Count_Type
) return Boolean
1185 L_NN
: Tree_Node_Array
renames Left_Tree
.Nodes
;
1186 R_NN
: Tree_Node_Array
renames Right_Tree
.Nodes
;
1188 Left_Children
: Children_Type
renames L_NN
(Left_Subtree
).Children
;
1189 Right_Children
: Children_Type
renames R_NN
(Right_Subtree
).Children
;
1191 L
, R
: Count_Type
'Base;
1194 if Child_Count
(Left_Tree
, Left_Subtree
)
1195 /= Child_Count
(Right_Tree
, Right_Subtree
)
1200 L
:= Left_Children
.First
;
1201 R
:= Right_Children
.First
;
1203 if not Equal_Subtree
(Left_Tree
, L
, Right_Tree
, R
) then
1218 function Equal_Subtree
1219 (Left_Position
: Cursor
;
1220 Right_Position
: Cursor
) return Boolean
1223 if Left_Position
= No_Element
then
1224 raise Constraint_Error
with "Left cursor has no element";
1227 if Right_Position
= No_Element
then
1228 raise Constraint_Error
with "Right cursor has no element";
1231 if Left_Position
= Right_Position
then
1235 if Is_Root
(Left_Position
) then
1236 if not Is_Root
(Right_Position
) then
1240 if Left_Position
.Container
.Count
= 0 then
1241 return Right_Position
.Container
.Count
= 0;
1244 if Right_Position
.Container
.Count
= 0 then
1248 return Equal_Children
1249 (Left_Tree
=> Left_Position
.Container
.all,
1250 Left_Subtree
=> Left_Position
.Node
,
1251 Right_Tree
=> Right_Position
.Container
.all,
1252 Right_Subtree
=> Right_Position
.Node
);
1255 if Is_Root
(Right_Position
) then
1259 return Equal_Subtree
1260 (Left_Tree
=> Left_Position
.Container
.all,
1261 Left_Subtree
=> Left_Position
.Node
,
1262 Right_Tree
=> Right_Position
.Container
.all,
1263 Right_Subtree
=> Right_Position
.Node
);
1266 function Equal_Subtree
1268 Left_Subtree
: Count_Type
;
1270 Right_Subtree
: Count_Type
) return Boolean
1273 if Left_Tree
.Elements
(Left_Subtree
) /=
1274 Right_Tree
.Elements
(Right_Subtree
)
1279 return Equal_Children
1280 (Left_Tree
=> Left_Tree
,
1281 Left_Subtree
=> Left_Subtree
,
1282 Right_Tree
=> Right_Tree
,
1283 Right_Subtree
=> Right_Subtree
);
1290 procedure Finalize
(Object
: in out Root_Iterator
) is
1291 B
: Natural renames Object
.Container
.Busy
;
1296 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1298 if Control
.Container
/= null then
1300 C
: Tree
renames Control
.Container
.all;
1301 B
: Natural renames C
.Busy
;
1302 L
: Natural renames C
.Lock
;
1308 Control
.Container
:= null;
1318 Item
: Element_Type
) return Cursor
1323 if Container
.Count
= 0 then
1327 Node
:= Find_In_Children
(Container
, Root_Node
(Container
), Item
);
1333 return Cursor
'(Container'Unrestricted_Access, Node);
1340 overriding function First (Object : Subtree_Iterator) return Cursor is
1342 if Object.Subtree = Root_Node (Object.Container.all) then
1343 return First_Child (Root (Object.Container.all));
1345 return Cursor'(Object
.Container
, Object
.Subtree
);
1349 overriding
function First
(Object
: Child_Iterator
) return Cursor
is
1351 return First_Child
(Cursor
'(Object.Container, Object.Subtree));
1358 function First_Child (Parent : Cursor) return Cursor is
1359 Node : Count_Type'Base;
1362 if Parent = No_Element then
1363 raise Constraint_Error with "Parent cursor has no element";
1366 if Parent.Container.Count = 0 then
1367 pragma Assert (Is_Root (Parent));
1371 Node := Parent.Container.Nodes (Parent.Node).Children.First;
1377 return Cursor'(Parent
.Container
, Node
);
1380 -------------------------
1381 -- First_Child_Element --
1382 -------------------------
1384 function First_Child_Element
(Parent
: Cursor
) return Element_Type
is
1386 return Element
(First_Child
(Parent
));
1387 end First_Child_Element
;
1389 ----------------------
1390 -- Find_In_Children --
1391 ----------------------
1393 function Find_In_Children
1395 Subtree
: Count_Type
;
1396 Item
: Element_Type
) return Count_Type
1398 N
: Count_Type
'Base;
1399 Result
: Count_Type
;
1402 N
:= Container
.Nodes
(Subtree
).Children
.First
;
1404 Result
:= Find_In_Subtree
(Container
, N
, Item
);
1410 N
:= Container
.Nodes
(N
).Next
;
1414 end Find_In_Children
;
1416 ---------------------
1417 -- Find_In_Subtree --
1418 ---------------------
1420 function Find_In_Subtree
1422 Item
: Element_Type
) return Cursor
1424 Result
: Count_Type
;
1427 if Position
= No_Element
then
1428 raise Constraint_Error
with "Position cursor has no element";
1431 -- Commented-out pending ruling by ARG. ???
1433 -- if Position.Container /= Container'Unrestricted_Access then
1434 -- raise Program_Error with "Position cursor not in container";
1437 if Position
.Container
.Count
= 0 then
1438 pragma Assert
(Is_Root
(Position
));
1442 if Is_Root
(Position
) then
1443 Result
:= Find_In_Children
1444 (Container
=> Position
.Container
.all,
1445 Subtree
=> Position
.Node
,
1449 Result
:= Find_In_Subtree
1450 (Container
=> Position
.Container
.all,
1451 Subtree
=> Position
.Node
,
1459 return Cursor
'(Position.Container, Result);
1460 end Find_In_Subtree;
1462 function Find_In_Subtree
1464 Subtree : Count_Type;
1465 Item : Element_Type) return Count_Type
1468 if Container.Elements (Subtree) = Item then
1472 return Find_In_Children (Container, Subtree, Item);
1473 end Find_In_Subtree;
1479 function Has_Element (Position : Cursor) return Boolean is
1481 if Position = No_Element then
1485 return Position.Node /= Root_Node (Position.Container.all);
1488 ---------------------
1489 -- Initialize_Node --
1490 ---------------------
1492 procedure Initialize_Node
1493 (Container : in out Tree;
1497 Container.Nodes (Index) :=
1501 Children => (others => 0));
1502 end Initialize_Node;
1504 ---------------------
1505 -- Initialize_Root --
1506 ---------------------
1508 procedure Initialize_Root (Container : in out Tree) is
1510 Initialize_Node (Container, Root_Node (Container));
1511 end Initialize_Root;
1517 procedure Insert_Child
1518 (Container : in out Tree;
1521 New_Item : Element_Type;
1522 Count : Count_Type := 1)
1525 pragma Unreferenced (Position);
1528 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1531 procedure Insert_Child
1532 (Container : in out Tree;
1535 New_Item : Element_Type;
1536 Position : out Cursor;
1537 Count : Count_Type := 1)
1539 Nodes : Tree_Node_Array renames Container.Nodes;
1544 if Parent = No_Element then
1545 raise Constraint_Error with "Parent cursor has no element";
1548 if Parent.Container /= Container'Unrestricted_Access then
1549 raise Program_Error with "Parent cursor not in container";
1552 if Before /= No_Element then
1553 if Before.Container /= Container'Unrestricted_Access then
1554 raise Program_Error with "Before cursor not in container";
1557 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then
1558 raise Constraint_Error with "Parent cursor not parent of Before";
1563 Position := No_Element; -- Need ruling from ARG ???
1567 if Container.Count > Container.Capacity - Count then
1568 raise Capacity_Error
1569 with "requested count exceeds available storage";
1572 if Container.Busy > 0 then
1574 with "attempt to tamper with cursors (tree is busy)";
1577 if Container.Count = 0 then
1578 Initialize_Root (Container);
1581 Allocate_Node (Container, New_Item, First);
1582 Nodes (First).Parent := Parent.Node;
1585 for J in Count_Type'(2) .. Count
loop
1586 Allocate_Node
(Container
, New_Item
, Nodes
(Last
).Next
);
1587 Nodes
(Nodes
(Last
).Next
).Parent
:= Parent
.Node
;
1588 Nodes
(Nodes
(Last
).Next
).Prev
:= Last
;
1590 Last
:= Nodes
(Last
).Next
;
1594 (Container
=> Container
,
1597 Parent
=> Parent
.Node
,
1598 Before
=> Before
.Node
);
1600 Container
.Count
:= Container
.Count
+ Count
;
1602 Position
:= Cursor
'(Parent.Container, First);
1605 procedure Insert_Child
1606 (Container : in out Tree;
1609 Position : out Cursor;
1610 Count : Count_Type := 1)
1612 Nodes : Tree_Node_Array renames Container.Nodes;
1616 New_Item : Element_Type;
1617 pragma Unmodified (New_Item);
1618 -- OK to reference, see below
1621 if Parent = No_Element then
1622 raise Constraint_Error with "Parent cursor has no element";
1625 if Parent.Container /= Container'Unrestricted_Access then
1626 raise Program_Error with "Parent cursor not in container";
1629 if Before /= No_Element then
1630 if Before.Container /= Container'Unrestricted_Access then
1631 raise Program_Error with "Before cursor not in container";
1634 if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then
1635 raise Constraint_Error with "Parent cursor not parent of Before";
1640 Position := No_Element; -- Need ruling from ARG ???
1644 if Container.Count > Container.Capacity - Count then
1645 raise Capacity_Error
1646 with "requested count exceeds available storage";
1649 if Container.Busy > 0 then
1651 with "attempt to tamper with cursors (tree is busy)";
1654 if Container.Count = 0 then
1655 Initialize_Root (Container);
1658 -- There is no explicit element provided, but in an instance the element
1659 -- type may be a scalar with a Default_Value aspect, or a composite
1660 -- type with such a scalar component, or components with default
1661 -- initialization, so insert the specified number of possibly
1662 -- initialized elements at the given position.
1664 Allocate_Node (Container, New_Item, First);
1665 Nodes (First).Parent := Parent.Node;
1668 for J in Count_Type'(2) .. Count
loop
1669 Allocate_Node
(Container
, New_Item
, Nodes
(Last
).Next
);
1670 Nodes
(Nodes
(Last
).Next
).Parent
:= Parent
.Node
;
1671 Nodes
(Nodes
(Last
).Next
).Prev
:= Last
;
1673 Last
:= Nodes
(Last
).Next
;
1677 (Container
=> Container
,
1680 Parent
=> Parent
.Node
,
1681 Before
=> Before
.Node
);
1683 Container
.Count
:= Container
.Count
+ Count
;
1685 Position
:= Cursor
'(Parent.Container, First);
1688 -------------------------
1689 -- Insert_Subtree_List --
1690 -------------------------
1692 procedure Insert_Subtree_List
1693 (Container : in out Tree;
1694 First : Count_Type'Base;
1695 Last : Count_Type'Base;
1696 Parent : Count_Type;
1697 Before : Count_Type'Base)
1699 NN : Tree_Node_Array renames Container.Nodes;
1700 N : Tree_Node_Type renames NN (Parent);
1701 CC : Children_Type renames N.Children;
1704 -- This is a simple utility operation to insert a list of nodes
1705 -- (First..Last) as children of Parent. The Before node specifies where
1706 -- the new children should be inserted relative to existing children.
1709 pragma Assert (Last <= 0);
1713 pragma Assert (Last > 0);
1714 pragma Assert (Before <= 0 or else NN (Before).Parent = Parent);
1716 if CC.First <= 0 then -- no existing children
1718 NN (CC.First).Prev := 0;
1720 NN (CC.Last).Next := 0;
1722 elsif Before <= 0 then -- means "insert after existing nodes"
1723 NN (CC.Last).Next := First;
1724 NN (First).Prev := CC.Last;
1726 NN (CC.Last).Next := 0;
1728 elsif Before = CC.First then
1729 NN (Last).Next := CC.First;
1730 NN (CC.First).Prev := Last;
1732 NN (CC.First).Prev := 0;
1735 NN (NN (Before).Prev).Next := First;
1736 NN (First).Prev := NN (Before).Prev;
1737 NN (Last).Next := Before;
1738 NN (Before).Prev := Last;
1740 end Insert_Subtree_List;
1742 -------------------------
1743 -- Insert_Subtree_Node --
1744 -------------------------
1746 procedure Insert_Subtree_Node
1747 (Container : in out Tree;
1748 Subtree : Count_Type'Base;
1749 Parent : Count_Type;
1750 Before : Count_Type'Base)
1753 -- This is a simple wrapper operation to insert a single child into the
1754 -- Parent's children list.
1757 (Container => Container,
1762 end Insert_Subtree_Node;
1768 function Is_Empty (Container : Tree) return Boolean is
1770 return Container.Count = 0;
1777 function Is_Leaf (Position : Cursor) return Boolean is
1779 if Position = No_Element then
1783 if Position.Container.Count = 0 then
1784 pragma Assert (Is_Root (Position));
1788 return Position.Container.Nodes (Position.Node).Children.First <= 0;
1795 function Is_Reachable
1797 From, To : Count_Type) return Boolean
1808 Idx := Container.Nodes (Idx).Parent;
1818 function Is_Root (Position : Cursor) return Boolean is
1821 (if Position.Container = null then False
1822 else Position.Node = Root_Node (Position.Container.all));
1831 Process : not null access procedure (Position : Cursor))
1833 B : Natural renames Container'Unrestricted_Access.all.Busy;
1836 if Container.Count = 0 then
1843 (Container => Container,
1844 Subtree => Root_Node (Container),
1845 Process => Process);
1855 function Iterate (Container : Tree)
1856 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1859 return Iterate_Subtree (Root (Container));
1862 ----------------------
1863 -- Iterate_Children --
1864 ----------------------
1866 procedure Iterate_Children
1868 Process : not null access procedure (Position : Cursor))
1871 if Parent = No_Element then
1872 raise Constraint_Error with "Parent cursor has no element";
1875 if Parent.Container.Count = 0 then
1876 pragma Assert (Is_Root (Parent));
1881 B : Natural renames Parent.Container.Busy;
1883 NN : Tree_Node_Array renames Parent.Container.Nodes;
1888 C := NN (Parent.Node).Children.First;
1890 Process (Cursor'(Parent
.Container
, Node
=> C
));
1901 end Iterate_Children
;
1903 procedure Iterate_Children
1905 Subtree
: Count_Type
;
1906 Process
: not null access procedure (Position
: Cursor
))
1908 NN
: Tree_Node_Array
renames Container
.Nodes
;
1909 N
: Tree_Node_Type
renames NN
(Subtree
);
1913 -- This is a helper function to recursively iterate over all the nodes
1914 -- in a subtree, in depth-first fashion. This particular helper just
1915 -- visits the children of this subtree, not the root of the subtree
1916 -- itself. This is useful when starting from the ultimate root of the
1917 -- entire tree (see Iterate), as that root does not have an element.
1919 C
:= N
.Children
.First
;
1921 Iterate_Subtree
(Container
, C
, Process
);
1924 end Iterate_Children
;
1926 function Iterate_Children
1929 return Tree_Iterator_Interfaces
.Reversible_Iterator
'Class
1931 C
: constant Tree_Access
:= Container
'Unrestricted_Access;
1932 B
: Natural renames C
.Busy
;
1935 if Parent
= No_Element
then
1936 raise Constraint_Error
with "Parent cursor has no element";
1939 if Parent
.Container
/= C
then
1940 raise Program_Error
with "Parent cursor not in container";
1943 return It
: constant Child_Iterator
:=
1944 Child_Iterator
'(Limited_Controlled with
1946 Subtree => Parent.Node)
1950 end Iterate_Children;
1952 ---------------------
1953 -- Iterate_Subtree --
1954 ---------------------
1956 function Iterate_Subtree
1958 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1961 if Position = No_Element then
1962 raise Constraint_Error with "Position cursor has no element";
1965 -- Implement Vet for multiway trees???
1966 -- pragma Assert (Vet (Position), "bad subtree cursor");
1969 B : Natural renames Position.Container.Busy;
1971 return It : constant Subtree_Iterator :=
1972 (Limited_Controlled with
1973 Container => Position.Container,
1974 Subtree => Position.Node)
1979 end Iterate_Subtree;
1981 procedure Iterate_Subtree
1983 Process : not null access procedure (Position : Cursor))
1986 if Position = No_Element then
1987 raise Constraint_Error with "Position cursor has no element";
1990 if Position.Container.Count = 0 then
1991 pragma Assert (Is_Root (Position));
1996 T : Tree renames Position.Container.all;
1997 B : Natural renames T.Busy;
2002 if Is_Root (Position) then
2003 Iterate_Children (T, Position.Node, Process);
2005 Iterate_Subtree (T, Position.Node, Process);
2015 end Iterate_Subtree;
2017 procedure Iterate_Subtree
2019 Subtree : Count_Type;
2020 Process : not null access procedure (Position : Cursor))
2023 -- This is a helper function to recursively iterate over all the nodes
2024 -- in a subtree, in depth-first fashion. It first visits the root of the
2025 -- subtree, then visits its children.
2027 Process (Cursor'(Container
'Unrestricted_Access, Subtree
));
2028 Iterate_Children
(Container
, Subtree
, Process
);
2029 end Iterate_Subtree
;
2035 overriding
function Last
(Object
: Child_Iterator
) return Cursor
is
2037 return Last_Child
(Cursor
'(Object.Container, Object.Subtree));
2044 function Last_Child (Parent : Cursor) return Cursor is
2045 Node : Count_Type'Base;
2048 if Parent = No_Element then
2049 raise Constraint_Error with "Parent cursor has no element";
2052 if Parent.Container.Count = 0 then
2053 pragma Assert (Is_Root (Parent));
2057 Node := Parent.Container.Nodes (Parent.Node).Children.Last;
2063 return Cursor'(Parent
.Container
, Node
);
2066 ------------------------
2067 -- Last_Child_Element --
2068 ------------------------
2070 function Last_Child_Element
(Parent
: Cursor
) return Element_Type
is
2072 return Element
(Last_Child
(Parent
));
2073 end Last_Child_Element
;
2079 procedure Move
(Target
: in out Tree
; Source
: in out Tree
) is
2081 if Target
'Address = Source
'Address then
2085 if Source
.Busy
> 0 then
2087 with "attempt to tamper with cursors of Source (tree is busy)";
2090 Target
.Assign
(Source
);
2098 overriding
function Next
2099 (Object
: Subtree_Iterator
;
2100 Position
: Cursor
) return Cursor
2103 if Position
.Container
= null then
2107 if Position
.Container
/= Object
.Container
then
2108 raise Program_Error
with
2109 "Position cursor of Next designates wrong tree";
2112 pragma Assert
(Object
.Container
.Count
> 0);
2113 pragma Assert
(Position
.Node
/= Root_Node
(Object
.Container
.all));
2116 Nodes
: Tree_Node_Array
renames Object
.Container
.Nodes
;
2120 Node
:= Position
.Node
;
2122 if Nodes
(Node
).Children
.First
> 0 then
2123 return Cursor
'(Object.Container, Nodes (Node).Children.First);
2126 while Node /= Object.Subtree loop
2127 if Nodes (Node).Next > 0 then
2128 return Cursor'(Object
.Container
, Nodes
(Node
).Next
);
2131 Node
:= Nodes
(Node
).Parent
;
2138 overriding
function Next
2139 (Object
: Child_Iterator
;
2140 Position
: Cursor
) return Cursor
2143 if Position
.Container
= null then
2147 if Position
.Container
/= Object
.Container
then
2148 raise Program_Error
with
2149 "Position cursor of Next designates wrong tree";
2152 pragma Assert
(Object
.Container
.Count
> 0);
2153 pragma Assert
(Position
.Node
/= Root_Node
(Object
.Container
.all));
2155 return Next_Sibling
(Position
);
2162 function Next_Sibling
(Position
: Cursor
) return Cursor
is
2164 if Position
= No_Element
then
2168 if Position
.Container
.Count
= 0 then
2169 pragma Assert
(Is_Root
(Position
));
2174 T
: Tree
renames Position
.Container
.all;
2175 NN
: Tree_Node_Array
renames T
.Nodes
;
2176 N
: Tree_Node_Type
renames NN
(Position
.Node
);
2183 return Cursor
'(Position.Container, N.Next);
2187 procedure Next_Sibling (Position : in out Cursor) is
2189 Position := Next_Sibling (Position);
2196 function Node_Count (Container : Tree) return Count_Type is
2198 -- Container.Count is the number of nodes we have actually allocated. We
2199 -- cache the value specifically so this Node_Count operation can execute
2200 -- in O(1) time, which makes it behave similarly to how the Length
2201 -- selector function behaves for other containers.
2203 -- The cached node count value only describes the nodes we have
2204 -- allocated; the root node itself is not included in that count. The
2205 -- Node_Count operation returns a value that includes the root node
2206 -- (because the RM says so), so we must add 1 to our cached value.
2208 return 1 + Container.Count;
2215 function Parent (Position : Cursor) return Cursor is
2217 if Position = No_Element then
2221 if Position.Container.Count = 0 then
2222 pragma Assert (Is_Root (Position));
2227 T : Tree renames Position.Container.all;
2228 NN : Tree_Node_Array renames T.Nodes;
2229 N : Tree_Node_Type renames NN (Position.Node);
2232 if N.Parent < 0 then
2233 pragma Assert (Position.Node = Root_Node (T));
2237 return Cursor'(Position
.Container
, N
.Parent
);
2245 procedure Prepend_Child
2246 (Container
: in out Tree
;
2248 New_Item
: Element_Type
;
2249 Count
: Count_Type
:= 1)
2251 Nodes
: Tree_Node_Array
renames Container
.Nodes
;
2252 First
, Last
: Count_Type
;
2255 if Parent
= No_Element
then
2256 raise Constraint_Error
with "Parent cursor has no element";
2259 if Parent
.Container
/= Container
'Unrestricted_Access then
2260 raise Program_Error
with "Parent cursor not in container";
2267 if Container
.Count
> Container
.Capacity
- Count
then
2268 raise Capacity_Error
2269 with "requested count exceeds available storage";
2272 if Container
.Busy
> 0 then
2274 with "attempt to tamper with cursors (tree is busy)";
2277 if Container
.Count
= 0 then
2278 Initialize_Root
(Container
);
2281 Allocate_Node
(Container
, New_Item
, First
);
2282 Nodes
(First
).Parent
:= Parent
.Node
;
2285 for J
in Count_Type
'(2) .. Count loop
2286 Allocate_Node (Container, New_Item, Nodes (Last).Next);
2287 Nodes (Nodes (Last).Next).Parent := Parent.Node;
2288 Nodes (Nodes (Last).Next).Prev := Last;
2290 Last := Nodes (Last).Next;
2294 (Container => Container,
2297 Parent => Parent.Node,
2298 Before => Nodes (Parent.Node).Children.First);
2300 Container.Count := Container.Count + Count;
2307 overriding function Previous
2308 (Object : Child_Iterator;
2309 Position : Cursor) return Cursor
2312 if Position.Container = null then
2316 if Position.Container /= Object.Container then
2317 raise Program_Error with
2318 "Position cursor of Previous designates wrong tree";
2321 return Previous_Sibling (Position);
2324 ----------------------
2325 -- Previous_Sibling --
2326 ----------------------
2328 function Previous_Sibling (Position : Cursor) return Cursor is
2330 if Position = No_Element then
2334 if Position.Container.Count = 0 then
2335 pragma Assert (Is_Root (Position));
2340 T : Tree renames Position.Container.all;
2341 NN : Tree_Node_Array renames T.Nodes;
2342 N : Tree_Node_Type renames NN (Position.Node);
2349 return Cursor'(Position
.Container
, N
.Prev
);
2351 end Previous_Sibling
;
2353 procedure Previous_Sibling
(Position
: in out Cursor
) is
2355 Position
:= Previous_Sibling
(Position
);
2356 end Previous_Sibling
;
2362 procedure Query_Element
2364 Process
: not null access procedure (Element
: Element_Type
))
2367 if Position
= No_Element
then
2368 raise Constraint_Error
with "Position cursor has no element";
2371 if Is_Root
(Position
) then
2372 raise Program_Error
with "Position cursor designates root";
2376 T
: Tree
renames Position
.Container
.all'Unrestricted_Access.all;
2377 B
: Natural renames T
.Busy
;
2378 L
: Natural renames T
.Lock
;
2384 Process
(Element
=> T
.Elements
(Position
.Node
));
2402 (Stream
: not null access Root_Stream_Type
'Class;
2403 Container
: out Tree
)
2405 procedure Read_Children
(Subtree
: Count_Type
);
2407 function Read_Subtree
2408 (Parent
: Count_Type
) return Count_Type
;
2410 NN
: Tree_Node_Array
renames Container
.Nodes
;
2412 Total_Count
: Count_Type
'Base;
2413 -- Value read from the stream that says how many elements follow
2415 Read_Count
: Count_Type
'Base;
2416 -- Actual number of elements read from the stream
2422 procedure Read_Children
(Subtree
: Count_Type
) is
2423 Count
: Count_Type
'Base;
2424 -- number of child subtrees
2429 Count_Type
'Read (Stream
, Count
);
2432 raise Program_Error
with "attempt to read from corrupt stream";
2439 CC
.First
:= Read_Subtree
(Parent
=> Subtree
);
2440 CC
.Last
:= CC
.First
;
2442 for J
in Count_Type
'(2) .. Count loop
2443 NN (CC.Last).Next := Read_Subtree (Parent => Subtree);
2444 NN (NN (CC.Last).Next).Prev := CC.Last;
2445 CC.Last := NN (CC.Last).Next;
2448 -- Now that the allocation and reads have completed successfully, it
2449 -- is safe to link the children to their parent.
2451 NN (Subtree).Children := CC;
2458 function Read_Subtree
2459 (Parent : Count_Type) return Count_Type
2461 Subtree : Count_Type;
2464 Allocate_Node (Container, Stream, Subtree);
2465 Container.Nodes (Subtree).Parent := Parent;
2467 Read_Count := Read_Count + 1;
2469 Read_Children (Subtree);
2474 -- Start of processing for Read
2477 Container.Clear; -- checks busy bit
2479 Count_Type'Read (Stream, Total_Count);
2481 if Total_Count < 0 then
2482 raise Program_Error with "attempt to read from corrupt stream";
2485 if Total_Count = 0 then
2489 if Total_Count > Container.Capacity then
2490 raise Capacity_Error -- ???
2491 with "node count in stream exceeds container capacity";
2494 Initialize_Root (Container);
2498 Read_Children (Root_Node (Container));
2500 if Read_Count /= Total_Count then
2501 raise Program_Error with "attempt to read from corrupt stream";
2504 Container.Count := Total_Count;
2508 (Stream : not null access Root_Stream_Type'Class;
2509 Position : out Cursor)
2512 raise Program_Error with "attempt to read tree cursor from stream";
2516 (Stream : not null access Root_Stream_Type'Class;
2517 Item : out Reference_Type)
2520 raise Program_Error with "attempt to stream reference";
2524 (Stream : not null access Root_Stream_Type'Class;
2525 Item : out Constant_Reference_Type)
2528 raise Program_Error with "attempt to stream reference";
2536 (Container : aliased in out Tree;
2537 Position : Cursor) return Reference_Type
2540 if Position.Container = null then
2541 raise Constraint_Error with
2542 "Position cursor has no element";
2545 if Position.Container /= Container'Unrestricted_Access then
2546 raise Program_Error with
2547 "Position cursor designates wrong container";
2550 if Position.Node = Root_Node (Container) then
2551 raise Program_Error with "Position cursor designates root";
2554 -- Implement Vet for multiway tree???
2555 -- pragma Assert (Vet (Position),
2556 -- "Position cursor in Constant_Reference is bad");
2559 C : Tree renames Position.Container.all;
2560 B : Natural renames C.Busy;
2561 L : Natural renames C.Lock;
2563 return R : constant Reference_Type :=
2564 (Element => Container.Elements (Position.Node)'Access,
2565 Control => (Controlled with Position.Container))
2574 --------------------
2575 -- Remove_Subtree --
2576 --------------------
2578 procedure Remove_Subtree
2579 (Container : in out Tree;
2580 Subtree : Count_Type)
2582 NN : Tree_Node_Array renames Container.Nodes;
2583 N : Tree_Node_Type renames NN (Subtree);
2584 CC : Children_Type renames NN (N.Parent).Children;
2587 -- This is a utility operation to remove a subtree node from its
2588 -- parent's list of children.
2590 if CC.First = Subtree then
2591 pragma Assert (N.Prev <= 0);
2593 if CC.Last = Subtree then
2594 pragma Assert (N.Next <= 0);
2600 NN (CC.First).Prev := 0;
2603 elsif CC.Last = Subtree then
2604 pragma Assert (N.Next <= 0);
2606 NN (CC.Last).Next := 0;
2609 NN (N.Prev).Next := N.Next;
2610 NN (N.Next).Prev := N.Prev;
2614 ----------------------
2615 -- Replace_Element --
2616 ----------------------
2618 procedure Replace_Element
2619 (Container : in out Tree;
2621 New_Item : Element_Type)
2624 if Position = No_Element then
2625 raise Constraint_Error with "Position cursor has no element";
2628 if Position.Container /= Container'Unrestricted_Access then
2629 raise Program_Error with "Position cursor not in container";
2632 if Is_Root (Position) then
2633 raise Program_Error with "Position cursor designates root";
2636 if Container.Lock > 0 then
2638 with "attempt to tamper with elements (tree is locked)";
2641 Container.Elements (Position.Node) := New_Item;
2642 end Replace_Element;
2644 ------------------------------
2645 -- Reverse_Iterate_Children --
2646 ------------------------------
2648 procedure Reverse_Iterate_Children
2650 Process : not null access procedure (Position : Cursor))
2653 if Parent = No_Element then
2654 raise Constraint_Error with "Parent cursor has no element";
2657 if Parent.Container.Count = 0 then
2658 pragma Assert (Is_Root (Parent));
2663 NN : Tree_Node_Array renames Parent.Container.Nodes;
2664 B : Natural renames Parent.Container.Busy;
2670 C := NN (Parent.Node).Children.Last;
2672 Process (Cursor'(Parent
.Container
, Node
=> C
));
2683 end Reverse_Iterate_Children
;
2689 function Root
(Container
: Tree
) return Cursor
is
2691 return (Container
'Unrestricted_Access, Root_Node
(Container
));
2698 function Root_Node
(Container
: Tree
) return Count_Type
is
2699 pragma Unreferenced
(Container
);
2705 ---------------------
2706 -- Splice_Children --
2707 ---------------------
2709 procedure Splice_Children
2710 (Target
: in out Tree
;
2711 Target_Parent
: Cursor
;
2713 Source
: in out Tree
;
2714 Source_Parent
: Cursor
)
2717 if Target_Parent
= No_Element
then
2718 raise Constraint_Error
with "Target_Parent cursor has no element";
2721 if Target_Parent
.Container
/= Target
'Unrestricted_Access then
2723 with "Target_Parent cursor not in Target container";
2726 if Before
/= No_Element
then
2727 if Before
.Container
/= Target
'Unrestricted_Access then
2729 with "Before cursor not in Target container";
2732 if Target
.Nodes
(Before
.Node
).Parent
/= Target_Parent
.Node
then
2733 raise Constraint_Error
2734 with "Before cursor not child of Target_Parent";
2738 if Source_Parent
= No_Element
then
2739 raise Constraint_Error
with "Source_Parent cursor has no element";
2742 if Source_Parent
.Container
/= Source
'Unrestricted_Access then
2744 with "Source_Parent cursor not in Source container";
2747 if Source
.Count
= 0 then
2748 pragma Assert
(Is_Root
(Source_Parent
));
2752 if Target
'Address = Source
'Address then
2753 if Target_Parent
= Source_Parent
then
2757 if Target
.Busy
> 0 then
2759 with "attempt to tamper with cursors (Target tree is busy)";
2762 if Is_Reachable
(Container
=> Target
,
2763 From
=> Target_Parent
.Node
,
2764 To
=> Source_Parent
.Node
)
2766 raise Constraint_Error
2767 with "Source_Parent is ancestor of Target_Parent";
2771 (Container
=> Target
,
2772 Target_Parent
=> Target_Parent
.Node
,
2773 Before
=> Before
.Node
,
2774 Source_Parent
=> Source_Parent
.Node
);
2779 if Target
.Busy
> 0 then
2781 with "attempt to tamper with cursors (Target tree is busy)";
2784 if Source
.Busy
> 0 then
2786 with "attempt to tamper with cursors (Source tree is busy)";
2789 if Target
.Count
= 0 then
2790 Initialize_Root
(Target
);
2795 Target_Parent
=> Target_Parent
.Node
,
2796 Before
=> Before
.Node
,
2798 Source_Parent
=> Source_Parent
.Node
);
2799 end Splice_Children
;
2801 procedure Splice_Children
2802 (Container
: in out Tree
;
2803 Target_Parent
: Cursor
;
2805 Source_Parent
: Cursor
)
2808 if Target_Parent
= No_Element
then
2809 raise Constraint_Error
with "Target_Parent cursor has no element";
2812 if Target_Parent
.Container
/= Container
'Unrestricted_Access then
2814 with "Target_Parent cursor not in container";
2817 if Before
/= No_Element
then
2818 if Before
.Container
/= Container
'Unrestricted_Access then
2820 with "Before cursor not in container";
2823 if Container
.Nodes
(Before
.Node
).Parent
/= Target_Parent
.Node
then
2824 raise Constraint_Error
2825 with "Before cursor not child of Target_Parent";
2829 if Source_Parent
= No_Element
then
2830 raise Constraint_Error
with "Source_Parent cursor has no element";
2833 if Source_Parent
.Container
/= Container
'Unrestricted_Access then
2835 with "Source_Parent cursor not in container";
2838 if Target_Parent
= Source_Parent
then
2842 pragma Assert
(Container
.Count
> 0);
2844 if Container
.Busy
> 0 then
2846 with "attempt to tamper with cursors (tree is busy)";
2849 if Is_Reachable
(Container
=> Container
,
2850 From
=> Target_Parent
.Node
,
2851 To
=> Source_Parent
.Node
)
2853 raise Constraint_Error
2854 with "Source_Parent is ancestor of Target_Parent";
2858 (Container
=> Container
,
2859 Target_Parent
=> Target_Parent
.Node
,
2860 Before
=> Before
.Node
,
2861 Source_Parent
=> Source_Parent
.Node
);
2862 end Splice_Children
;
2864 procedure Splice_Children
2865 (Container
: in out Tree
;
2866 Target_Parent
: Count_Type
;
2867 Before
: Count_Type
'Base;
2868 Source_Parent
: Count_Type
)
2870 NN
: Tree_Node_Array
renames Container
.Nodes
;
2871 CC
: constant Children_Type
:= NN
(Source_Parent
).Children
;
2872 C
: Count_Type
'Base;
2875 -- This is a utility operation to remove the children from Source parent
2876 -- and insert them into Target parent.
2878 NN
(Source_Parent
).Children
:= Children_Type
'(others => 0);
2880 -- Fix up the Parent pointers of each child to designate its new Target
2885 NN (C).Parent := Target_Parent;
2890 (Container => Container,
2893 Parent => Target_Parent,
2895 end Splice_Children;
2897 procedure Splice_Children
2898 (Target : in out Tree;
2899 Target_Parent : Count_Type;
2900 Before : Count_Type'Base;
2901 Source : in out Tree;
2902 Source_Parent : Count_Type)
2904 S_NN : Tree_Node_Array renames Source.Nodes;
2905 S_CC : Children_Type renames S_NN (Source_Parent).Children;
2907 Target_Count, Source_Count : Count_Type;
2908 T, S : Count_Type'Base;
2911 -- This is a utility operation to copy the children from the Source
2912 -- parent and insert them as children of the Target parent, and then
2913 -- delete them from the Source. (This is not a true splice operation,
2914 -- but it is the best we can do in a bounded form.) The Before position
2915 -- specifies where among the Target parent's exising children the new
2916 -- children are inserted.
2918 -- Before we attempt the insertion, we must count the sources nodes in
2919 -- order to determine whether the target have enough storage
2920 -- available. Note that calculating this value is an O(n) operation.
2922 -- Here is an optimization opportunity: iterate of each children the
2923 -- source explicitly, and keep a running count of the total number of
2924 -- nodes. Compare the running total to the capacity of the target each
2925 -- pass through the loop. This is more efficient than summing the counts
2926 -- of child subtree (which is what Subtree_Node_Count does) and then
2927 -- comparing that total sum to the target's capacity. ???
2929 -- Here is another possibility. We currently treat the splice as an
2930 -- all-or-nothing proposition: either we can insert all of children of
2931 -- the source, or we raise exception with modifying the target. The
2932 -- price for not causing side-effect is an O(n) determination of the
2933 -- source count. If we are willing to tolerate side-effect, then we
2934 -- could loop over the children of the source, counting that subtree and
2935 -- then immediately inserting it in the target. The issue here is that
2936 -- the test for available storage could fail during some later pass,
2937 -- after children have already been inserted into target. ???
2939 Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1;
2941 if Source_Count = 0 then
2945 if Target.Count > Target.Capacity - Source_Count then
2946 raise Capacity_Error -- ???
2947 with "Source count exceeds available storage on Target";
2950 -- Copy_Subtree returns a count of the number of nodes it inserts, but
2951 -- it does this by incrementing the value passed in. Therefore we must
2952 -- initialize the count before calling Copy_Subtree.
2960 Source_Subtree => S,
2962 Target_Parent => Target_Parent,
2963 Target_Subtree => T,
2964 Count => Target_Count);
2967 (Container => Target,
2969 Parent => Target_Parent,
2975 pragma Assert (Target_Count = Source_Count);
2976 Target.Count := Target.Count + Target_Count;
2978 -- As with Copy_Subtree, operation Deallocate_Children returns a count
2979 -- of the number of nodes it deallocates, but it works by incrementing
2980 -- the value passed in. We must therefore initialize the count before
2985 Deallocate_Children (Source, Source_Parent, Source_Count);
2986 pragma Assert (Source_Count = Target_Count);
2988 Source.Count := Source.Count - Source_Count;
2989 end Splice_Children;
2991 --------------------
2992 -- Splice_Subtree --
2993 --------------------
2995 procedure Splice_Subtree
2996 (Target : in out Tree;
2999 Source : in out Tree;
3000 Position : in out Cursor)
3003 if Parent = No_Element then
3004 raise Constraint_Error with "Parent cursor has no element";
3007 if Parent.Container /= Target'Unrestricted_Access then
3008 raise Program_Error with "Parent cursor not in Target container";
3011 if Before /= No_Element then
3012 if Before.Container /= Target'Unrestricted_Access then
3013 raise Program_Error with "Before cursor not in Target container";
3016 if Target.Nodes (Before.Node).Parent /= Parent.Node then
3017 raise Constraint_Error with "Before cursor not child of Parent";
3021 if Position = No_Element then
3022 raise Constraint_Error with "Position cursor has no element";
3025 if Position.Container /= Source'Unrestricted_Access then
3026 raise Program_Error with "Position cursor not in Source container";
3029 if Is_Root (Position) then
3030 raise Program_Error with "Position cursor designates root";
3033 if Target'Address = Source'Address then
3034 if Target.Nodes (Position.Node).Parent = Parent.Node then
3035 if Before = No_Element then
3036 if Target.Nodes (Position.Node).Next <= 0 then -- last child
3040 elsif Position.Node = Before.Node then
3043 elsif Target.Nodes (Position.Node).Next = Before.Node then
3048 if Target.Busy > 0 then
3050 with "attempt to tamper with cursors (Target tree is busy)";
3053 if Is_Reachable (Container => Target,
3054 From => Parent.Node,
3055 To => Position.Node)
3057 raise Constraint_Error with "Position is ancestor of Parent";
3060 Remove_Subtree (Target, Position.Node);
3062 Target.Nodes (Position.Node).Parent := Parent.Node;
3063 Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node);
3068 if Target.Busy > 0 then
3070 with "attempt to tamper with cursors (Target tree is busy)";
3073 if Source.Busy > 0 then
3075 with "attempt to tamper with cursors (Source tree is busy)";
3078 if Target.Count = 0 then
3079 Initialize_Root (Target);
3084 Parent => Parent.Node,
3085 Before => Before.Node,
3087 Position => Position.Node); -- modified during call
3089 Position.Container := Target'Unrestricted_Access;
3092 procedure Splice_Subtree
3093 (Container : in out Tree;
3099 if Parent = No_Element then
3100 raise Constraint_Error with "Parent cursor has no element";
3103 if Parent.Container /= Container'Unrestricted_Access then
3104 raise Program_Error with "Parent cursor not in container";
3107 if Before /= No_Element then
3108 if Before.Container /= Container'Unrestricted_Access then
3109 raise Program_Error with "Before cursor not in container";
3112 if Container.Nodes (Before.Node).Parent /= Parent.Node then
3113 raise Constraint_Error with "Before cursor not child of Parent";
3117 if Position = No_Element then
3118 raise Constraint_Error with "Position cursor has no element";
3121 if Position.Container /= Container'Unrestricted_Access then
3122 raise Program_Error with "Position cursor not in container";
3125 if Is_Root (Position) then
3127 -- Should this be PE instead? Need ARG confirmation. ???
3129 raise Constraint_Error with "Position cursor designates root";
3132 if Container.Nodes (Position.Node).Parent = Parent.Node then
3133 if Before = No_Element then
3134 if Container.Nodes (Position.Node).Next <= 0 then -- last child
3138 elsif Position.Node = Before.Node then
3141 elsif Container.Nodes (Position.Node).Next = Before.Node then
3146 if Container.Busy > 0 then
3148 with "attempt to tamper with cursors (tree is busy)";
3151 if Is_Reachable (Container => Container,
3152 From => Parent.Node,
3153 To => Position.Node)
3155 raise Constraint_Error with "Position is ancestor of Parent";
3158 Remove_Subtree (Container, Position.Node);
3159 Container.Nodes (Position.Node).Parent := Parent.Node;
3160 Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node);
3163 procedure Splice_Subtree
3164 (Target : in out Tree;
3165 Parent : Count_Type;
3166 Before : Count_Type'Base;
3167 Source : in out Tree;
3168 Position : in out Count_Type) -- Source on input, Target on output
3170 Source_Count : Count_Type := Subtree_Node_Count (Source, Position);
3171 pragma Assert (Source_Count >= 1);
3173 Target_Subtree : Count_Type;
3174 Target_Count : Count_Type;
3177 -- This is a utility operation to do the heavy lifting associated with
3178 -- splicing a subtree from one tree to another. Note that "splicing"
3179 -- is a bit of a misnomer here in the case of a bounded tree, because
3180 -- the elements must be copied from the source to the target.
3182 if Target.Count > Target.Capacity - Source_Count then
3183 raise Capacity_Error -- ???
3184 with "Source count exceeds available storage on Target";
3187 -- Copy_Subtree returns a count of the number of nodes it inserts, but
3188 -- it does this by incrementing the value passed in. Therefore we must
3189 -- initialize the count before calling Copy_Subtree.
3195 Source_Subtree => Position,
3197 Target_Parent => Parent,
3198 Target_Subtree => Target_Subtree,
3199 Count => Target_Count);
3201 pragma Assert (Target_Count = Source_Count);
3203 -- Now link the newly-allocated subtree into the target.
3206 (Container => Target,
3207 Subtree => Target_Subtree,
3211 Target.Count := Target.Count + Target_Count;
3213 -- The manipulation of the Target container is complete. Now we remove
3214 -- the subtree from the Source container.
3216 Remove_Subtree (Source, Position); -- unlink the subtree
3218 -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of
3219 -- the number of nodes it deallocates, but it works by incrementing the
3220 -- value passed in. We must therefore initialize the count before
3225 Deallocate_Subtree (Source, Position, Source_Count);
3226 pragma Assert (Source_Count = Target_Count);
3228 Source.Count := Source.Count - Source_Count;
3230 Position := Target_Subtree;
3233 ------------------------
3234 -- Subtree_Node_Count --
3235 ------------------------
3237 function Subtree_Node_Count (Position : Cursor) return Count_Type is
3239 if Position = No_Element then
3243 if Position.Container.Count = 0 then
3244 pragma Assert (Is_Root (Position));
3248 return Subtree_Node_Count (Position.Container.all, Position.Node);
3249 end Subtree_Node_Count;
3251 function Subtree_Node_Count
3253 Subtree : Count_Type) return Count_Type
3255 Result : Count_Type;
3256 Node : Count_Type'Base;
3260 Node := Container.Nodes (Subtree).Children.First;
3262 Result := Result + Subtree_Node_Count (Container, Node);
3263 Node := Container.Nodes (Node).Next;
3266 end Subtree_Node_Count;
3273 (Container : in out Tree;
3277 if I = No_Element then
3278 raise Constraint_Error with "I cursor has no element";
3281 if I.Container /= Container'Unrestricted_Access then
3282 raise Program_Error with "I cursor not in container";
3286 raise Program_Error with "I cursor designates root";
3289 if I = J then -- make this test sooner???
3293 if J = No_Element then
3294 raise Constraint_Error with "J cursor has no element";
3297 if J.Container /= Container'Unrestricted_Access then
3298 raise Program_Error with "J cursor not in container";
3302 raise Program_Error with "J cursor designates root";
3305 if Container.Lock > 0 then
3307 with "attempt to tamper with elements (tree is locked)";
3311 EE : Element_Array renames Container.Elements;
3312 EI : constant Element_Type := EE (I.Node);
3315 EE (I.Node) := EE (J.Node);
3320 --------------------
3321 -- Update_Element --
3322 --------------------
3324 procedure Update_Element
3325 (Container : in out Tree;
3327 Process : not null access procedure (Element : in out Element_Type))
3330 if Position = No_Element then
3331 raise Constraint_Error with "Position cursor has no element";
3334 if Position.Container /= Container'Unrestricted_Access then
3335 raise Program_Error with "Position cursor not in container";
3338 if Is_Root (Position) then
3339 raise Program_Error with "Position cursor designates root";
3343 T : Tree renames Position.Container.all'Unrestricted_Access.all;
3344 B : Natural renames T.Busy;
3345 L : Natural renames T.Lock;
3351 Process (Element => T.Elements (Position.Node));
3369 (Stream : not null access Root_Stream_Type'Class;
3372 procedure Write_Children (Subtree : Count_Type);
3373 procedure Write_Subtree (Subtree : Count_Type);
3375 --------------------
3376 -- Write_Children --
3377 --------------------
3379 procedure Write_Children (Subtree : Count_Type) is
3380 CC : Children_Type renames Container.Nodes (Subtree).Children;
3381 C : Count_Type'Base;
3384 Count_Type'Write (Stream, Child_Count (Container, Subtree));
3389 C := Container.Nodes (C).Next;
3397 procedure Write_Subtree (Subtree : Count_Type) is
3399 Element_Type'Write (Stream, Container.Elements (Subtree));
3400 Write_Children (Subtree);
3403 -- Start of processing for Write
3406 Count_Type'Write (Stream, Container.Count);
3408 if Container.Count = 0 then
3412 Write_Children (Root_Node (Container));
3416 (Stream : not null access Root_Stream_Type'Class;
3420 raise Program_Error with "attempt to write tree cursor to stream";
3424 (Stream : not null access Root_Stream_Type'Class;
3425 Item : Reference_Type)
3428 raise Program_Error with "attempt to stream reference";
3432 (Stream : not null access Root_Stream_Type'Class;
3433 Item : Constant_Reference_Type)
3436 raise Program_Error with "attempt to stream reference";
3439 end Ada.Containers.Bounded_Multiway_Trees;