1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
9 -- Copyright (C) 2004-2012, 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 Ada
.Unchecked_Deallocation
;
32 with System
; use type System
.Address
;
34 package body Ada
.Containers
.Indefinite_Multiway_Trees
is
40 type Root_Iterator
is abstract new Limited_Controlled
and
41 Tree_Iterator_Interfaces
.Forward_Iterator
with
43 Container
: Tree_Access
;
44 Subtree
: Tree_Node_Access
;
47 overriding
procedure Finalize
(Object
: in out Root_Iterator
);
49 -----------------------
50 -- Subtree_Iterator --
51 -----------------------
53 type Subtree_Iterator
is new Root_Iterator
with null record;
55 overriding
function First
(Object
: Subtree_Iterator
) return Cursor
;
57 overriding
function Next
58 (Object
: Subtree_Iterator
;
59 Position
: Cursor
) return Cursor
;
65 type Child_Iterator
is new Root_Iterator
and
66 Tree_Iterator_Interfaces
.Reversible_Iterator
with null record;
68 overriding
function First
(Object
: Child_Iterator
) return Cursor
;
70 overriding
function Next
71 (Object
: Child_Iterator
;
72 Position
: Cursor
) return Cursor
;
74 overriding
function Last
(Object
: Child_Iterator
) return Cursor
;
76 overriding
function Previous
77 (Object
: Child_Iterator
;
78 Position
: Cursor
) return Cursor
;
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Root_Node
(Container
: Tree
) return Tree_Node_Access
;
86 procedure Free_Element
is
87 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
89 procedure Deallocate_Node
(X
: in out Tree_Node_Access
);
91 procedure Deallocate_Children
92 (Subtree
: Tree_Node_Access
;
93 Count
: in out Count_Type
);
95 procedure Deallocate_Subtree
96 (Subtree
: in out Tree_Node_Access
;
97 Count
: in out Count_Type
);
99 function Equal_Children
100 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
102 function Equal_Subtree
103 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
105 procedure Iterate_Children
106 (Container
: Tree_Access
;
107 Subtree
: Tree_Node_Access
;
108 Process
: not null access procedure (Position
: Cursor
));
110 procedure Iterate_Subtree
111 (Container
: Tree_Access
;
112 Subtree
: Tree_Node_Access
;
113 Process
: not null access procedure (Position
: Cursor
));
115 procedure Copy_Children
116 (Source
: Children_Type
;
117 Parent
: Tree_Node_Access
;
118 Count
: in out Count_Type
);
120 procedure Copy_Subtree
121 (Source
: Tree_Node_Access
;
122 Parent
: Tree_Node_Access
;
123 Target
: out Tree_Node_Access
;
124 Count
: in out Count_Type
);
126 function Find_In_Children
127 (Subtree
: Tree_Node_Access
;
128 Item
: Element_Type
) return Tree_Node_Access
;
130 function Find_In_Subtree
131 (Subtree
: Tree_Node_Access
;
132 Item
: Element_Type
) return Tree_Node_Access
;
134 function Child_Count
(Children
: Children_Type
) return Count_Type
;
136 function Subtree_Node_Count
137 (Subtree
: Tree_Node_Access
) return Count_Type
;
139 function Is_Reachable
(From
, To
: Tree_Node_Access
) return Boolean;
141 procedure Remove_Subtree
(Subtree
: Tree_Node_Access
);
143 procedure Insert_Subtree_Node
144 (Subtree
: Tree_Node_Access
;
145 Parent
: Tree_Node_Access
;
146 Before
: Tree_Node_Access
);
148 procedure Insert_Subtree_List
149 (First
: Tree_Node_Access
;
150 Last
: Tree_Node_Access
;
151 Parent
: Tree_Node_Access
;
152 Before
: Tree_Node_Access
);
154 procedure Splice_Children
155 (Target_Parent
: Tree_Node_Access
;
156 Before
: Tree_Node_Access
;
157 Source_Parent
: Tree_Node_Access
);
163 function "=" (Left
, Right
: Tree
) return Boolean is
165 if Left
'Address = Right
'Address then
169 return Equal_Children
(Root_Node
(Left
), Root_Node
(Right
));
176 procedure Adjust
(Container
: in out Tree
) is
177 Source
: constant Children_Type
:= Container
.Root
.Children
;
178 Source_Count
: constant Count_Type
:= Container
.Count
;
179 Target_Count
: Count_Type
;
182 -- We first restore the target container to its default-initialized
183 -- state, before we attempt any allocation, to ensure that invariants
184 -- are preserved in the event that the allocation fails.
186 Container
.Root
.Children
:= Children_Type
'(others => null);
189 Container.Count := 0;
191 -- Copy_Children returns a count of the number of nodes that it
192 -- allocates, but it works by incrementing the value that is passed in.
193 -- We must therefore initialize the count value before calling
198 -- Now we attempt the allocation of subtrees. The invariants are
199 -- satisfied even if the allocation fails.
201 Copy_Children (Source, Root_Node (Container), Target_Count);
202 pragma Assert (Target_Count = Source_Count);
204 Container.Count := Source_Count;
207 procedure Adjust (Control : in out Reference_Control_Type) is
209 if Control.Container /= null then
211 C : Tree renames Control.Container.all;
212 B : Natural renames C.Busy;
213 L : Natural renames C.Lock;
225 function Ancestor_Find
227 Item : Element_Type) return Cursor
229 R, N : Tree_Node_Access;
232 if Position = No_Element then
233 raise Constraint_Error with "Position cursor has no element";
236 -- Commented-out pending ARG ruling. ???
238 -- if Position.Container /= Container'Unrestricted_Access then
239 -- raise Program_Error with "Position cursor not in container";
242 -- AI-0136 says to raise PE if Position equals the root node. This does
243 -- not seem correct, as this value is just the limiting condition of the
244 -- search. For now we omit this check pending a ruling from the ARG.???
246 -- if Is_Root (Position) then
247 -- raise Program_Error with "Position cursor designates root";
250 R := Root_Node (Position.Container.all);
253 if N.Element.all = Item then
254 return Cursor'(Position
.Container
, N
);
267 procedure Append_Child
268 (Container
: in out Tree
;
270 New_Item
: Element_Type
;
271 Count
: Count_Type
:= 1)
273 First
, Last
: Tree_Node_Access
;
274 Element
: Element_Access
;
277 if Parent
= No_Element
then
278 raise Constraint_Error
with "Parent cursor has no element";
281 if Parent
.Container
/= Container
'Unrestricted_Access then
282 raise Program_Error
with "Parent cursor not in container";
289 if Container
.Busy
> 0 then
291 with "attempt to tamper with cursors (tree is busy)";
294 Element
:= new Element_Type
'(New_Item);
295 First := new Tree_Node_Type'(Parent
=> Parent
.Node
,
301 for J
in Count_Type
'(2) .. Count loop
303 -- Reclaim other nodes if Storage_Error. ???
305 Element := new Element_Type'(New_Item
);
306 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
317 Parent => Parent.Node,
318 Before => null); -- null means "insert at end of list"
320 -- In order for operation Node_Count to complete in O(1) time, we cache
321 -- the count value. Here we increment the total count by the number of
322 -- nodes we just inserted.
324 Container.Count := Container.Count + Count;
331 procedure Assign (Target : in out Tree; Source : Tree) is
332 Source_Count : constant Count_Type := Source.Count;
333 Target_Count : Count_Type;
336 if Target'Address = Source'Address then
340 Target.Clear; -- checks busy bit
342 -- Copy_Children returns the number of nodes that it allocates, but it
343 -- does this by incrementing the count value passed in, so we must
344 -- initialize the count before calling Copy_Children.
348 -- Note that Copy_Children inserts the newly-allocated children into
349 -- their parent list only after the allocation of all the children has
350 -- succeeded. This preserves invariants even if the allocation fails.
352 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
353 pragma Assert (Target_Count = Source_Count);
355 Target.Count := Source_Count;
362 function Child_Count (Parent : Cursor) return Count_Type is
364 if Parent = No_Element then
367 return Child_Count (Parent.Node.Children);
371 function Child_Count (Children : Children_Type) return Count_Type is
373 Node : Tree_Node_Access;
377 Node := Children.First;
378 while Node /= null loop
379 Result := Result + 1;
390 function Child_Depth (Parent, Child : Cursor) return Count_Type is
392 N : Tree_Node_Access;
395 if Parent = No_Element then
396 raise Constraint_Error with "Parent cursor has no element";
399 if Child = No_Element then
400 raise Constraint_Error with "Child cursor has no element";
403 if Parent.Container /= Child.Container then
404 raise Program_Error with "Parent and Child in different containers";
409 while N /= Parent.Node loop
410 Result := Result + 1;
414 raise Program_Error with "Parent is not ancestor of Child";
425 procedure Clear (Container : in out Tree) is
426 Container_Count : Count_Type;
427 Children_Count : Count_Type;
430 if Container.Busy > 0 then
432 with "attempt to tamper with cursors (tree is busy)";
435 -- We first set the container count to 0, in order to preserve
436 -- invariants in case the deallocation fails. (This works because
437 -- Deallocate_Children immediately removes the children from their
438 -- parent, and then does the actual deallocation.)
440 Container_Count := Container.Count;
441 Container.Count := 0;
443 -- Deallocate_Children returns the number of nodes that it deallocates,
444 -- but it does this by incrementing the count value that is passed in,
445 -- so we must first initialize the count return value before calling it.
449 -- See comment above. Deallocate_Children immediately removes the
450 -- children list from their parent node (here, the root of the tree),
451 -- and only after that does it attempt the actual deallocation. So even
452 -- if the deallocation fails, the representation invariants
454 Deallocate_Children (Root_Node (Container), Children_Count);
455 pragma Assert (Children_Count = Container_Count);
458 ------------------------
459 -- Constant_Reference --
460 ------------------------
462 function Constant_Reference
463 (Container : aliased Tree;
464 Position : Cursor) return Constant_Reference_Type
467 if Position.Container = null then
468 raise Constraint_Error with
469 "Position cursor has no element";
472 if Position.Container /= Container'Unrestricted_Access then
473 raise Program_Error with
474 "Position cursor designates wrong container";
477 if Position.Node = Root_Node (Container) then
478 raise Program_Error with "Position cursor designates root";
481 if Position.Node.Element = null then
482 raise Program_Error with "Node has no element";
485 -- Implement Vet for multiway tree???
486 -- pragma Assert (Vet (Position),
487 -- "Position cursor in Constant_Reference is bad");
490 C : Tree renames Position.Container.all;
491 B : Natural renames C.Busy;
492 L : Natural renames C.Lock;
494 return R : constant Constant_Reference_Type :=
495 (Element => Position.Node.Element.all'Access,
497 (Controlled with Container'Unrestricted_Access))
503 end Constant_Reference;
511 Item : Element_Type) return Boolean
514 return Find (Container, Item) /= No_Element;
521 function Copy (Source : Tree) return Tree is
523 return Target : Tree do
525 (Source => Source.Root.Children,
526 Parent => Root_Node (Target),
527 Count => Target.Count);
529 pragma Assert (Target.Count = Source.Count);
537 procedure Copy_Children
538 (Source : Children_Type;
539 Parent : Tree_Node_Access;
540 Count : in out Count_Type)
542 pragma Assert (Parent /= null);
543 pragma Assert (Parent.Children.First = null);
544 pragma Assert (Parent.Children.Last = null);
547 C : Tree_Node_Access;
550 -- We special-case the first allocation, in order to establish the
551 -- representation invariants for type Children_Type.
567 -- The representation invariants for the Children_Type list have been
568 -- established, so we can now copy the remaining children of Source.
575 Target => CC.Last.Next,
578 CC.Last.Next.Prev := CC.Last;
579 CC.Last := CC.Last.Next;
584 -- We add the newly-allocated children to their parent list only after
585 -- the allocation has succeeded, in order to preserve invariants of the
588 Parent.Children := CC;
595 procedure Copy_Subtree
596 (Target : in out Tree;
601 Target_Subtree : Tree_Node_Access;
602 Target_Count : Count_Type;
605 if Parent = No_Element then
606 raise Constraint_Error with "Parent cursor has no element";
609 if Parent.Container /= Target'Unrestricted_Access then
610 raise Program_Error with "Parent cursor not in container";
613 if Before /= No_Element then
614 if Before.Container /= Target'Unrestricted_Access then
615 raise Program_Error with "Before cursor not in container";
618 if Before.Node.Parent /= Parent.Node then
619 raise Constraint_Error with "Before cursor not child of Parent";
623 if Source = No_Element then
627 if Is_Root (Source) then
628 raise Constraint_Error with "Source cursor designates root";
631 -- Copy_Subtree returns a count of the number of nodes that it
632 -- allocates, but it works by incrementing the value that is passed in.
633 -- We must therefore initialize the count value before calling
639 (Source => Source.Node,
640 Parent => Parent.Node,
641 Target => Target_Subtree,
642 Count => Target_Count);
644 pragma Assert (Target_Subtree /= null);
645 pragma Assert (Target_Subtree.Parent = Parent.Node);
646 pragma Assert (Target_Count >= 1);
649 (Subtree => Target_Subtree,
650 Parent => Parent.Node,
651 Before => Before.Node);
653 -- In order for operation Node_Count to complete in O(1) time, we cache
654 -- the count value. Here we increment the total count by the number of
655 -- nodes we just inserted.
657 Target.Count := Target.Count + Target_Count;
660 procedure Copy_Subtree
661 (Source : Tree_Node_Access;
662 Parent : Tree_Node_Access;
663 Target : out Tree_Node_Access;
664 Count : in out Count_Type)
666 E : constant Element_Access := new Element_Type'(Source
.Element
.all);
669 Target
:= new Tree_Node_Type
'(Element => E,
676 (Source => Source.Children,
681 -------------------------
682 -- Deallocate_Children --
683 -------------------------
685 procedure Deallocate_Children
686 (Subtree : Tree_Node_Access;
687 Count : in out Count_Type)
689 pragma Assert (Subtree /= null);
691 CC : Children_Type := Subtree.Children;
692 C : Tree_Node_Access;
695 -- We immediately remove the children from their parent, in order to
696 -- preserve invariants in case the deallocation fails.
698 Subtree.Children := Children_Type'(others => null);
700 while CC
.First
/= null loop
704 Deallocate_Subtree
(C
, Count
);
706 end Deallocate_Children
;
708 ---------------------
709 -- Deallocate_Node --
710 ---------------------
712 procedure Deallocate_Node
(X
: in out Tree_Node_Access
) is
713 procedure Free_Node
is
714 new Ada
.Unchecked_Deallocation
(Tree_Node_Type
, Tree_Node_Access
);
716 -- Start of processing for Deallocate_Node
720 Free_Element
(X
.Element
);
725 ------------------------
726 -- Deallocate_Subtree --
727 ------------------------
729 procedure Deallocate_Subtree
730 (Subtree
: in out Tree_Node_Access
;
731 Count
: in out Count_Type
)
734 Deallocate_Children
(Subtree
, Count
);
735 Deallocate_Node
(Subtree
);
737 end Deallocate_Subtree
;
739 ---------------------
740 -- Delete_Children --
741 ---------------------
743 procedure Delete_Children
744 (Container
: in out Tree
;
750 if Parent
= No_Element
then
751 raise Constraint_Error
with "Parent cursor has no element";
754 if Parent
.Container
/= Container
'Unrestricted_Access then
755 raise Program_Error
with "Parent cursor not in container";
758 if Container
.Busy
> 0 then
760 with "attempt to tamper with cursors (tree is busy)";
763 -- Deallocate_Children returns a count of the number of nodes
764 -- that it deallocates, but it works by incrementing the
765 -- value that is passed in. We must therefore initialize
766 -- the count value before calling Deallocate_Children.
770 Deallocate_Children
(Parent
.Node
, Count
);
771 pragma Assert
(Count
<= Container
.Count
);
773 Container
.Count
:= Container
.Count
- Count
;
780 procedure Delete_Leaf
781 (Container
: in out Tree
;
782 Position
: in out Cursor
)
784 X
: Tree_Node_Access
;
787 if Position
= No_Element
then
788 raise Constraint_Error
with "Position cursor has no element";
791 if Position
.Container
/= Container
'Unrestricted_Access then
792 raise Program_Error
with "Position cursor not in container";
795 if Is_Root
(Position
) then
796 raise Program_Error
with "Position cursor designates root";
799 if not Is_Leaf
(Position
) then
800 raise Constraint_Error
with "Position cursor does not designate leaf";
803 if Container
.Busy
> 0 then
805 with "attempt to tamper with cursors (tree is busy)";
809 Position
:= No_Element
;
811 -- Restore represention invariants before attempting the actual
815 Container
.Count
:= Container
.Count
- 1;
817 -- It is now safe to attempt the deallocation. This leaf node has been
818 -- disassociated from the tree, so even if the deallocation fails,
819 -- representation invariants will remain satisfied.
828 procedure Delete_Subtree
829 (Container
: in out Tree
;
830 Position
: in out Cursor
)
832 X
: Tree_Node_Access
;
836 if Position
= No_Element
then
837 raise Constraint_Error
with "Position cursor has no element";
840 if Position
.Container
/= Container
'Unrestricted_Access then
841 raise Program_Error
with "Position cursor not in container";
844 if Is_Root
(Position
) then
845 raise Program_Error
with "Position cursor designates root";
848 if Container
.Busy
> 0 then
850 with "attempt to tamper with cursors (tree is busy)";
854 Position
:= No_Element
;
856 -- Here is one case where a deallocation failure can result in the
857 -- violation of a representation invariant. We disassociate the subtree
858 -- from the tree now, but we only decrement the total node count after
859 -- we attempt the deallocation. However, if the deallocation fails, the
860 -- total node count will not get decremented.
862 -- One way around this dilemma is to count the nodes in the subtree
863 -- before attempt to delete the subtree, but that is an O(n) operation,
864 -- so it does not seem worth it.
866 -- Perhaps this is much ado about nothing, since the only way
867 -- deallocation can fail is if Controlled Finalization fails: this
868 -- propagates Program_Error so all bets are off anyway. ???
872 -- Deallocate_Subtree returns a count of the number of nodes that it
873 -- deallocates, but it works by incrementing the value that is passed
874 -- in. We must therefore initialize the count value before calling
875 -- Deallocate_Subtree.
879 Deallocate_Subtree
(X
, Count
);
880 pragma Assert
(Count
<= Container
.Count
);
882 -- See comments above. We would prefer to do this sooner, but there's no
883 -- way to satisfy that goal without an potentially severe execution
886 Container
.Count
:= Container
.Count
- Count
;
893 function Depth
(Position
: Cursor
) return Count_Type
is
895 N
: Tree_Node_Access
;
902 Result
:= Result
+ 1;
912 function Element
(Position
: Cursor
) return Element_Type
is
914 if Position
.Container
= null then
915 raise Constraint_Error
with "Position cursor has no element";
918 if Position
.Node
= Root_Node
(Position
.Container
.all) then
919 raise Program_Error
with "Position cursor designates root";
922 return Position
.Node
.Element
.all;
929 function Equal_Children
930 (Left_Subtree
: Tree_Node_Access
;
931 Right_Subtree
: Tree_Node_Access
) return Boolean
933 Left_Children
: Children_Type
renames Left_Subtree
.Children
;
934 Right_Children
: Children_Type
renames Right_Subtree
.Children
;
936 L
, R
: Tree_Node_Access
;
939 if Child_Count
(Left_Children
) /= Child_Count
(Right_Children
) then
943 L
:= Left_Children
.First
;
944 R
:= Right_Children
.First
;
946 if not Equal_Subtree
(L
, R
) then
961 function Equal_Subtree
962 (Left_Position
: Cursor
;
963 Right_Position
: Cursor
) return Boolean
966 if Left_Position
= No_Element
then
967 raise Constraint_Error
with "Left cursor has no element";
970 if Right_Position
= No_Element
then
971 raise Constraint_Error
with "Right cursor has no element";
974 if Left_Position
= Right_Position
then
978 if Is_Root
(Left_Position
) then
979 if not Is_Root
(Right_Position
) then
983 return Equal_Children
(Left_Position
.Node
, Right_Position
.Node
);
986 if Is_Root
(Right_Position
) then
990 return Equal_Subtree
(Left_Position
.Node
, Right_Position
.Node
);
993 function Equal_Subtree
994 (Left_Subtree
: Tree_Node_Access
;
995 Right_Subtree
: Tree_Node_Access
) return Boolean
998 if Left_Subtree
.Element
.all /= Right_Subtree
.Element
.all then
1002 return Equal_Children
(Left_Subtree
, Right_Subtree
);
1009 procedure Finalize
(Object
: in out Root_Iterator
) is
1010 B
: Natural renames Object
.Container
.Busy
;
1015 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1017 if Control
.Container
/= null then
1019 C
: Tree
renames Control
.Container
.all;
1020 B
: Natural renames C
.Busy
;
1021 L
: Natural renames C
.Lock
;
1027 Control
.Container
:= null;
1037 Item
: Element_Type
) return Cursor
1039 N
: constant Tree_Node_Access
:=
1040 Find_In_Children
(Root_Node
(Container
), Item
);
1047 return Cursor
'(Container'Unrestricted_Access, N);
1054 overriding function First (Object : Subtree_Iterator) return Cursor is
1056 if Object.Subtree = Root_Node (Object.Container.all) then
1057 return First_Child (Root (Object.Container.all));
1059 return Cursor'(Object
.Container
, Object
.Subtree
);
1063 overriding
function First
(Object
: Child_Iterator
) return Cursor
is
1065 return First_Child
(Cursor
'(Object.Container, Object.Subtree));
1072 function First_Child (Parent : Cursor) return Cursor is
1073 Node : Tree_Node_Access;
1076 if Parent = No_Element then
1077 raise Constraint_Error with "Parent cursor has no element";
1080 Node := Parent.Node.Children.First;
1086 return Cursor'(Parent
.Container
, Node
);
1089 -------------------------
1090 -- First_Child_Element --
1091 -------------------------
1093 function First_Child_Element
(Parent
: Cursor
) return Element_Type
is
1095 return Element
(First_Child
(Parent
));
1096 end First_Child_Element
;
1098 ----------------------
1099 -- Find_In_Children --
1100 ----------------------
1102 function Find_In_Children
1103 (Subtree
: Tree_Node_Access
;
1104 Item
: Element_Type
) return Tree_Node_Access
1106 N
, Result
: Tree_Node_Access
;
1109 N
:= Subtree
.Children
.First
;
1110 while N
/= null loop
1111 Result
:= Find_In_Subtree
(N
, Item
);
1113 if Result
/= null then
1121 end Find_In_Children
;
1123 ---------------------
1124 -- Find_In_Subtree --
1125 ---------------------
1127 function Find_In_Subtree
1129 Item
: Element_Type
) return Cursor
1131 Result
: Tree_Node_Access
;
1134 if Position
= No_Element
then
1135 raise Constraint_Error
with "Position cursor has no element";
1138 -- Commented-out pending ruling from ARG. ???
1140 -- if Position.Container /= Container'Unrestricted_Access then
1141 -- raise Program_Error with "Position cursor not in container";
1144 if Is_Root
(Position
) then
1145 Result
:= Find_In_Children
(Position
.Node
, Item
);
1148 Result
:= Find_In_Subtree
(Position
.Node
, Item
);
1151 if Result
= null then
1155 return Cursor
'(Position.Container, Result);
1156 end Find_In_Subtree;
1158 function Find_In_Subtree
1159 (Subtree : Tree_Node_Access;
1160 Item : Element_Type) return Tree_Node_Access
1163 if Subtree.Element.all = Item then
1167 return Find_In_Children (Subtree, Item);
1168 end Find_In_Subtree;
1174 function Has_Element (Position : Cursor) return Boolean is
1176 if Position = No_Element then
1180 return Position.Node.Parent /= null;
1187 procedure Insert_Child
1188 (Container : in out Tree;
1191 New_Item : Element_Type;
1192 Count : Count_Type := 1)
1195 pragma Unreferenced (Position);
1198 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1201 procedure Insert_Child
1202 (Container : in out Tree;
1205 New_Item : Element_Type;
1206 Position : out Cursor;
1207 Count : Count_Type := 1)
1209 Last : Tree_Node_Access;
1210 Element : Element_Access;
1213 if Parent = No_Element then
1214 raise Constraint_Error with "Parent cursor has no element";
1217 if Parent.Container /= Container'Unrestricted_Access then
1218 raise Program_Error with "Parent cursor not in container";
1221 if Before /= No_Element then
1222 if Before.Container /= Container'Unrestricted_Access then
1223 raise Program_Error with "Before cursor not in container";
1226 if Before.Node.Parent /= Parent.Node then
1227 raise Constraint_Error with "Parent cursor not parent of Before";
1232 Position := No_Element; -- Need ruling from ARG ???
1236 if Container.Busy > 0 then
1238 with "attempt to tamper with cursors (tree is busy)";
1241 Position.Container := Parent.Container;
1243 Element := new Element_Type'(New_Item
);
1244 Position
.Node
:= new Tree_Node_Type
'(Parent => Parent.Node,
1248 Last := Position.Node;
1250 for J in Count_Type'(2) .. Count
loop
1251 -- Reclaim other nodes if Storage_Error. ???
1253 Element
:= new Element_Type
'(New_Item);
1254 Last.Next := new Tree_Node_Type'(Parent
=> Parent
.Node
,
1263 (First
=> Position
.Node
,
1265 Parent
=> Parent
.Node
,
1266 Before
=> Before
.Node
);
1268 -- In order for operation Node_Count to complete in O(1) time, we cache
1269 -- the count value. Here we increment the total count by the number of
1270 -- nodes we just inserted.
1272 Container
.Count
:= Container
.Count
+ Count
;
1275 -------------------------
1276 -- Insert_Subtree_List --
1277 -------------------------
1279 procedure Insert_Subtree_List
1280 (First
: Tree_Node_Access
;
1281 Last
: Tree_Node_Access
;
1282 Parent
: Tree_Node_Access
;
1283 Before
: Tree_Node_Access
)
1285 pragma Assert
(Parent
/= null);
1286 C
: Children_Type
renames Parent
.Children
;
1289 -- This is a simple utility operation to insert a list of nodes (from
1290 -- First..Last) as children of Parent. The Before node specifies where
1291 -- the new children should be inserted relative to the existing
1294 if First
= null then
1295 pragma Assert
(Last
= null);
1299 pragma Assert
(Last
/= null);
1300 pragma Assert
(Before
= null or else Before
.Parent
= Parent
);
1302 if C
.First
= null then
1304 C
.First
.Prev
:= null;
1306 C
.Last
.Next
:= null;
1308 elsif Before
= null then -- means "insert after existing nodes"
1309 C
.Last
.Next
:= First
;
1310 First
.Prev
:= C
.Last
;
1312 C
.Last
.Next
:= null;
1314 elsif Before
= C
.First
then
1315 Last
.Next
:= C
.First
;
1316 C
.First
.Prev
:= Last
;
1318 C
.First
.Prev
:= null;
1321 Before
.Prev
.Next
:= First
;
1322 First
.Prev
:= Before
.Prev
;
1323 Last
.Next
:= Before
;
1324 Before
.Prev
:= Last
;
1326 end Insert_Subtree_List
;
1328 -------------------------
1329 -- Insert_Subtree_Node --
1330 -------------------------
1332 procedure Insert_Subtree_Node
1333 (Subtree
: Tree_Node_Access
;
1334 Parent
: Tree_Node_Access
;
1335 Before
: Tree_Node_Access
)
1338 -- This is a simple wrapper operation to insert a single child into the
1339 -- Parent's children list.
1346 end Insert_Subtree_Node
;
1352 function Is_Empty
(Container
: Tree
) return Boolean is
1354 return Container
.Root
.Children
.First
= null;
1361 function Is_Leaf
(Position
: Cursor
) return Boolean is
1363 if Position
= No_Element
then
1367 return Position
.Node
.Children
.First
= null;
1374 function Is_Reachable
(From
, To
: Tree_Node_Access
) return Boolean is
1375 pragma Assert
(From
/= null);
1376 pragma Assert
(To
/= null);
1378 N
: Tree_Node_Access
;
1382 while N
/= null loop
1397 function Is_Root
(Position
: Cursor
) return Boolean is
1399 if Position
.Container
= null then
1403 return Position
= Root
(Position
.Container
.all);
1412 Process
: not null access procedure (Position
: Cursor
))
1414 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1420 (Container
=> Container
'Unrestricted_Access,
1421 Subtree
=> Root_Node
(Container
),
1422 Process
=> Process
);
1432 function Iterate
(Container
: Tree
)
1433 return Tree_Iterator_Interfaces
.Forward_Iterator
'Class
1436 return Iterate_Subtree
(Root
(Container
));
1439 ----------------------
1440 -- Iterate_Children --
1441 ----------------------
1443 procedure Iterate_Children
1445 Process
: not null access procedure (Position
: Cursor
))
1448 if Parent
= No_Element
then
1449 raise Constraint_Error
with "Parent cursor has no element";
1453 B
: Natural renames Parent
.Container
.Busy
;
1454 C
: Tree_Node_Access
;
1459 C
:= Parent
.Node
.Children
.First
;
1460 while C
/= null loop
1461 Process
(Position
=> Cursor
'(Parent.Container, Node => C));
1472 end Iterate_Children;
1474 procedure Iterate_Children
1475 (Container : Tree_Access;
1476 Subtree : Tree_Node_Access;
1477 Process : not null access procedure (Position : Cursor))
1479 Node : Tree_Node_Access;
1482 -- This is a helper function to recursively iterate over all the nodes
1483 -- in a subtree, in depth-first fashion. This particular helper just
1484 -- visits the children of this subtree, not the root of the subtree node
1485 -- itself. This is useful when starting from the ultimate root of the
1486 -- entire tree (see Iterate), as that root does not have an element.
1488 Node := Subtree.Children.First;
1489 while Node /= null loop
1490 Iterate_Subtree (Container, Node, Process);
1493 end Iterate_Children;
1495 function Iterate_Children
1498 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1500 C : constant Tree_Access := Container'Unrestricted_Access;
1501 B : Natural renames C.Busy;
1504 if Parent = No_Element then
1505 raise Constraint_Error with "Parent cursor has no element";
1508 if Parent.Container /= C then
1509 raise Program_Error with "Parent cursor not in container";
1512 return It : constant Child_Iterator :=
1513 Child_Iterator'(Limited_Controlled
with
1515 Subtree
=> Parent
.Node
)
1519 end Iterate_Children
;
1521 ---------------------
1522 -- Iterate_Subtree --
1523 ---------------------
1525 function Iterate_Subtree
1527 return Tree_Iterator_Interfaces
.Forward_Iterator
'Class
1530 if Position
= No_Element
then
1531 raise Constraint_Error
with "Position cursor has no element";
1534 -- Implement Vet for multiway trees???
1535 -- pragma Assert (Vet (Position), "bad subtree cursor");
1538 B
: Natural renames Position
.Container
.Busy
;
1540 return It
: constant Subtree_Iterator
:=
1541 (Limited_Controlled
with
1542 Container
=> Position
.Container
,
1543 Subtree
=> Position
.Node
)
1548 end Iterate_Subtree
;
1550 procedure Iterate_Subtree
1552 Process
: not null access procedure (Position
: Cursor
))
1555 if Position
= No_Element
then
1556 raise Constraint_Error
with "Position cursor has no element";
1560 B
: Natural renames Position
.Container
.Busy
;
1565 if Is_Root
(Position
) then
1566 Iterate_Children
(Position
.Container
, Position
.Node
, Process
);
1568 Iterate_Subtree
(Position
.Container
, Position
.Node
, Process
);
1578 end Iterate_Subtree
;
1580 procedure Iterate_Subtree
1581 (Container
: Tree_Access
;
1582 Subtree
: Tree_Node_Access
;
1583 Process
: not null access procedure (Position
: Cursor
))
1586 -- This is a helper function to recursively iterate over all the nodes
1587 -- in a subtree, in depth-first fashion. It first visits the root of the
1588 -- subtree, then visits its children.
1590 Process
(Cursor
'(Container, Subtree));
1591 Iterate_Children (Container, Subtree, Process);
1592 end Iterate_Subtree;
1598 overriding function Last (Object : Child_Iterator) return Cursor is
1600 return Last_Child (Cursor'(Object
.Container
, Object
.Subtree
));
1607 function Last_Child
(Parent
: Cursor
) return Cursor
is
1608 Node
: Tree_Node_Access
;
1611 if Parent
= No_Element
then
1612 raise Constraint_Error
with "Parent cursor has no element";
1615 Node
:= Parent
.Node
.Children
.Last
;
1621 return (Parent
.Container
, Node
);
1624 ------------------------
1625 -- Last_Child_Element --
1626 ------------------------
1628 function Last_Child_Element
(Parent
: Cursor
) return Element_Type
is
1630 return Element
(Last_Child
(Parent
));
1631 end Last_Child_Element
;
1637 procedure Move
(Target
: in out Tree
; Source
: in out Tree
) is
1638 Node
: Tree_Node_Access
;
1641 if Target
'Address = Source
'Address then
1645 if Source
.Busy
> 0 then
1647 with "attempt to tamper with cursors of Source (tree is busy)";
1650 Target
.Clear
; -- checks busy bit
1652 Target
.Root
.Children
:= Source
.Root
.Children
;
1653 Source
.Root
.Children
:= Children_Type
'(others => null);
1655 Node := Target.Root.Children.First;
1656 while Node /= null loop
1657 Node.Parent := Root_Node (Target);
1661 Target.Count := Source.Count;
1670 (Object : Subtree_Iterator;
1671 Position : Cursor) return Cursor
1673 Node : Tree_Node_Access;
1676 if Position.Container = null then
1680 if Position.Container /= Object.Container then
1681 raise Program_Error with
1682 "Position cursor of Next designates wrong tree";
1685 Node := Position.Node;
1687 if Node.Children.First /= null then
1688 return Cursor'(Object
.Container
, Node
.Children
.First
);
1691 while Node
/= Object
.Subtree
loop
1692 if Node
.Next
/= null then
1693 return Cursor
'(Object.Container, Node.Next);
1696 Node := Node.Parent;
1703 (Object : Child_Iterator;
1704 Position : Cursor) return Cursor
1707 if Position.Container = null then
1711 if Position.Container /= Object.Container then
1712 raise Program_Error with
1713 "Position cursor of Next designates wrong tree";
1716 return Next_Sibling (Position);
1723 function Next_Sibling (Position : Cursor) return Cursor is
1725 if Position = No_Element then
1729 if Position.Node.Next = null then
1733 return Cursor'(Position
.Container
, Position
.Node
.Next
);
1736 procedure Next_Sibling
(Position
: in out Cursor
) is
1738 Position
:= Next_Sibling
(Position
);
1745 function Node_Count
(Container
: Tree
) return Count_Type
is
1747 -- Container.Count is the number of nodes we have actually allocated. We
1748 -- cache the value specifically so this Node_Count operation can execute
1749 -- in O(1) time, which makes it behave similarly to how the Length
1750 -- selector function behaves for other containers.
1752 -- The cached node count value only describes the nodes we have
1753 -- allocated; the root node itself is not included in that count. The
1754 -- Node_Count operation returns a value that includes the root node
1755 -- (because the RM says so), so we must add 1 to our cached value.
1757 return 1 + Container
.Count
;
1764 function Parent
(Position
: Cursor
) return Cursor
is
1766 if Position
= No_Element
then
1770 if Position
.Node
.Parent
= null then
1774 return Cursor
'(Position.Container, Position.Node.Parent);
1781 procedure Prepend_Child
1782 (Container : in out Tree;
1784 New_Item : Element_Type;
1785 Count : Count_Type := 1)
1787 First, Last : Tree_Node_Access;
1788 Element : Element_Access;
1791 if Parent = No_Element then
1792 raise Constraint_Error with "Parent cursor has no element";
1795 if Parent.Container /= Container'Unrestricted_Access then
1796 raise Program_Error with "Parent cursor not in container";
1803 if Container.Busy > 0 then
1805 with "attempt to tamper with cursors (tree is busy)";
1808 Element := new Element_Type'(New_Item
);
1809 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
1815 for J in Count_Type'(2) .. Count
loop
1817 -- Reclaim other nodes if Storage_Error. ???
1819 Element
:= new Element_Type
'(New_Item);
1820 Last.Next := new Tree_Node_Type'(Parent
=> Parent
.Node
,
1831 Parent
=> Parent
.Node
,
1832 Before
=> Parent
.Node
.Children
.First
);
1834 -- In order for operation Node_Count to complete in O(1) time, we cache
1835 -- the count value. Here we increment the total count by the number of
1836 -- nodes we just inserted.
1838 Container
.Count
:= Container
.Count
+ Count
;
1845 overriding
function Previous
1846 (Object
: Child_Iterator
;
1847 Position
: Cursor
) return Cursor
1850 if Position
.Container
= null then
1854 if Position
.Container
/= Object
.Container
then
1855 raise Program_Error
with
1856 "Position cursor of Previous designates wrong tree";
1859 return Previous_Sibling
(Position
);
1862 ----------------------
1863 -- Previous_Sibling --
1864 ----------------------
1866 function Previous_Sibling
(Position
: Cursor
) return Cursor
is
1868 if Position
= No_Element
then
1872 if Position
.Node
.Prev
= null then
1876 return Cursor
'(Position.Container, Position.Node.Prev);
1877 end Previous_Sibling;
1879 procedure Previous_Sibling (Position : in out Cursor) is
1881 Position := Previous_Sibling (Position);
1882 end Previous_Sibling;
1888 procedure Query_Element
1890 Process : not null access procedure (Element : Element_Type))
1893 if Position = No_Element then
1894 raise Constraint_Error with "Position cursor has no element";
1897 if Is_Root (Position) then
1898 raise Program_Error with "Position cursor designates root";
1902 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1903 B : Natural renames T.Busy;
1904 L : Natural renames T.Lock;
1910 Process (Position.Node.Element.all);
1928 (Stream : not null access Root_Stream_Type'Class;
1929 Container : out Tree)
1931 procedure Read_Children (Subtree : Tree_Node_Access);
1933 function Read_Subtree
1934 (Parent : Tree_Node_Access) return Tree_Node_Access;
1936 Total_Count : Count_Type'Base;
1937 -- Value read from the stream that says how many elements follow
1939 Read_Count : Count_Type'Base;
1940 -- Actual number of elements read from the stream
1946 procedure Read_Children (Subtree : Tree_Node_Access) is
1947 pragma Assert (Subtree /= null);
1948 pragma Assert (Subtree.Children.First = null);
1949 pragma Assert (Subtree.Children.Last = null);
1951 Count : Count_Type'Base;
1952 -- Number of child subtrees
1957 Count_Type'Read (Stream, Count);
1960 raise Program_Error with "attempt to read from corrupt stream";
1967 C.First := Read_Subtree (Parent => Subtree);
1970 for J in Count_Type'(2) .. Count
loop
1971 C
.Last
.Next
:= Read_Subtree
(Parent
=> Subtree
);
1972 C
.Last
.Next
.Prev
:= C
.Last
;
1973 C
.Last
:= C
.Last
.Next
;
1976 -- Now that the allocation and reads have completed successfully, it
1977 -- is safe to link the children to their parent.
1979 Subtree
.Children
:= C
;
1986 function Read_Subtree
1987 (Parent
: Tree_Node_Access
) return Tree_Node_Access
1989 Element
: constant Element_Access
:=
1990 new Element_Type
'(Element_Type'Input (Stream));
1992 Subtree : constant Tree_Node_Access :=
1999 Read_Count
:= Read_Count
+ 1;
2001 Read_Children
(Subtree
);
2006 -- Start of processing for Read
2009 Container
.Clear
; -- checks busy bit
2011 Count_Type
'Read (Stream
, Total_Count
);
2013 if Total_Count
< 0 then
2014 raise Program_Error
with "attempt to read from corrupt stream";
2017 if Total_Count
= 0 then
2023 Read_Children
(Root_Node
(Container
));
2025 if Read_Count
/= Total_Count
then
2026 raise Program_Error
with "attempt to read from corrupt stream";
2029 Container
.Count
:= Total_Count
;
2033 (Stream
: not null access Root_Stream_Type
'Class;
2034 Position
: out Cursor
)
2037 raise Program_Error
with "attempt to read tree cursor from stream";
2041 (Stream
: not null access Root_Stream_Type
'Class;
2042 Item
: out Reference_Type
)
2045 raise Program_Error
with "attempt to stream reference";
2049 (Stream
: not null access Root_Stream_Type
'Class;
2050 Item
: out Constant_Reference_Type
)
2053 raise Program_Error
with "attempt to stream reference";
2061 (Container
: aliased in out Tree
;
2062 Position
: Cursor
) return Reference_Type
2065 if Position
.Container
= null then
2066 raise Constraint_Error
with
2067 "Position cursor has no element";
2070 if Position
.Container
/= Container
'Unrestricted_Access then
2071 raise Program_Error
with
2072 "Position cursor designates wrong container";
2075 if Position
.Node
= Root_Node
(Container
) then
2076 raise Program_Error
with "Position cursor designates root";
2079 if Position
.Node
.Element
= null then
2080 raise Program_Error
with "Node has no element";
2083 -- Implement Vet for multiway tree???
2084 -- pragma Assert (Vet (Position),
2085 -- "Position cursor in Constant_Reference is bad");
2088 C
: Tree
renames Position
.Container
.all;
2089 B
: Natural renames C
.Busy
;
2090 L
: Natural renames C
.Lock
;
2092 return R
: constant Reference_Type
:=
2093 (Element
=> Position
.Node
.Element
.all'Access,
2094 Control
=> (Controlled
with Position
.Container
))
2102 --------------------
2103 -- Remove_Subtree --
2104 --------------------
2106 procedure Remove_Subtree
(Subtree
: Tree_Node_Access
) is
2107 C
: Children_Type
renames Subtree
.Parent
.Children
;
2110 -- This is a utility operation to remove a subtree node from its
2111 -- parent's list of children.
2113 if C
.First
= Subtree
then
2114 pragma Assert
(Subtree
.Prev
= null);
2116 if C
.Last
= Subtree
then
2117 pragma Assert
(Subtree
.Next
= null);
2122 C
.First
:= Subtree
.Next
;
2123 C
.First
.Prev
:= null;
2126 elsif C
.Last
= Subtree
then
2127 pragma Assert
(Subtree
.Next
= null);
2128 C
.Last
:= Subtree
.Prev
;
2129 C
.Last
.Next
:= null;
2132 Subtree
.Prev
.Next
:= Subtree
.Next
;
2133 Subtree
.Next
.Prev
:= Subtree
.Prev
;
2137 ----------------------
2138 -- Replace_Element --
2139 ----------------------
2141 procedure Replace_Element
2142 (Container
: in out Tree
;
2144 New_Item
: Element_Type
)
2146 E
, X
: Element_Access
;
2149 if Position
= No_Element
then
2150 raise Constraint_Error
with "Position cursor has no element";
2153 if Position
.Container
/= Container
'Unrestricted_Access then
2154 raise Program_Error
with "Position cursor not in container";
2157 if Is_Root
(Position
) then
2158 raise Program_Error
with "Position cursor designates root";
2161 if Container
.Lock
> 0 then
2163 with "attempt to tamper with elements (tree is locked)";
2166 E
:= new Element_Type
'(New_Item);
2168 X := Position.Node.Element;
2169 Position.Node.Element := E;
2172 end Replace_Element;
2174 ------------------------------
2175 -- Reverse_Iterate_Children --
2176 ------------------------------
2178 procedure Reverse_Iterate_Children
2180 Process : not null access procedure (Position : Cursor))
2183 if Parent = No_Element then
2184 raise Constraint_Error with "Parent cursor has no element";
2188 B : Natural renames Parent.Container.Busy;
2189 C : Tree_Node_Access;
2194 C := Parent.Node.Children.Last;
2195 while C /= null loop
2196 Process (Position => Cursor'(Parent
.Container
, Node
=> C
));
2207 end Reverse_Iterate_Children
;
2213 function Root
(Container
: Tree
) return Cursor
is
2215 return (Container
'Unrestricted_Access, Root_Node
(Container
));
2222 function Root_Node
(Container
: Tree
) return Tree_Node_Access
is
2224 return Container
.Root
'Unrestricted_Access;
2227 ---------------------
2228 -- Splice_Children --
2229 ---------------------
2231 procedure Splice_Children
2232 (Target
: in out Tree
;
2233 Target_Parent
: Cursor
;
2235 Source
: in out Tree
;
2236 Source_Parent
: Cursor
)
2241 if Target_Parent
= No_Element
then
2242 raise Constraint_Error
with "Target_Parent cursor has no element";
2245 if Target_Parent
.Container
/= Target
'Unrestricted_Access then
2247 with "Target_Parent cursor not in Target container";
2250 if Before
/= No_Element
then
2251 if Before
.Container
/= Target
'Unrestricted_Access then
2253 with "Before cursor not in Target container";
2256 if Before
.Node
.Parent
/= Target_Parent
.Node
then
2257 raise Constraint_Error
2258 with "Before cursor not child of Target_Parent";
2262 if Source_Parent
= No_Element
then
2263 raise Constraint_Error
with "Source_Parent cursor has no element";
2266 if Source_Parent
.Container
/= Source
'Unrestricted_Access then
2268 with "Source_Parent cursor not in Source container";
2271 if Target
'Address = Source
'Address then
2272 if Target_Parent
= Source_Parent
then
2276 if Target
.Busy
> 0 then
2278 with "attempt to tamper with cursors (Target tree is busy)";
2281 if Is_Reachable
(From
=> Target_Parent
.Node
,
2282 To
=> Source_Parent
.Node
)
2284 raise Constraint_Error
2285 with "Source_Parent is ancestor of Target_Parent";
2289 (Target_Parent
=> Target_Parent
.Node
,
2290 Before
=> Before
.Node
,
2291 Source_Parent
=> Source_Parent
.Node
);
2296 if Target
.Busy
> 0 then
2298 with "attempt to tamper with cursors (Target tree is busy)";
2301 if Source
.Busy
> 0 then
2303 with "attempt to tamper with cursors (Source tree is busy)";
2306 -- We cache the count of the nodes we have allocated, so that operation
2307 -- Node_Count can execute in O(1) time. But that means we must count the
2308 -- nodes in the subtree we remove from Source and insert into Target, in
2309 -- order to keep the count accurate.
2311 Count
:= Subtree_Node_Count
(Source_Parent
.Node
);
2312 pragma Assert
(Count
>= 1);
2314 Count
:= Count
- 1; -- because Source_Parent node does not move
2317 (Target_Parent
=> Target_Parent
.Node
,
2318 Before
=> Before
.Node
,
2319 Source_Parent
=> Source_Parent
.Node
);
2321 Source
.Count
:= Source
.Count
- Count
;
2322 Target
.Count
:= Target
.Count
+ Count
;
2323 end Splice_Children
;
2325 procedure Splice_Children
2326 (Container
: in out Tree
;
2327 Target_Parent
: Cursor
;
2329 Source_Parent
: Cursor
)
2332 if Target_Parent
= No_Element
then
2333 raise Constraint_Error
with "Target_Parent cursor has no element";
2336 if Target_Parent
.Container
/= Container
'Unrestricted_Access then
2338 with "Target_Parent cursor not in container";
2341 if Before
/= No_Element
then
2342 if Before
.Container
/= Container
'Unrestricted_Access then
2344 with "Before cursor not in container";
2347 if Before
.Node
.Parent
/= Target_Parent
.Node
then
2348 raise Constraint_Error
2349 with "Before cursor not child of Target_Parent";
2353 if Source_Parent
= No_Element
then
2354 raise Constraint_Error
with "Source_Parent cursor has no element";
2357 if Source_Parent
.Container
/= Container
'Unrestricted_Access then
2359 with "Source_Parent cursor not in container";
2362 if Target_Parent
= Source_Parent
then
2366 if Container
.Busy
> 0 then
2368 with "attempt to tamper with cursors (tree is busy)";
2371 if Is_Reachable
(From
=> Target_Parent
.Node
,
2372 To
=> Source_Parent
.Node
)
2374 raise Constraint_Error
2375 with "Source_Parent is ancestor of Target_Parent";
2379 (Target_Parent
=> Target_Parent
.Node
,
2380 Before
=> Before
.Node
,
2381 Source_Parent
=> Source_Parent
.Node
);
2382 end Splice_Children
;
2384 procedure Splice_Children
2385 (Target_Parent
: Tree_Node_Access
;
2386 Before
: Tree_Node_Access
;
2387 Source_Parent
: Tree_Node_Access
)
2389 CC
: constant Children_Type
:= Source_Parent
.Children
;
2390 C
: Tree_Node_Access
;
2393 -- This is a utility operation to remove the children from Source parent
2394 -- and insert them into Target parent.
2396 Source_Parent
.Children
:= Children_Type
'(others => null);
2398 -- Fix up the Parent pointers of each child to designate its new Target
2402 while C /= null loop
2403 C.Parent := Target_Parent;
2410 Parent => Target_Parent,
2412 end Splice_Children;
2414 --------------------
2415 -- Splice_Subtree --
2416 --------------------
2418 procedure Splice_Subtree
2419 (Target : in out Tree;
2422 Source : in out Tree;
2423 Position : in out Cursor)
2425 Subtree_Count : Count_Type;
2428 if Parent = No_Element then
2429 raise Constraint_Error with "Parent cursor has no element";
2432 if Parent.Container /= Target'Unrestricted_Access then
2433 raise Program_Error with "Parent cursor not in Target container";
2436 if Before /= No_Element then
2437 if Before.Container /= Target'Unrestricted_Access then
2438 raise Program_Error with "Before cursor not in Target container";
2441 if Before.Node.Parent /= Parent.Node then
2442 raise Constraint_Error with "Before cursor not child of Parent";
2446 if Position = No_Element then
2447 raise Constraint_Error with "Position cursor has no element";
2450 if Position.Container /= Source'Unrestricted_Access then
2451 raise Program_Error with "Position cursor not in Source container";
2454 if Is_Root (Position) then
2455 raise Program_Error with "Position cursor designates root";
2458 if Target'Address = Source'Address then
2459 if Position.Node.Parent = Parent.Node then
2460 if Position.Node = Before.Node then
2464 if Position.Node.Next = Before.Node then
2469 if Target.Busy > 0 then
2471 with "attempt to tamper with cursors (Target tree is busy)";
2474 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2475 raise Constraint_Error with "Position is ancestor of Parent";
2478 Remove_Subtree (Position.Node);
2480 Position.Node.Parent := Parent.Node;
2481 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2486 if Target.Busy > 0 then
2488 with "attempt to tamper with cursors (Target tree is busy)";
2491 if Source.Busy > 0 then
2493 with "attempt to tamper with cursors (Source tree is busy)";
2496 -- This is an unfortunate feature of this API: we must count the nodes
2497 -- in the subtree that we remove from the source tree, which is an O(n)
2498 -- operation. It would have been better if the Tree container did not
2499 -- have a Node_Count selector; a user that wants the number of nodes in
2500 -- the tree could simply call Subtree_Node_Count, with the understanding
2501 -- that such an operation is O(n).
2503 -- Of course, we could choose to implement the Node_Count selector as an
2504 -- O(n) operation, which would turn this splice operation into an O(1)
2507 Subtree_Count := Subtree_Node_Count (Position.Node);
2508 pragma Assert (Subtree_Count <= Source.Count);
2510 Remove_Subtree (Position.Node);
2511 Source.Count := Source.Count - Subtree_Count;
2513 Position.Node.Parent := Parent.Node;
2514 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2516 Target.Count := Target.Count + Subtree_Count;
2518 Position.Container := Target'Unrestricted_Access;
2521 procedure Splice_Subtree
2522 (Container : in out Tree;
2528 if Parent = No_Element then
2529 raise Constraint_Error with "Parent cursor has no element";
2532 if Parent.Container /= Container'Unrestricted_Access then
2533 raise Program_Error with "Parent cursor not in container";
2536 if Before /= No_Element then
2537 if Before.Container /= Container'Unrestricted_Access then
2538 raise Program_Error with "Before cursor not in container";
2541 if Before.Node.Parent /= Parent.Node then
2542 raise Constraint_Error with "Before cursor not child of Parent";
2546 if Position = No_Element then
2547 raise Constraint_Error with "Position cursor has no element";
2550 if Position.Container /= Container'Unrestricted_Access then
2551 raise Program_Error with "Position cursor not in container";
2554 if Is_Root (Position) then
2556 -- Should this be PE instead? Need ARG confirmation. ???
2558 raise Constraint_Error with "Position cursor designates root";
2561 if Position.Node.Parent = Parent.Node then
2562 if Position.Node = Before.Node then
2566 if Position.Node.Next = Before.Node then
2571 if Container.Busy > 0 then
2573 with "attempt to tamper with cursors (tree is busy)";
2576 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2577 raise Constraint_Error with "Position is ancestor of Parent";
2580 Remove_Subtree (Position.Node);
2582 Position.Node.Parent := Parent.Node;
2583 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2586 ------------------------
2587 -- Subtree_Node_Count --
2588 ------------------------
2590 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2592 if Position = No_Element then
2596 return Subtree_Node_Count (Position.Node);
2597 end Subtree_Node_Count;
2599 function Subtree_Node_Count
2600 (Subtree : Tree_Node_Access) return Count_Type
2602 Result : Count_Type;
2603 Node : Tree_Node_Access;
2607 Node := Subtree.Children.First;
2608 while Node /= null loop
2609 Result := Result + Subtree_Node_Count (Node);
2614 end Subtree_Node_Count;
2621 (Container : in out Tree;
2625 if I = No_Element then
2626 raise Constraint_Error with "I cursor has no element";
2629 if I.Container /= Container'Unrestricted_Access then
2630 raise Program_Error with "I cursor not in container";
2634 raise Program_Error with "I cursor designates root";
2637 if I = J then -- make this test sooner???
2641 if J = No_Element then
2642 raise Constraint_Error with "J cursor has no element";
2645 if J.Container /= Container'Unrestricted_Access then
2646 raise Program_Error with "J cursor not in container";
2650 raise Program_Error with "J cursor designates root";
2653 if Container.Lock > 0 then
2655 with "attempt to tamper with elements (tree is locked)";
2659 EI : constant Element_Access := I.Node.Element;
2662 I.Node.Element := J.Node.Element;
2663 J.Node.Element := EI;
2667 --------------------
2668 -- Update_Element --
2669 --------------------
2671 procedure Update_Element
2672 (Container : in out Tree;
2674 Process : not null access procedure (Element : in out Element_Type))
2677 if Position = No_Element then
2678 raise Constraint_Error with "Position cursor has no element";
2681 if Position.Container /= Container'Unrestricted_Access then
2682 raise Program_Error with "Position cursor not in container";
2685 if Is_Root (Position) then
2686 raise Program_Error with "Position cursor designates root";
2690 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2691 B : Natural renames T.Busy;
2692 L : Natural renames T.Lock;
2698 Process (Position.Node.Element.all);
2716 (Stream : not null access Root_Stream_Type'Class;
2719 procedure Write_Children (Subtree : Tree_Node_Access);
2720 procedure Write_Subtree (Subtree : Tree_Node_Access);
2722 --------------------
2723 -- Write_Children --
2724 --------------------
2726 procedure Write_Children (Subtree : Tree_Node_Access) is
2727 CC : Children_Type renames Subtree.Children;
2728 C : Tree_Node_Access;
2731 Count_Type'Write (Stream, Child_Count (CC));
2734 while C /= null loop
2744 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2746 Element_Type'Output (Stream, Subtree.Element.all);
2747 Write_Children (Subtree);
2750 -- Start of processing for Write
2753 Count_Type'Write (Stream, Container.Count);
2755 if Container.Count = 0 then
2759 Write_Children (Root_Node (Container));
2763 (Stream : not null access Root_Stream_Type'Class;
2767 raise Program_Error with "attempt to write tree cursor to stream";
2771 (Stream : not null access Root_Stream_Type'Class;
2772 Item : Reference_Type)
2775 raise Program_Error with "attempt to stream reference";
2779 (Stream : not null access Root_Stream_Type'Class;
2780 Item : Constant_Reference_Type)
2783 raise Program_Error with "attempt to stream reference";
2786 end Ada.Containers.Indefinite_Multiway_Trees;