1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
9 -- Copyright (C) 2004-2023, 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
;
33 with System
.Put_Images
;
35 package body Ada
.Containers
.Indefinite_Multiway_Trees
with
39 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
40 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
41 -- See comment in Ada.Containers.Helpers
47 type Root_Iterator
is abstract new Limited_Controlled
and
48 Tree_Iterator_Interfaces
.Forward_Iterator
with
50 Container
: Tree_Access
;
51 Subtree
: Tree_Node_Access
;
54 overriding
procedure Finalize
(Object
: in out Root_Iterator
);
56 -----------------------
57 -- Subtree_Iterator --
58 -----------------------
60 type Subtree_Iterator
is new Root_Iterator
with null record;
62 overriding
function First
(Object
: Subtree_Iterator
) return Cursor
;
64 overriding
function Next
65 (Object
: Subtree_Iterator
;
66 Position
: Cursor
) return Cursor
;
72 type Child_Iterator
is new Root_Iterator
and
73 Tree_Iterator_Interfaces
.Reversible_Iterator
with null record;
75 overriding
function First
(Object
: Child_Iterator
) return Cursor
;
77 overriding
function Next
78 (Object
: Child_Iterator
;
79 Position
: Cursor
) return Cursor
;
81 overriding
function Last
(Object
: Child_Iterator
) return Cursor
;
83 overriding
function Previous
84 (Object
: Child_Iterator
;
85 Position
: Cursor
) return Cursor
;
87 -----------------------
88 -- Local Subprograms --
89 -----------------------
91 function Root_Node
(Container
: Tree
) return Tree_Node_Access
;
93 procedure Free_Element
is
94 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
96 procedure Deallocate_Node
(X
: in out Tree_Node_Access
);
98 procedure Deallocate_Children
99 (Subtree
: Tree_Node_Access
;
100 Count
: in out Count_Type
);
102 procedure Deallocate_Subtree
103 (Subtree
: in out Tree_Node_Access
;
104 Count
: in out Count_Type
);
106 function Equal_Children
107 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
109 function Equal_Subtree
110 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
112 procedure Iterate_Children
113 (Container
: Tree_Access
;
114 Subtree
: Tree_Node_Access
;
115 Process
: not null access procedure (Position
: Cursor
));
117 procedure Iterate_Subtree
118 (Container
: Tree_Access
;
119 Subtree
: Tree_Node_Access
;
120 Process
: not null access procedure (Position
: Cursor
));
122 procedure Copy_Children
123 (Source
: Children_Type
;
124 Parent
: Tree_Node_Access
;
125 Count
: in out Count_Type
);
127 procedure Copy_Subtree
128 (Source
: Tree_Node_Access
;
129 Parent
: Tree_Node_Access
;
130 Target
: out Tree_Node_Access
;
131 Count
: in out Count_Type
);
133 function Find_In_Children
134 (Subtree
: Tree_Node_Access
;
135 Item
: Element_Type
) return Tree_Node_Access
;
137 function Find_In_Subtree
138 (Subtree
: Tree_Node_Access
;
139 Item
: Element_Type
) return Tree_Node_Access
;
141 function Child_Count
(Children
: Children_Type
) return Count_Type
;
143 function Subtree_Node_Count
144 (Subtree
: Tree_Node_Access
) return Count_Type
;
146 function Is_Reachable
(From
, To
: Tree_Node_Access
) return Boolean;
148 procedure Remove_Subtree
(Subtree
: Tree_Node_Access
);
150 procedure Insert_Subtree_Node
151 (Subtree
: Tree_Node_Access
;
152 Parent
: Tree_Node_Access
;
153 Before
: Tree_Node_Access
);
155 procedure Insert_Subtree_List
156 (First
: Tree_Node_Access
;
157 Last
: Tree_Node_Access
;
158 Parent
: Tree_Node_Access
;
159 Before
: Tree_Node_Access
);
161 procedure Splice_Children
162 (Target_Parent
: Tree_Node_Access
;
163 Before
: Tree_Node_Access
;
164 Source_Parent
: Tree_Node_Access
);
170 function "=" (Left
, Right
: Tree
) return Boolean is
172 return Equal_Children
(Root_Node
(Left
), Root_Node
(Right
));
179 procedure Adjust
(Container
: in out Tree
) is
180 Source
: constant Children_Type
:= Container
.Root
.Children
;
181 Source_Count
: constant Count_Type
:= Container
.Count
;
182 Target_Count
: Count_Type
;
185 -- We first restore the target container to its default-initialized
186 -- state, before we attempt any allocation, to ensure that invariants
187 -- are preserved in the event that the allocation fails.
189 Container
.Root
.Children
:= Children_Type
'(others => null);
190 Zero_Counts (Container.TC);
191 Container.Count := 0;
193 -- Copy_Children returns a count of the number of nodes that it
194 -- allocates, but it works by incrementing the value that is passed in.
195 -- We must therefore initialize the count value before calling
200 -- Now we attempt the allocation of subtrees. The invariants are
201 -- satisfied even if the allocation fails.
203 Copy_Children (Source, Root_Node (Container), Target_Count);
204 pragma Assert (Target_Count = Source_Count);
206 Container.Count := Source_Count;
213 function Ancestor_Find
215 Item : Element_Type) return Cursor
217 R, N : Tree_Node_Access;
220 if Checks and then Position = No_Element then
221 raise Constraint_Error with "Position cursor has no element";
224 -- Commented-out pending ARG ruling. ???
226 -- if Checks and then
227 -- Position.Container /= Container'Unrestricted_Access
229 -- raise Program_Error with "Position cursor not in container";
232 -- AI-0136 says to raise PE if Position equals the root node. This does
233 -- not seem correct, as this value is just the limiting condition of the
234 -- search. For now we omit this check pending a ruling from the ARG.???
236 -- if Checks and then Is_Root (Position) then
237 -- raise Program_Error with "Position cursor designates root";
240 R := Root_Node (Position.Container.all);
243 if N.Element.all = Item then
244 return Cursor'(Position
.Container
, N
);
257 procedure Append_Child
258 (Container
: in out Tree
;
260 New_Item
: Element_Type
;
261 Count
: Count_Type
:= 1)
263 First
, Last
: Tree_Node_Access
;
264 Element
: Element_Access
;
267 TC_Check
(Container
.TC
);
269 if Checks
and then Parent
= No_Element
then
270 raise Constraint_Error
with "Parent cursor has no element";
273 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
274 raise Program_Error
with "Parent cursor not in container";
282 -- The element allocator may need an accessibility check in the case
283 -- the actual type is class-wide or has access discriminants (see
284 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
285 -- allocator in the loop below, because the one in this block would
286 -- have failed already.
288 pragma Unsuppress
(Accessibility_Check
);
291 Element
:= new Element_Type
'(New_Item);
294 First := new Tree_Node_Type'(Parent
=> Parent
.Node
,
300 for J
in Count_Type
'(2) .. Count loop
302 -- Reclaim other nodes if Storage_Error. ???
304 Element := new Element_Type'(New_Item
);
305 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
316 Parent => Parent.Node,
317 Before => null); -- null means "insert at end of list"
319 -- In order for operation Node_Count to complete in O(1) time, we cache
320 -- the count value. Here we increment the total count by the number of
321 -- nodes we just inserted.
323 Container.Count := Container.Count + Count;
330 procedure Assign (Target : in out Tree; Source : Tree) is
331 Source_Count : constant Count_Type := Source.Count;
332 Target_Count : Count_Type;
335 if Target'Address = Source'Address then
339 Target.Clear; -- checks busy bit
341 -- Copy_Children returns the number of nodes that it allocates, but it
342 -- does this by incrementing the count value passed in, so we must
343 -- initialize the count before calling Copy_Children.
347 -- Note that Copy_Children inserts the newly-allocated children into
348 -- their parent list only after the allocation of all the children has
349 -- succeeded. This preserves invariants even if the allocation fails.
351 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
352 pragma Assert (Target_Count = Source_Count);
354 Target.Count := Source_Count;
361 function Child_Count (Parent : Cursor) return Count_Type is
363 if Parent = No_Element then
366 return Child_Count (Parent.Node.Children);
370 function Child_Count (Children : Children_Type) return Count_Type is
372 Node : Tree_Node_Access;
376 Node := Children.First;
377 while Node /= null loop
378 Result := Result + 1;
389 function Child_Depth (Parent, Child : Cursor) return Count_Type is
391 N : Tree_Node_Access;
394 if Checks and then Parent = No_Element then
395 raise Constraint_Error with "Parent cursor has no element";
398 if Checks and then Child = No_Element then
399 raise Constraint_Error with "Child cursor has no element";
402 if Checks and then Parent.Container /= Child.Container then
403 raise Program_Error with "Parent and Child in different containers";
408 while N /= Parent.Node loop
409 Result := Result + 1;
412 if Checks and then N = null then
413 raise Program_Error with "Parent is not ancestor of Child";
424 procedure Clear (Container : in out Tree) is
425 Container_Count : Count_Type;
426 Children_Count : Count_Type;
429 TC_Check (Container.TC);
431 -- We first set the container count to 0, in order to preserve
432 -- invariants in case the deallocation fails. (This works because
433 -- Deallocate_Children immediately removes the children from their
434 -- parent, and then does the actual deallocation.)
436 Container_Count := Container.Count;
437 Container.Count := 0;
439 -- Deallocate_Children returns the number of nodes that it deallocates,
440 -- but it does this by incrementing the count value that is passed in,
441 -- so we must first initialize the count return value before calling it.
445 -- See comment above. Deallocate_Children immediately removes the
446 -- children list from their parent node (here, the root of the tree),
447 -- and only after that does it attempt the actual deallocation. So even
448 -- if the deallocation fails, the representation invariants
450 Deallocate_Children (Root_Node (Container), Children_Count);
451 pragma Assert (Children_Count = Container_Count);
454 ------------------------
455 -- Constant_Reference --
456 ------------------------
458 function Constant_Reference
459 (Container : aliased Tree;
460 Position : Cursor) return Constant_Reference_Type
463 if Checks and then Position.Container = null then
464 raise Constraint_Error with
465 "Position cursor has no element";
468 if Checks and then Position.Container /= Container'Unrestricted_Access
470 raise Program_Error with
471 "Position cursor designates wrong container";
474 if Checks and then Position.Node = Root_Node (Container) then
475 raise Program_Error with "Position cursor designates root";
478 if Checks and then Position.Node.Element = null then
479 raise Program_Error with "Node has no element";
482 -- Implement Vet for multiway tree???
483 -- pragma Assert (Vet (Position),
484 -- "Position cursor in Constant_Reference is bad");
487 TC : constant Tamper_Counts_Access :=
488 Container.TC'Unrestricted_Access;
490 return R : constant Constant_Reference_Type :=
491 (Element => Position.Node.Element.all'Access,
492 Control => (Controlled with TC))
497 end Constant_Reference;
505 Item : Element_Type) return Boolean
508 return Find (Container, Item) /= No_Element;
515 function Copy (Source : Tree) return Tree is
517 return Target : Tree do
519 (Source => Source.Root.Children,
520 Parent => Root_Node (Target),
521 Count => Target.Count);
523 pragma Assert (Target.Count = Source.Count);
531 procedure Copy_Children
532 (Source : Children_Type;
533 Parent : Tree_Node_Access;
534 Count : in out Count_Type)
536 pragma Assert (Parent /= null);
537 pragma Assert (Parent.Children.First = null);
538 pragma Assert (Parent.Children.Last = null);
541 C : Tree_Node_Access;
544 -- We special-case the first allocation, in order to establish the
545 -- representation invariants for type Children_Type.
561 -- The representation invariants for the Children_Type list have been
562 -- established, so we can now copy the remaining children of Source.
569 Target => CC.Last.Next,
572 CC.Last.Next.Prev := CC.Last;
573 CC.Last := CC.Last.Next;
578 -- We add the newly-allocated children to their parent list only after
579 -- the allocation has succeeded, in order to preserve invariants of the
582 Parent.Children := CC;
589 procedure Copy_Subtree
590 (Target : in out Tree;
595 Target_Subtree : Tree_Node_Access;
596 Target_Count : Count_Type;
599 if Checks and then Parent = No_Element then
600 raise Constraint_Error with "Parent cursor has no element";
603 if Checks and then Parent.Container /= Target'Unrestricted_Access then
604 raise Program_Error with "Parent cursor not in container";
607 if Before /= No_Element then
608 if Checks and then Before.Container /= Target'Unrestricted_Access then
609 raise Program_Error with "Before cursor not in container";
612 if Checks and then Before.Node.Parent /= Parent.Node then
613 raise Constraint_Error with "Before cursor not child of Parent";
617 if Source = No_Element then
621 if Checks and then Is_Root (Source) then
622 raise Constraint_Error with "Source cursor designates root";
625 -- Copy_Subtree returns a count of the number of nodes that it
626 -- allocates, but it works by incrementing the value that is passed in.
627 -- We must therefore initialize the count value before calling
633 (Source => Source.Node,
634 Parent => Parent.Node,
635 Target => Target_Subtree,
636 Count => Target_Count);
638 pragma Assert (Target_Subtree /= null);
639 pragma Assert (Target_Subtree.Parent = Parent.Node);
640 pragma Assert (Target_Count >= 1);
643 (Subtree => Target_Subtree,
644 Parent => Parent.Node,
645 Before => Before.Node);
647 -- In order for operation Node_Count to complete in O(1) time, we cache
648 -- the count value. Here we increment the total count by the number of
649 -- nodes we just inserted.
651 Target.Count := Target.Count + Target_Count;
654 procedure Copy_Subtree
655 (Source : Tree_Node_Access;
656 Parent : Tree_Node_Access;
657 Target : out Tree_Node_Access;
658 Count : in out Count_Type)
660 E : constant Element_Access := new Element_Type'(Source
.Element
.all);
663 Target
:= new Tree_Node_Type
'(Element => E,
670 (Source => Source.Children,
675 -------------------------
676 -- Deallocate_Children --
677 -------------------------
679 procedure Deallocate_Children
680 (Subtree : Tree_Node_Access;
681 Count : in out Count_Type)
683 pragma Assert (Subtree /= null);
685 CC : Children_Type := Subtree.Children;
686 C : Tree_Node_Access;
689 -- We immediately remove the children from their parent, in order to
690 -- preserve invariants in case the deallocation fails.
692 Subtree.Children := Children_Type'(others => null);
694 while CC
.First
/= null loop
698 Deallocate_Subtree
(C
, Count
);
700 end Deallocate_Children
;
702 ---------------------
703 -- Deallocate_Node --
704 ---------------------
706 procedure Deallocate_Node
(X
: in out Tree_Node_Access
) is
707 procedure Free_Node
is
708 new Ada
.Unchecked_Deallocation
(Tree_Node_Type
, Tree_Node_Access
);
710 -- Start of processing for Deallocate_Node
714 Free_Element
(X
.Element
);
719 ------------------------
720 -- Deallocate_Subtree --
721 ------------------------
723 procedure Deallocate_Subtree
724 (Subtree
: in out Tree_Node_Access
;
725 Count
: in out Count_Type
)
728 Deallocate_Children
(Subtree
, Count
);
729 Deallocate_Node
(Subtree
);
731 end Deallocate_Subtree
;
733 ---------------------
734 -- Delete_Children --
735 ---------------------
737 procedure Delete_Children
738 (Container
: in out Tree
;
744 TC_Check
(Container
.TC
);
746 if Checks
and then Parent
= No_Element
then
747 raise Constraint_Error
with "Parent cursor has no element";
750 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
751 raise Program_Error
with "Parent cursor not in container";
754 -- Deallocate_Children returns a count of the number of nodes
755 -- that it deallocates, but it works by incrementing the
756 -- value that is passed in. We must therefore initialize
757 -- the count value before calling Deallocate_Children.
761 Deallocate_Children
(Parent
.Node
, Count
);
762 pragma Assert
(Count
<= Container
.Count
);
764 Container
.Count
:= Container
.Count
- Count
;
771 procedure Delete_Leaf
772 (Container
: in out Tree
;
773 Position
: in out Cursor
)
775 X
: Tree_Node_Access
;
778 TC_Check
(Container
.TC
);
780 if Checks
and then Position
= No_Element
then
781 raise Constraint_Error
with "Position cursor has no element";
784 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
786 raise Program_Error
with "Position cursor not in container";
789 if Checks
and then Is_Root
(Position
) then
790 raise Program_Error
with "Position cursor designates root";
793 if Checks
and then not Is_Leaf
(Position
) then
794 raise Constraint_Error
with "Position cursor does not designate leaf";
798 Position
:= No_Element
;
800 -- Restore represention invariants before attempting the actual
804 Container
.Count
:= Container
.Count
- 1;
806 -- It is now safe to attempt the deallocation. This leaf node has been
807 -- disassociated from the tree, so even if the deallocation fails,
808 -- representation invariants will remain satisfied.
817 procedure Delete_Subtree
818 (Container
: in out Tree
;
819 Position
: in out Cursor
)
821 X
: Tree_Node_Access
;
825 TC_Check
(Container
.TC
);
827 if Checks
and then Position
= No_Element
then
828 raise Constraint_Error
with "Position cursor has no element";
831 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
833 raise Program_Error
with "Position cursor not in container";
836 if Checks
and then Is_Root
(Position
) then
837 raise Program_Error
with "Position cursor designates root";
841 Position
:= No_Element
;
843 -- Here is one case where a deallocation failure can result in the
844 -- violation of a representation invariant. We disassociate the subtree
845 -- from the tree now, but we only decrement the total node count after
846 -- we attempt the deallocation. However, if the deallocation fails, the
847 -- total node count will not get decremented.
849 -- One way around this dilemma is to count the nodes in the subtree
850 -- before attempt to delete the subtree, but that is an O(n) operation,
851 -- so it does not seem worth it.
853 -- Perhaps this is much ado about nothing, since the only way
854 -- deallocation can fail is if Controlled Finalization fails: this
855 -- propagates Program_Error so all bets are off anyway. ???
859 -- Deallocate_Subtree returns a count of the number of nodes that it
860 -- deallocates, but it works by incrementing the value that is passed
861 -- in. We must therefore initialize the count value before calling
862 -- Deallocate_Subtree.
866 Deallocate_Subtree
(X
, Count
);
867 pragma Assert
(Count
<= Container
.Count
);
869 -- See comments above. We would prefer to do this sooner, but there's no
870 -- way to satisfy that goal without an potentially severe execution
873 Container
.Count
:= Container
.Count
- Count
;
880 function Depth
(Position
: Cursor
) return Count_Type
is
882 N
: Tree_Node_Access
;
889 Result
:= Result
+ 1;
899 function Element
(Position
: Cursor
) return Element_Type
is
901 if Checks
and then Position
.Container
= null then
902 raise Constraint_Error
with "Position cursor has no element";
905 if Checks
and then Position
.Node
= Root_Node
(Position
.Container
.all)
907 raise Program_Error
with "Position cursor designates root";
910 return Position
.Node
.Element
.all;
917 function Equal_Children
918 (Left_Subtree
: Tree_Node_Access
;
919 Right_Subtree
: Tree_Node_Access
) return Boolean
921 Left_Children
: Children_Type
renames Left_Subtree
.Children
;
922 Right_Children
: Children_Type
renames Right_Subtree
.Children
;
924 L
, R
: Tree_Node_Access
;
927 if Child_Count
(Left_Children
) /= Child_Count
(Right_Children
) then
931 L
:= Left_Children
.First
;
932 R
:= Right_Children
.First
;
934 if not Equal_Subtree
(L
, R
) then
949 function Equal_Subtree
950 (Left_Position
: Cursor
;
951 Right_Position
: Cursor
) return Boolean
954 if Checks
and then Left_Position
= No_Element
then
955 raise Constraint_Error
with "Left cursor has no element";
958 if Checks
and then Right_Position
= No_Element
then
959 raise Constraint_Error
with "Right cursor has no element";
962 if Left_Position
= Right_Position
then
966 if Is_Root
(Left_Position
) then
967 if not Is_Root
(Right_Position
) then
971 return Equal_Children
(Left_Position
.Node
, Right_Position
.Node
);
974 if Is_Root
(Right_Position
) then
978 return Equal_Subtree
(Left_Position
.Node
, Right_Position
.Node
);
981 function Equal_Subtree
982 (Left_Subtree
: Tree_Node_Access
;
983 Right_Subtree
: Tree_Node_Access
) return Boolean
986 if Left_Subtree
.Element
.all /= Right_Subtree
.Element
.all then
990 return Equal_Children
(Left_Subtree
, Right_Subtree
);
997 procedure Finalize
(Object
: in out Root_Iterator
) is
999 Unbusy
(Object
.Container
.TC
);
1008 Item
: Element_Type
) return Cursor
1010 N
: constant Tree_Node_Access
:=
1011 Find_In_Children
(Root_Node
(Container
), Item
);
1018 return Cursor
'(Container'Unrestricted_Access, N);
1025 overriding function First (Object : Subtree_Iterator) return Cursor is
1027 if Object.Subtree = Root_Node (Object.Container.all) then
1028 return First_Child (Root (Object.Container.all));
1030 return Cursor'(Object
.Container
, Object
.Subtree
);
1034 overriding
function First
(Object
: Child_Iterator
) return Cursor
is
1036 return First_Child
(Cursor
'(Object.Container, Object.Subtree));
1043 function First_Child (Parent : Cursor) return Cursor is
1044 Node : Tree_Node_Access;
1047 if Checks and then Parent = No_Element then
1048 raise Constraint_Error with "Parent cursor has no element";
1051 Node := Parent.Node.Children.First;
1057 return Cursor'(Parent
.Container
, Node
);
1060 -------------------------
1061 -- First_Child_Element --
1062 -------------------------
1064 function First_Child_Element
(Parent
: Cursor
) return Element_Type
is
1066 return Element
(First_Child
(Parent
));
1067 end First_Child_Element
;
1069 ----------------------
1070 -- Find_In_Children --
1071 ----------------------
1073 function Find_In_Children
1074 (Subtree
: Tree_Node_Access
;
1075 Item
: Element_Type
) return Tree_Node_Access
1077 N
, Result
: Tree_Node_Access
;
1080 N
:= Subtree
.Children
.First
;
1081 while N
/= null loop
1082 Result
:= Find_In_Subtree
(N
, Item
);
1084 if Result
/= null then
1092 end Find_In_Children
;
1094 ---------------------
1095 -- Find_In_Subtree --
1096 ---------------------
1098 function Find_In_Subtree
1100 Item
: Element_Type
) return Cursor
1102 Result
: Tree_Node_Access
;
1105 if Checks
and then Position
= No_Element
then
1106 raise Constraint_Error
with "Position cursor has no element";
1109 -- Commented-out pending ruling from ARG. ???
1111 -- if Checks and then
1112 -- Position.Container /= Container'Unrestricted_Access
1114 -- raise Program_Error with "Position cursor not in container";
1117 if Is_Root
(Position
) then
1118 Result
:= Find_In_Children
(Position
.Node
, Item
);
1121 Result
:= Find_In_Subtree
(Position
.Node
, Item
);
1124 if Result
= null then
1128 return Cursor
'(Position.Container, Result);
1129 end Find_In_Subtree;
1131 function Find_In_Subtree
1132 (Subtree : Tree_Node_Access;
1133 Item : Element_Type) return Tree_Node_Access
1136 if Subtree.Element.all = Item then
1140 return Find_In_Children (Subtree, Item);
1141 end Find_In_Subtree;
1143 ------------------------
1144 -- Get_Element_Access --
1145 ------------------------
1147 function Get_Element_Access
1148 (Position : Cursor) return not null Element_Access is
1150 return Position.Node.Element;
1151 end Get_Element_Access;
1157 function Has_Element (Position : Cursor) return Boolean is
1159 if Position = No_Element then
1163 return Position.Node.Parent /= null;
1170 procedure Insert_Child
1171 (Container : in out Tree;
1174 New_Item : Element_Type;
1175 Count : Count_Type := 1)
1180 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1183 procedure Insert_Child
1184 (Container : in out Tree;
1187 New_Item : Element_Type;
1188 Position : out Cursor;
1189 Count : Count_Type := 1)
1191 First : Tree_Node_Access;
1192 Last : Tree_Node_Access;
1193 Element : Element_Access;
1196 TC_Check (Container.TC);
1198 if Checks and then Parent = No_Element then
1199 raise Constraint_Error with "Parent cursor has no element";
1202 if Checks and then Parent.Container /= Container'Unrestricted_Access then
1203 raise Program_Error with "Parent cursor not in container";
1206 if Before /= No_Element then
1207 if Checks and then Before.Container /= Container'Unrestricted_Access
1209 raise Program_Error with "Before cursor not in container";
1212 if Checks and then Before.Node.Parent /= Parent.Node then
1213 raise Constraint_Error with "Parent cursor not parent of Before";
1218 Position := No_Element; -- Need ruling from ARG ???
1223 -- The element allocator may need an accessibility check in the case
1224 -- the actual type is class-wide or has access discriminants (see
1225 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1226 -- allocator in the loop below, because the one in this block would
1227 -- have failed already.
1229 pragma Unsuppress (Accessibility_Check);
1232 Element := new Element_Type'(New_Item
);
1235 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
1240 for J in Count_Type'(2) .. Count
loop
1242 -- Reclaim other nodes if Storage_Error. ???
1244 Element
:= new Element_Type
'(New_Item);
1245 Last.Next := new Tree_Node_Type'(Parent
=> Parent
.Node
,
1256 Parent
=> Parent
.Node
,
1257 Before
=> Before
.Node
);
1259 -- In order for operation Node_Count to complete in O(1) time, we cache
1260 -- the count value. Here we increment the total count by the number of
1261 -- nodes we just inserted.
1263 Container
.Count
:= Container
.Count
+ Count
;
1265 Position
:= Cursor
'(Parent.Container, First);
1268 -------------------------
1269 -- Insert_Subtree_List --
1270 -------------------------
1272 procedure Insert_Subtree_List
1273 (First : Tree_Node_Access;
1274 Last : Tree_Node_Access;
1275 Parent : Tree_Node_Access;
1276 Before : Tree_Node_Access)
1278 pragma Assert (Parent /= null);
1279 C : Children_Type renames Parent.Children;
1282 -- This is a simple utility operation to insert a list of nodes (from
1283 -- First..Last) as children of Parent. The Before node specifies where
1284 -- the new children should be inserted relative to the existing
1287 if First = null then
1288 pragma Assert (Last = null);
1292 pragma Assert (Last /= null);
1293 pragma Assert (Before = null or else Before.Parent = Parent);
1295 if C.First = null then
1297 C.First.Prev := null;
1299 C.Last.Next := null;
1301 elsif Before = null then -- means "insert after existing nodes"
1302 C.Last.Next := First;
1303 First.Prev := C.Last;
1305 C.Last.Next := null;
1307 elsif Before = C.First then
1308 Last.Next := C.First;
1309 C.First.Prev := Last;
1311 C.First.Prev := null;
1314 Before.Prev.Next := First;
1315 First.Prev := Before.Prev;
1316 Last.Next := Before;
1317 Before.Prev := Last;
1319 end Insert_Subtree_List;
1321 -------------------------
1322 -- Insert_Subtree_Node --
1323 -------------------------
1325 procedure Insert_Subtree_Node
1326 (Subtree : Tree_Node_Access;
1327 Parent : Tree_Node_Access;
1328 Before : Tree_Node_Access)
1331 -- This is a simple wrapper operation to insert a single child into the
1332 -- Parent's children list.
1339 end Insert_Subtree_Node;
1345 function Is_Empty (Container : Tree) return Boolean is
1347 return Container.Root.Children.First = null;
1354 function Is_Leaf (Position : Cursor) return Boolean is
1356 if Position = No_Element then
1360 return Position.Node.Children.First = null;
1367 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1368 pragma Assert (From /= null);
1369 pragma Assert (To /= null);
1371 N : Tree_Node_Access;
1375 while N /= null loop
1390 function Is_Root (Position : Cursor) return Boolean is
1392 if Position.Container = null then
1396 return Position = Root (Position.Container.all);
1405 Process : not null access procedure (Position : Cursor))
1407 Busy : With_Busy (Container.TC'Unrestricted_Access);
1410 (Container => Container'Unrestricted_Access,
1411 Subtree => Root_Node (Container),
1412 Process => Process);
1415 function Iterate (Container : Tree)
1416 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1419 return Iterate_Subtree (Root (Container));
1422 ----------------------
1423 -- Iterate_Children --
1424 ----------------------
1426 procedure Iterate_Children
1428 Process : not null access procedure (Position : Cursor))
1430 C : Tree_Node_Access;
1431 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
1433 if Checks and then Parent = No_Element then
1434 raise Constraint_Error with "Parent cursor has no element";
1437 C := Parent.Node.Children.First;
1438 while C /= null loop
1439 Process (Position => Cursor'(Parent
.Container
, Node
=> C
));
1442 end Iterate_Children
;
1444 procedure Iterate_Children
1445 (Container
: Tree_Access
;
1446 Subtree
: Tree_Node_Access
;
1447 Process
: not null access procedure (Position
: Cursor
))
1449 Node
: Tree_Node_Access
;
1452 -- This is a helper function to recursively iterate over all the nodes
1453 -- in a subtree, in depth-first fashion. This particular helper just
1454 -- visits the children of this subtree, not the root of the subtree node
1455 -- itself. This is useful when starting from the ultimate root of the
1456 -- entire tree (see Iterate), as that root does not have an element.
1458 Node
:= Subtree
.Children
.First
;
1459 while Node
/= null loop
1460 Iterate_Subtree
(Container
, Node
, Process
);
1463 end Iterate_Children
;
1465 function Iterate_Children
1468 return Tree_Iterator_Interfaces
.Reversible_Iterator
'Class
1470 C
: constant Tree_Access
:= Container
'Unrestricted_Access;
1472 if Checks
and then Parent
= No_Element
then
1473 raise Constraint_Error
with "Parent cursor has no element";
1476 if Checks
and then Parent
.Container
/= C
then
1477 raise Program_Error
with "Parent cursor not in container";
1480 return It
: constant Child_Iterator
:=
1481 Child_Iterator
'(Limited_Controlled with
1483 Subtree => Parent.Node)
1487 end Iterate_Children;
1489 ---------------------
1490 -- Iterate_Subtree --
1491 ---------------------
1493 function Iterate_Subtree
1495 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1497 C : constant Tree_Access := Position.Container;
1499 if Checks and then Position = No_Element then
1500 raise Constraint_Error with "Position cursor has no element";
1503 -- Implement Vet for multiway trees???
1504 -- pragma Assert (Vet (Position), "bad subtree cursor");
1506 return It : constant Subtree_Iterator :=
1507 (Limited_Controlled with
1508 Container => Position.Container,
1509 Subtree => Position.Node)
1513 end Iterate_Subtree;
1515 procedure Iterate_Subtree
1517 Process : not null access procedure (Position : Cursor))
1519 Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
1521 if Checks and then Position = No_Element then
1522 raise Constraint_Error with "Position cursor has no element";
1525 if Is_Root (Position) then
1526 Iterate_Children (Position.Container, Position.Node, Process);
1528 Iterate_Subtree (Position.Container, Position.Node, Process);
1530 end Iterate_Subtree;
1532 procedure Iterate_Subtree
1533 (Container : Tree_Access;
1534 Subtree : Tree_Node_Access;
1535 Process : not null access procedure (Position : Cursor))
1538 -- This is a helper function to recursively iterate over all the nodes
1539 -- in a subtree, in depth-first fashion. It first visits the root of the
1540 -- subtree, then visits its children.
1542 Process (Cursor'(Container
, Subtree
));
1543 Iterate_Children
(Container
, Subtree
, Process
);
1544 end Iterate_Subtree
;
1550 overriding
function Last
(Object
: Child_Iterator
) return Cursor
is
1552 return Last_Child
(Cursor
'(Object.Container, Object.Subtree));
1559 function Last_Child (Parent : Cursor) return Cursor is
1560 Node : Tree_Node_Access;
1563 if Checks and then Parent = No_Element then
1564 raise Constraint_Error with "Parent cursor has no element";
1567 Node := Parent.Node.Children.Last;
1573 return (Parent.Container, Node);
1576 ------------------------
1577 -- Last_Child_Element --
1578 ------------------------
1580 function Last_Child_Element (Parent : Cursor) return Element_Type is
1582 return Element (Last_Child (Parent));
1583 end Last_Child_Element;
1589 procedure Move (Target : in out Tree; Source : in out Tree) is
1590 Node : Tree_Node_Access;
1593 if Target'Address = Source'Address then
1597 TC_Check (Source.TC);
1599 Target.Clear; -- checks busy bit
1601 Target.Root.Children := Source.Root.Children;
1602 Source.Root.Children := Children_Type'(others => null);
1604 Node
:= Target
.Root
.Children
.First
;
1605 while Node
/= null loop
1606 Node
.Parent
:= Root_Node
(Target
);
1610 Target
.Count
:= Source
.Count
;
1619 (Object
: Subtree_Iterator
;
1620 Position
: Cursor
) return Cursor
1622 Node
: Tree_Node_Access
;
1625 if Position
.Container
= null then
1629 if Checks
and then Position
.Container
/= Object
.Container
then
1630 raise Program_Error
with
1631 "Position cursor of Next designates wrong tree";
1634 Node
:= Position
.Node
;
1636 if Node
.Children
.First
/= null then
1637 return Cursor
'(Object.Container, Node.Children.First);
1640 while Node /= Object.Subtree loop
1641 if Node.Next /= null then
1642 return Cursor'(Object
.Container
, Node
.Next
);
1645 Node
:= Node
.Parent
;
1652 (Object
: Child_Iterator
;
1653 Position
: Cursor
) return Cursor
1656 if Position
.Container
= null then
1660 if Checks
and then Position
.Container
/= Object
.Container
then
1661 raise Program_Error
with
1662 "Position cursor of Next designates wrong tree";
1665 return Next_Sibling
(Position
);
1672 function Next_Sibling
(Position
: Cursor
) return Cursor
is
1674 if Position
= No_Element
then
1678 if Position
.Node
.Next
= null then
1682 return Cursor
'(Position.Container, Position.Node.Next);
1685 procedure Next_Sibling (Position : in out Cursor) is
1687 Position := Next_Sibling (Position);
1694 function Node_Count (Container : Tree) return Count_Type is
1696 -- Container.Count is the number of nodes we have actually allocated. We
1697 -- cache the value specifically so this Node_Count operation can execute
1698 -- in O(1) time, which makes it behave similarly to how the Length
1699 -- selector function behaves for other containers.
1701 -- The cached node count value only describes the nodes we have
1702 -- allocated; the root node itself is not included in that count. The
1703 -- Node_Count operation returns a value that includes the root node
1704 -- (because the RM says so), so we must add 1 to our cached value.
1706 return 1 + Container.Count;
1713 function Parent (Position : Cursor) return Cursor is
1715 if Position = No_Element then
1719 if Position.Node.Parent = null then
1723 return Cursor'(Position
.Container
, Position
.Node
.Parent
);
1730 procedure Prepend_Child
1731 (Container
: in out Tree
;
1733 New_Item
: Element_Type
;
1734 Count
: Count_Type
:= 1)
1736 First
, Last
: Tree_Node_Access
;
1737 Element
: Element_Access
;
1740 TC_Check
(Container
.TC
);
1742 if Checks
and then Parent
= No_Element
then
1743 raise Constraint_Error
with "Parent cursor has no element";
1746 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
1747 raise Program_Error
with "Parent cursor not in container";
1755 -- The element allocator may need an accessibility check in the case
1756 -- the actual type is class-wide or has access discriminants (see
1757 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1758 -- allocator in the loop below, because the one in this block would
1759 -- have failed already.
1761 pragma Unsuppress
(Accessibility_Check
);
1764 Element
:= new Element_Type
'(New_Item);
1767 First := new Tree_Node_Type'(Parent
=> Parent
.Node
,
1773 for J
in Count_Type
'(2) .. Count loop
1775 -- Reclaim other nodes if Storage_Error. ???
1777 Element := new Element_Type'(New_Item
);
1778 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
1789 Parent => Parent.Node,
1790 Before => Parent.Node.Children.First);
1792 -- In order for operation Node_Count to complete in O(1) time, we cache
1793 -- the count value. Here we increment the total count by the number of
1794 -- nodes we just inserted.
1796 Container.Count := Container.Count + Count;
1803 overriding function Previous
1804 (Object : Child_Iterator;
1805 Position : Cursor) return Cursor
1808 if Position.Container = null then
1812 if Checks and then Position.Container /= Object.Container then
1813 raise Program_Error with
1814 "Position cursor of Previous designates wrong tree";
1817 return Previous_Sibling (Position);
1820 ----------------------
1821 -- Previous_Sibling --
1822 ----------------------
1824 function Previous_Sibling (Position : Cursor) return Cursor is
1826 if Position = No_Element then
1830 if Position.Node.Prev = null then
1834 return Cursor'(Position
.Container
, Position
.Node
.Prev
);
1835 end Previous_Sibling
;
1837 procedure Previous_Sibling
(Position
: in out Cursor
) is
1839 Position
:= Previous_Sibling
(Position
);
1840 end Previous_Sibling
;
1842 ----------------------
1843 -- Pseudo_Reference --
1844 ----------------------
1846 function Pseudo_Reference
1847 (Container
: aliased Tree
'Class) return Reference_Control_Type
1849 TC
: constant Tamper_Counts_Access
:= Container
.TC
'Unrestricted_Access;
1851 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
1854 end Pseudo_Reference
;
1860 procedure Query_Element
1862 Process
: not null access procedure (Element
: Element_Type
))
1864 T
: Tree
renames Position
.Container
.all'Unrestricted_Access.all;
1865 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
1867 if Checks
and then Position
= No_Element
then
1868 raise Constraint_Error
with "Position cursor has no element";
1871 if Checks
and then Is_Root
(Position
) then
1872 raise Program_Error
with "Position cursor designates root";
1875 Process
(Position
.Node
.Element
.all);
1883 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Tree
)
1885 use System
.Put_Images
;
1887 procedure Rec
(Position
: Cursor
);
1888 -- Recursive routine operating on cursors
1890 procedure Rec
(Position
: Cursor
) is
1891 First_Time
: Boolean := True;
1895 for X
in Iterate_Children
(V
, Position
) loop
1897 First_Time
:= False;
1902 Element_Type
'Put_Image (S
, Element
(X
));
1903 if Child_Count
(X
) > 0 then
1904 Simple_Array_Between
(S
);
1913 if First_Child
(Root
(V
)) = No_Element
then
1917 Rec
(First_Child
(Root
(V
)));
1926 (Stream
: not null access Root_Stream_Type
'Class;
1927 Container
: out Tree
)
1929 procedure Read_Children
(Subtree
: Tree_Node_Access
);
1931 function Read_Subtree
1932 (Parent
: Tree_Node_Access
) return Tree_Node_Access
;
1934 Total_Count
: Count_Type
'Base;
1935 -- Value read from the stream that says how many elements follow
1937 Read_Count
: Count_Type
'Base;
1938 -- Actual number of elements read from the stream
1944 procedure Read_Children
(Subtree
: Tree_Node_Access
) is
1945 pragma Assert
(Subtree
/= null);
1946 pragma Assert
(Subtree
.Children
.First
= null);
1947 pragma Assert
(Subtree
.Children
.Last
= null);
1949 Count
: Count_Type
'Base;
1950 -- Number of child subtrees
1955 Count_Type
'Read (Stream
, Count
);
1957 if Checks
and then Count
< 0 then
1958 raise Program_Error
with "attempt to read from corrupt stream";
1965 C
.First
:= Read_Subtree
(Parent
=> Subtree
);
1968 for J
in Count_Type
'(2) .. Count loop
1969 C.Last.Next := Read_Subtree (Parent => Subtree);
1970 C.Last.Next.Prev := C.Last;
1971 C.Last := C.Last.Next;
1974 -- Now that the allocation and reads have completed successfully, it
1975 -- is safe to link the children to their parent.
1977 Subtree.Children := C;
1984 function Read_Subtree
1985 (Parent : Tree_Node_Access) return Tree_Node_Access
1987 Element : constant Element_Access :=
1988 new Element_Type'(Element_Type
'Input (Stream
));
1990 Subtree
: constant Tree_Node_Access
:=
1992 (Parent => Parent, Element => Element, others => <>);
1995 Read_Count := Read_Count + 1;
1997 Read_Children (Subtree);
2002 -- Start of processing for Read
2005 Container.Clear; -- checks busy bit
2007 Count_Type'Read (Stream, Total_Count);
2009 if Checks and then Total_Count < 0 then
2010 raise Program_Error with "attempt to read from corrupt stream";
2013 if Total_Count = 0 then
2019 Read_Children (Root_Node (Container));
2021 if Checks and then Read_Count /= Total_Count then
2022 raise Program_Error with "attempt to read from corrupt stream";
2025 Container.Count := Total_Count;
2029 (Stream : not null access Root_Stream_Type'Class;
2030 Position : out Cursor)
2033 raise Program_Error with "attempt to read tree cursor from stream";
2037 (Stream : not null access Root_Stream_Type'Class;
2038 Item : out Reference_Type)
2041 raise Program_Error with "attempt to stream reference";
2045 (Stream : not null access Root_Stream_Type'Class;
2046 Item : out Constant_Reference_Type)
2049 raise Program_Error with "attempt to stream reference";
2057 (Container : aliased in out Tree;
2058 Position : Cursor) return Reference_Type
2061 if Checks and then Position.Container = null then
2062 raise Constraint_Error with
2063 "Position cursor has no element";
2066 if Checks and then Position.Container /= Container'Unrestricted_Access
2068 raise Program_Error with
2069 "Position cursor designates wrong container";
2072 if Checks and then Position.Node = Root_Node (Container) then
2073 raise Program_Error with "Position cursor designates root";
2076 if Checks and then Position.Node.Element = null then
2077 raise Program_Error with "Node has no element";
2080 -- Implement Vet for multiway tree???
2081 -- pragma Assert (Vet (Position),
2082 -- "Position cursor in Constant_Reference is bad");
2085 TC : constant Tamper_Counts_Access :=
2086 Container.TC'Unrestricted_Access;
2088 return R : constant Reference_Type :=
2089 (Element => Position.Node.Element.all'Access,
2090 Control => (Controlled with TC))
2097 --------------------
2098 -- Remove_Subtree --
2099 --------------------
2101 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
2102 C : Children_Type renames Subtree.Parent.Children;
2105 -- This is a utility operation to remove a subtree node from its
2106 -- parent's list of children.
2108 if C.First = Subtree then
2109 pragma Assert (Subtree.Prev = null);
2111 if C.Last = Subtree then
2112 pragma Assert (Subtree.Next = null);
2117 C.First := Subtree.Next;
2118 C.First.Prev := null;
2121 elsif C.Last = Subtree then
2122 pragma Assert (Subtree.Next = null);
2123 C.Last := Subtree.Prev;
2124 C.Last.Next := null;
2127 Subtree.Prev.Next := Subtree.Next;
2128 Subtree.Next.Prev := Subtree.Prev;
2132 ----------------------
2133 -- Replace_Element --
2134 ----------------------
2136 procedure Replace_Element
2137 (Container : in out Tree;
2139 New_Item : Element_Type)
2141 E, X : Element_Access;
2144 TE_Check (Container.TC);
2146 if Checks and then Position = No_Element then
2147 raise Constraint_Error with "Position cursor has no element";
2150 if Checks and then Position.Container /= Container'Unrestricted_Access
2152 raise Program_Error with "Position cursor not in container";
2155 if Checks and then Is_Root (Position) then
2156 raise Program_Error with "Position cursor designates root";
2160 -- The element allocator may need an accessibility check in the case
2161 -- the actual type is class-wide or has access discriminants (see
2162 -- RM 4.8(10.1) and AI12-0035).
2164 pragma Unsuppress (Accessibility_Check);
2167 E := new Element_Type'(New_Item
);
2170 X
:= Position
.Node
.Element
;
2171 Position
.Node
.Element
:= E
;
2174 end Replace_Element
;
2176 ------------------------------
2177 -- Reverse_Iterate_Children --
2178 ------------------------------
2180 procedure Reverse_Iterate_Children
2182 Process
: not null access procedure (Position
: Cursor
))
2184 C
: Tree_Node_Access
;
2185 Busy
: With_Busy
(Parent
.Container
.TC
'Unrestricted_Access);
2187 if Checks
and then Parent
= No_Element
then
2188 raise Constraint_Error
with "Parent cursor has no element";
2191 C
:= Parent
.Node
.Children
.Last
;
2192 while C
/= null loop
2193 Process
(Position
=> Cursor
'(Parent.Container, Node => C));
2196 end Reverse_Iterate_Children;
2202 function Root (Container : Tree) return Cursor is
2204 return (Container'Unrestricted_Access, Root_Node (Container));
2211 function Root_Node (Container : Tree) return Tree_Node_Access is
2213 return Container.Root'Unrestricted_Access;
2216 ---------------------
2217 -- Splice_Children --
2218 ---------------------
2220 procedure Splice_Children
2221 (Target : in out Tree;
2222 Target_Parent : Cursor;
2224 Source : in out Tree;
2225 Source_Parent : Cursor)
2230 TC_Check (Target.TC);
2231 TC_Check (Source.TC);
2233 if Checks and then Target_Parent = No_Element then
2234 raise Constraint_Error with "Target_Parent cursor has no element";
2237 if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
2240 with "Target_Parent cursor not in Target container";
2243 if Before /= No_Element then
2244 if Checks and then Before.Container /= Target'Unrestricted_Access then
2246 with "Before cursor not in Target container";
2249 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2250 raise Constraint_Error
2251 with "Before cursor not child of Target_Parent";
2255 if Checks and then Source_Parent = No_Element then
2256 raise Constraint_Error with "Source_Parent cursor has no element";
2259 if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
2262 with "Source_Parent cursor not in Source container";
2265 if Target'Address = Source'Address then
2266 if Target_Parent = Source_Parent then
2270 if Checks and then Is_Reachable (From => Target_Parent.Node,
2271 To => Source_Parent.Node)
2273 raise Constraint_Error
2274 with "Source_Parent is ancestor of Target_Parent";
2278 (Target_Parent => Target_Parent.Node,
2279 Before => Before.Node,
2280 Source_Parent => Source_Parent.Node);
2285 -- We cache the count of the nodes we have allocated, so that operation
2286 -- Node_Count can execute in O(1) time. But that means we must count the
2287 -- nodes in the subtree we remove from Source and insert into Target, in
2288 -- order to keep the count accurate.
2290 Count := Subtree_Node_Count (Source_Parent.Node);
2291 pragma Assert (Count >= 1);
2293 Count := Count - 1; -- because Source_Parent node does not move
2296 (Target_Parent => Target_Parent.Node,
2297 Before => Before.Node,
2298 Source_Parent => Source_Parent.Node);
2300 Source.Count := Source.Count - Count;
2301 Target.Count := Target.Count + Count;
2302 end Splice_Children;
2304 procedure Splice_Children
2305 (Container : in out Tree;
2306 Target_Parent : Cursor;
2308 Source_Parent : Cursor)
2311 TC_Check (Container.TC);
2313 if Checks and then Target_Parent = No_Element then
2314 raise Constraint_Error with "Target_Parent cursor has no element";
2318 Target_Parent.Container /= Container'Unrestricted_Access
2321 with "Target_Parent cursor not in container";
2324 if Before /= No_Element then
2325 if Checks and then Before.Container /= Container'Unrestricted_Access
2328 with "Before cursor not in container";
2331 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2332 raise Constraint_Error
2333 with "Before cursor not child of Target_Parent";
2337 if Checks and then Source_Parent = No_Element then
2338 raise Constraint_Error with "Source_Parent cursor has no element";
2342 Source_Parent.Container /= Container'Unrestricted_Access
2345 with "Source_Parent cursor not in container";
2348 if Target_Parent = Source_Parent then
2352 if Checks and then Is_Reachable (From => Target_Parent.Node,
2353 To => Source_Parent.Node)
2355 raise Constraint_Error
2356 with "Source_Parent is ancestor of Target_Parent";
2360 (Target_Parent => Target_Parent.Node,
2361 Before => Before.Node,
2362 Source_Parent => Source_Parent.Node);
2363 end Splice_Children;
2365 procedure Splice_Children
2366 (Target_Parent : Tree_Node_Access;
2367 Before : Tree_Node_Access;
2368 Source_Parent : Tree_Node_Access)
2370 CC : constant Children_Type := Source_Parent.Children;
2371 C : Tree_Node_Access;
2374 -- This is a utility operation to remove the children from Source parent
2375 -- and insert them into Target parent.
2377 Source_Parent.Children := Children_Type'(others => null);
2379 -- Fix up the Parent pointers of each child to designate its new Target
2383 while C
/= null loop
2384 C
.Parent
:= Target_Parent
;
2391 Parent
=> Target_Parent
,
2393 end Splice_Children
;
2395 --------------------
2396 -- Splice_Subtree --
2397 --------------------
2399 procedure Splice_Subtree
2400 (Target
: in out Tree
;
2403 Source
: in out Tree
;
2404 Position
: in out Cursor
)
2406 Subtree_Count
: Count_Type
;
2409 TC_Check
(Target
.TC
);
2410 TC_Check
(Source
.TC
);
2412 if Checks
and then Parent
= No_Element
then
2413 raise Constraint_Error
with "Parent cursor has no element";
2416 if Checks
and then Parent
.Container
/= Target
'Unrestricted_Access then
2417 raise Program_Error
with "Parent cursor not in Target container";
2420 if Before
/= No_Element
then
2421 if Checks
and then Before
.Container
/= Target
'Unrestricted_Access then
2422 raise Program_Error
with "Before cursor not in Target container";
2425 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
2426 raise Constraint_Error
with "Before cursor not child of Parent";
2430 if Checks
and then Position
= No_Element
then
2431 raise Constraint_Error
with "Position cursor has no element";
2434 if Checks
and then Position
.Container
/= Source
'Unrestricted_Access then
2435 raise Program_Error
with "Position cursor not in Source container";
2438 if Checks
and then Is_Root
(Position
) then
2439 raise Program_Error
with "Position cursor designates root";
2442 if Target
'Address = Source
'Address then
2443 if Position
.Node
.Parent
= Parent
.Node
then
2444 if Position
.Node
= Before
.Node
then
2448 if Position
.Node
.Next
= Before
.Node
then
2454 Is_Reachable
(From
=> Parent
.Node
, To
=> Position
.Node
)
2456 raise Constraint_Error
with "Position is ancestor of Parent";
2459 Remove_Subtree
(Position
.Node
);
2461 Position
.Node
.Parent
:= Parent
.Node
;
2462 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2467 -- This is an unfortunate feature of this API: we must count the nodes
2468 -- in the subtree that we remove from the source tree, which is an O(n)
2469 -- operation. It would have been better if the Tree container did not
2470 -- have a Node_Count selector; a user that wants the number of nodes in
2471 -- the tree could simply call Subtree_Node_Count, with the understanding
2472 -- that such an operation is O(n).
2474 -- Of course, we could choose to implement the Node_Count selector as an
2475 -- O(n) operation, which would turn this splice operation into an O(1)
2478 Subtree_Count
:= Subtree_Node_Count
(Position
.Node
);
2479 pragma Assert
(Subtree_Count
<= Source
.Count
);
2481 Remove_Subtree
(Position
.Node
);
2482 Source
.Count
:= Source
.Count
- Subtree_Count
;
2484 Position
.Node
.Parent
:= Parent
.Node
;
2485 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2487 Target
.Count
:= Target
.Count
+ Subtree_Count
;
2489 Position
.Container
:= Target
'Unrestricted_Access;
2492 procedure Splice_Subtree
2493 (Container
: in out Tree
;
2499 TC_Check
(Container
.TC
);
2501 if Checks
and then Parent
= No_Element
then
2502 raise Constraint_Error
with "Parent cursor has no element";
2505 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
2506 raise Program_Error
with "Parent cursor not in container";
2509 if Before
/= No_Element
then
2510 if Checks
and then Before
.Container
/= Container
'Unrestricted_Access
2512 raise Program_Error
with "Before cursor not in container";
2515 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
2516 raise Constraint_Error
with "Before cursor not child of Parent";
2520 if Checks
and then Position
= No_Element
then
2521 raise Constraint_Error
with "Position cursor has no element";
2524 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2526 raise Program_Error
with "Position cursor not in container";
2529 if Checks
and then Is_Root
(Position
) then
2531 -- Should this be PE instead? Need ARG confirmation. ???
2533 raise Constraint_Error
with "Position cursor designates root";
2536 if Position
.Node
.Parent
= Parent
.Node
then
2537 if Position
.Node
= Before
.Node
then
2541 if Position
.Node
.Next
= Before
.Node
then
2547 Is_Reachable
(From
=> Parent
.Node
, To
=> Position
.Node
)
2549 raise Constraint_Error
with "Position is ancestor of Parent";
2552 Remove_Subtree
(Position
.Node
);
2554 Position
.Node
.Parent
:= Parent
.Node
;
2555 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2558 ------------------------
2559 -- Subtree_Node_Count --
2560 ------------------------
2562 function Subtree_Node_Count
(Position
: Cursor
) return Count_Type
is
2564 if Position
= No_Element
then
2568 return Subtree_Node_Count
(Position
.Node
);
2569 end Subtree_Node_Count
;
2571 function Subtree_Node_Count
2572 (Subtree
: Tree_Node_Access
) return Count_Type
2574 Result
: Count_Type
;
2575 Node
: Tree_Node_Access
;
2579 Node
:= Subtree
.Children
.First
;
2580 while Node
/= null loop
2581 Result
:= Result
+ Subtree_Node_Count
(Node
);
2586 end Subtree_Node_Count
;
2593 (Container
: in out Tree
;
2597 TE_Check
(Container
.TC
);
2599 if Checks
and then I
= No_Element
then
2600 raise Constraint_Error
with "I cursor has no element";
2603 if Checks
and then I
.Container
/= Container
'Unrestricted_Access then
2604 raise Program_Error
with "I cursor not in container";
2607 if Checks
and then Is_Root
(I
) then
2608 raise Program_Error
with "I cursor designates root";
2611 if I
= J
then -- make this test sooner???
2615 if Checks
and then J
= No_Element
then
2616 raise Constraint_Error
with "J cursor has no element";
2619 if Checks
and then J
.Container
/= Container
'Unrestricted_Access then
2620 raise Program_Error
with "J cursor not in container";
2623 if Checks
and then Is_Root
(J
) then
2624 raise Program_Error
with "J cursor designates root";
2628 EI
: constant Element_Access
:= I
.Node
.Element
;
2631 I
.Node
.Element
:= J
.Node
.Element
;
2632 J
.Node
.Element
:= EI
;
2636 --------------------
2637 -- Update_Element --
2638 --------------------
2640 procedure Update_Element
2641 (Container
: in out Tree
;
2643 Process
: not null access procedure (Element
: in out Element_Type
))
2645 T
: Tree
renames Position
.Container
.all'Unrestricted_Access.all;
2646 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
2648 if Checks
and then Position
= No_Element
then
2649 raise Constraint_Error
with "Position cursor has no element";
2652 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2654 raise Program_Error
with "Position cursor not in container";
2657 if Checks
and then Is_Root
(Position
) then
2658 raise Program_Error
with "Position cursor designates root";
2661 Process
(Position
.Node
.Element
.all);
2669 (Stream
: not null access Root_Stream_Type
'Class;
2672 procedure Write_Children
(Subtree
: Tree_Node_Access
);
2673 procedure Write_Subtree
(Subtree
: Tree_Node_Access
);
2675 --------------------
2676 -- Write_Children --
2677 --------------------
2679 procedure Write_Children
(Subtree
: Tree_Node_Access
) is
2680 CC
: Children_Type
renames Subtree
.Children
;
2681 C
: Tree_Node_Access
;
2684 Count_Type
'Write (Stream
, Child_Count
(CC
));
2687 while C
/= null loop
2697 procedure Write_Subtree
(Subtree
: Tree_Node_Access
) is
2699 Element_Type
'Output (Stream
, Subtree
.Element
.all);
2700 Write_Children
(Subtree
);
2703 -- Start of processing for Write
2706 Count_Type
'Write (Stream
, Container
.Count
);
2708 if Container
.Count
= 0 then
2712 Write_Children
(Root_Node
(Container
));
2716 (Stream
: not null access Root_Stream_Type
'Class;
2720 raise Program_Error
with "attempt to write tree cursor to stream";
2724 (Stream
: not null access Root_Stream_Type
'Class;
2725 Item
: Reference_Type
)
2728 raise Program_Error
with "attempt to stream reference";
2732 (Stream
: not null access Root_Stream_Type
'Class;
2733 Item
: Constant_Reference_Type
)
2736 raise Program_Error
with "attempt to stream reference";
2739 end Ada
.Containers
.Indefinite_Multiway_Trees
;