1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S --
9 -- Copyright (C) 2004-2024, 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_Conversion
;
31 with Ada
.Unchecked_Deallocation
;
33 with System
; use type System
.Address
;
34 with System
.Put_Images
;
36 package body Ada
.Containers
.Multiway_Trees
with
40 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
41 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
42 -- See comment in Ada.Containers.Helpers
48 type Root_Iterator
is abstract new Limited_Controlled
and
49 Tree_Iterator_Interfaces
.Forward_Iterator
with
51 Container
: Tree_Access
;
52 Subtree
: Tree_Node_Access
;
54 with Disable_Controlled
=> not T_Check
;
56 overriding
procedure Finalize
(Object
: in out Root_Iterator
);
58 -----------------------
59 -- Subtree_Iterator --
60 -----------------------
62 -- ??? these headers are a bit odd, but for sure they do not substitute
63 -- for documenting things, what *is* a Subtree_Iterator?
65 type Subtree_Iterator
is new Root_Iterator
with null record;
67 overriding
function First
(Object
: Subtree_Iterator
) return Cursor
;
69 overriding
function Next
70 (Object
: Subtree_Iterator
;
71 Position
: Cursor
) return Cursor
;
77 type Child_Iterator
is new Root_Iterator
and
78 Tree_Iterator_Interfaces
.Reversible_Iterator
with null record
79 with Disable_Controlled
=> not T_Check
;
81 overriding
function First
(Object
: Child_Iterator
) return Cursor
;
83 overriding
function Next
84 (Object
: Child_Iterator
;
85 Position
: Cursor
) return Cursor
;
87 overriding
function Last
(Object
: Child_Iterator
) return Cursor
;
89 overriding
function Previous
90 (Object
: Child_Iterator
;
91 Position
: Cursor
) return Cursor
;
93 -----------------------
94 -- Local Subprograms --
95 -----------------------
97 function Root_Node
(Container
: Tree
) return Tree_Node_Access
;
99 procedure Deallocate_Node
is
100 new Ada
.Unchecked_Deallocation
(Tree_Node_Type
, Tree_Node_Access
);
102 procedure Deallocate_Children
103 (Subtree
: Tree_Node_Access
;
104 Count
: in out Count_Type
);
106 procedure Deallocate_Subtree
107 (Subtree
: in out Tree_Node_Access
;
108 Count
: in out Count_Type
);
110 function Equal_Children
111 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
113 function Equal_Subtree
114 (Left_Subtree
, Right_Subtree
: Tree_Node_Access
) return Boolean;
116 procedure Iterate_Children
117 (Container
: Tree_Access
;
118 Subtree
: Tree_Node_Access
;
119 Process
: not null access procedure (Position
: Cursor
));
121 procedure Iterate_Subtree
122 (Container
: Tree_Access
;
123 Subtree
: Tree_Node_Access
;
124 Process
: not null access procedure (Position
: Cursor
));
126 procedure Copy_Children
127 (Source
: Children_Type
;
128 Parent
: Tree_Node_Access
;
129 Count
: in out Count_Type
);
131 procedure Copy_Subtree
132 (Source
: Tree_Node_Access
;
133 Parent
: Tree_Node_Access
;
134 Target
: out Tree_Node_Access
;
135 Count
: in out Count_Type
);
137 function Find_In_Children
138 (Subtree
: Tree_Node_Access
;
139 Item
: Element_Type
) return Tree_Node_Access
;
141 function Find_In_Subtree
142 (Subtree
: Tree_Node_Access
;
143 Item
: Element_Type
) return Tree_Node_Access
;
145 function Child_Count
(Children
: Children_Type
) return Count_Type
;
147 function Subtree_Node_Count
148 (Subtree
: Tree_Node_Access
) return Count_Type
;
150 function Is_Reachable
(From
, To
: Tree_Node_Access
) return Boolean;
152 procedure Remove_Subtree
(Subtree
: Tree_Node_Access
);
154 procedure Insert_Subtree_Node
155 (Subtree
: Tree_Node_Access
;
156 Parent
: Tree_Node_Access
;
157 Before
: Tree_Node_Access
);
159 procedure Insert_Subtree_List
160 (First
: Tree_Node_Access
;
161 Last
: Tree_Node_Access
;
162 Parent
: Tree_Node_Access
;
163 Before
: Tree_Node_Access
);
165 procedure Splice_Children
166 (Target_Parent
: Tree_Node_Access
;
167 Before
: Tree_Node_Access
;
168 Source_Parent
: Tree_Node_Access
);
174 function "=" (Left
, Right
: Tree
) return Boolean is
176 return Equal_Children
(Root_Node
(Left
), Root_Node
(Right
));
183 procedure Adjust
(Container
: in out Tree
) is
184 Source
: constant Children_Type
:= Container
.Root
.Children
;
185 Source_Count
: constant Count_Type
:= Container
.Count
;
186 Target_Count
: Count_Type
;
189 -- We first restore the target container to its default-initialized
190 -- state, before we attempt any allocation, to ensure that invariants
191 -- are preserved in the event that the allocation fails.
193 Container
.Root
.Children
:= Children_Type
'(others => null);
194 Zero_Counts (Container.TC);
195 Container.Count := 0;
197 -- Copy_Children returns a count of the number of nodes that it
198 -- allocates, but it works by incrementing the value that is passed
199 -- in. We must therefore initialize the count value before calling
204 -- Now we attempt the allocation of subtrees. The invariants are
205 -- satisfied even if the allocation fails.
207 Copy_Children (Source, Root_Node (Container), Target_Count);
208 pragma Assert (Target_Count = Source_Count);
210 Container.Count := Source_Count;
217 function Ancestor_Find
219 Item : Element_Type) return Cursor
221 R, N : Tree_Node_Access;
224 if Checks and then Position = No_Element then
225 raise Constraint_Error with "Position cursor has no element";
228 -- Commented-out pending official ruling from ARG. ???
230 -- if Position.Container /= Container'Unrestricted_Access then
231 -- raise Program_Error with "Position cursor not in container";
234 -- AI-0136 says to raise PE if Position equals the root node. This does
235 -- not seem correct, as this value is just the limiting condition of the
236 -- search. For now we omit this check, pending a ruling from the ARG.???
238 -- if Checks and then Is_Root (Position) then
239 -- raise Program_Error with "Position cursor designates root";
242 R := Root_Node (Position.Container.all);
245 if N.Element = Item then
246 return Cursor'(Position
.Container
, N
);
259 procedure Append_Child
260 (Container
: in out Tree
;
262 New_Item
: Element_Type
;
263 Count
: Count_Type
:= 1)
265 First
: Tree_Node_Access
;
266 Last
: Tree_Node_Access
;
269 TC_Check
(Container
.TC
);
271 if Checks
and then Parent
= No_Element
then
272 raise Constraint_Error
with "Parent cursor has no element";
275 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
276 raise Program_Error
with "Parent cursor not in container";
283 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
288 for J in Count_Type'(2) .. Count
loop
290 -- Reclaim other nodes if Storage_Error. ???
292 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
303 Parent => Parent.Node,
304 Before => null); -- null means "insert at end of list"
306 -- In order for operation Node_Count to complete in O(1) time, we cache
307 -- the count value. Here we increment the total count by the number of
308 -- nodes we just inserted.
310 Container.Count := Container.Count + Count;
317 procedure Assign (Target : in out Tree; Source : Tree) is
318 Source_Count : constant Count_Type := Source.Count;
319 Target_Count : Count_Type;
322 if Target'Address = Source'Address then
326 Target.Clear; -- checks busy bit
328 -- Copy_Children returns the number of nodes that it allocates, but it
329 -- does this by incrementing the count value passed in, so we must
330 -- initialize the count before calling Copy_Children.
334 -- Note that Copy_Children inserts the newly-allocated children into
335 -- their parent list only after the allocation of all the children has
336 -- succeeded. This preserves invariants even if the allocation fails.
338 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
339 pragma Assert (Target_Count = Source_Count);
341 Target.Count := Source_Count;
348 function Child_Count (Parent : Cursor) return Count_Type is
350 return (if Parent = No_Element
351 then 0 else Child_Count (Parent.Node.Children));
354 function Child_Count (Children : Children_Type) return Count_Type is
356 Node : Tree_Node_Access;
360 Node := Children.First;
361 while Node /= null loop
362 Result := Result + 1;
373 function Child_Depth (Parent, Child : Cursor) return Count_Type is
375 N : Tree_Node_Access;
378 if Checks and then Parent = No_Element then
379 raise Constraint_Error with "Parent cursor has no element";
382 if Checks and then Child = No_Element then
383 raise Constraint_Error with "Child cursor has no element";
386 if Checks and then Parent.Container /= Child.Container then
387 raise Program_Error with "Parent and Child in different containers";
392 while N /= Parent.Node loop
393 Result := Result + 1;
396 if Checks and then N = null then
397 raise Program_Error with "Parent is not ancestor of Child";
408 procedure Clear (Container : in out Tree) is
409 Container_Count, Children_Count : Count_Type;
412 TC_Check (Container.TC);
414 -- We first set the container count to 0, in order to preserve
415 -- invariants in case the deallocation fails. (This works because
416 -- Deallocate_Children immediately removes the children from their
417 -- parent, and then does the actual deallocation.)
419 Container_Count := Container.Count;
420 Container.Count := 0;
422 -- Deallocate_Children returns the number of nodes that it deallocates,
423 -- but it does this by incrementing the count value that is passed in,
424 -- so we must first initialize the count return value before calling it.
428 -- See comment above. Deallocate_Children immediately removes the
429 -- children list from their parent node (here, the root of the tree),
430 -- and only after that does it attempt the actual deallocation. So even
431 -- if the deallocation fails, the representation invariants for the tree
434 Deallocate_Children (Root_Node (Container), Children_Count);
435 pragma Assert (Children_Count = Container_Count);
438 ------------------------
439 -- Constant_Reference --
440 ------------------------
442 function Constant_Reference
443 (Container : aliased Tree;
444 Position : Cursor) return Constant_Reference_Type
447 if Checks and then Position.Container = null then
448 raise Constraint_Error with
449 "Position cursor has no element";
452 if Checks and then Position.Container /= Container'Unrestricted_Access
454 raise Program_Error with
455 "Position cursor designates wrong container";
458 if Checks and then Position.Node = Root_Node (Container) then
459 raise Program_Error with "Position cursor designates root";
462 -- Implement Vet for multiway tree???
463 -- pragma Assert (Vet (Position),
464 -- "Position cursor in Constant_Reference is bad");
467 C : Tree renames Position.Container.all;
468 TC : constant Tamper_Counts_Access :=
469 C.TC'Unrestricted_Access;
471 return R : constant Constant_Reference_Type :=
472 (Element => Position.Node.Element'Access,
473 Control => (Controlled with TC))
478 end Constant_Reference;
486 Item : Element_Type) return Boolean
489 return Find (Container, Item) /= No_Element;
496 function Copy (Source : Tree) return Tree is
498 return Target : Tree do
500 (Source => Source.Root.Children,
501 Parent => Root_Node (Target),
502 Count => Target.Count);
504 pragma Assert (Target.Count = Source.Count);
512 procedure Copy_Children
513 (Source : Children_Type;
514 Parent : Tree_Node_Access;
515 Count : in out Count_Type)
517 pragma Assert (Parent /= null);
518 pragma Assert (Parent.Children.First = null);
519 pragma Assert (Parent.Children.Last = null);
522 C : Tree_Node_Access;
525 -- We special-case the first allocation, in order to establish the
526 -- representation invariants for type Children_Type.
542 -- The representation invariants for the Children_Type list have been
543 -- established, so we can now copy the remaining children of Source.
550 Target => CC.Last.Next,
553 CC.Last.Next.Prev := CC.Last;
554 CC.Last := CC.Last.Next;
559 -- Add the newly-allocated children to their parent list only after the
560 -- allocation has succeeded, so as to preserve invariants of the parent.
562 Parent.Children := CC;
569 procedure Copy_Subtree
570 (Target : in out Tree;
575 Target_Subtree : Tree_Node_Access;
576 Target_Count : Count_Type;
579 if Checks and then Parent = No_Element then
580 raise Constraint_Error with "Parent cursor has no element";
583 if Checks and then Parent.Container /= Target'Unrestricted_Access then
584 raise Program_Error with "Parent cursor not in container";
587 if Before /= No_Element then
588 if Checks and then Before.Container /= Target'Unrestricted_Access then
589 raise Program_Error with "Before cursor not in container";
592 if Checks and then Before.Node.Parent /= Parent.Node then
593 raise Constraint_Error with "Before cursor not child of Parent";
597 if Source = No_Element then
601 if Checks and then Is_Root (Source) then
602 raise Constraint_Error with "Source cursor designates root";
605 -- Copy_Subtree returns a count of the number of nodes that it
606 -- allocates, but it works by incrementing the value that is passed
607 -- in. We must therefore initialize the count value before calling
613 (Source => Source.Node,
614 Parent => Parent.Node,
615 Target => Target_Subtree,
616 Count => Target_Count);
618 pragma Assert (Target_Subtree /= null);
619 pragma Assert (Target_Subtree.Parent = Parent.Node);
620 pragma Assert (Target_Count >= 1);
623 (Subtree => Target_Subtree,
624 Parent => Parent.Node,
625 Before => Before.Node);
627 -- In order for operation Node_Count to complete in O(1) time, we cache
628 -- the count value. Here we increment the total count by the number of
629 -- nodes we just inserted.
631 Target.Count := Target.Count + Target_Count;
634 procedure Copy_Subtree
635 (Source : Tree_Node_Access;
636 Parent : Tree_Node_Access;
637 Target : out Tree_Node_Access;
638 Count : in out Count_Type)
641 Target := new Tree_Node_Type'(Element
=> Source
.Element
,
648 (Source
=> Source
.Children
,
653 -------------------------
654 -- Deallocate_Children --
655 -------------------------
657 procedure Deallocate_Children
658 (Subtree
: Tree_Node_Access
;
659 Count
: in out Count_Type
)
661 pragma Assert
(Subtree
/= null);
663 CC
: Children_Type
:= Subtree
.Children
;
664 C
: Tree_Node_Access
;
667 -- We immediately remove the children from their parent, in order to
668 -- preserve invariants in case the deallocation fails.
670 Subtree
.Children
:= Children_Type
'(others => null);
672 while CC.First /= null loop
676 Deallocate_Subtree (C, Count);
678 end Deallocate_Children;
680 ------------------------
681 -- Deallocate_Subtree --
682 ------------------------
684 procedure Deallocate_Subtree
685 (Subtree : in out Tree_Node_Access;
686 Count : in out Count_Type)
689 Deallocate_Children (Subtree, Count);
690 Deallocate_Node (Subtree);
692 end Deallocate_Subtree;
694 ---------------------
695 -- Delete_Children --
696 ---------------------
698 procedure Delete_Children
699 (Container : in out Tree;
705 TC_Check (Container.TC);
707 if Checks and then Parent = No_Element then
708 raise Constraint_Error with "Parent cursor has no element";
711 if Checks and then Parent.Container /= Container'Unrestricted_Access then
712 raise Program_Error with "Parent cursor not in container";
715 -- Deallocate_Children returns a count of the number of nodes that it
716 -- deallocates, but it works by incrementing the value that is passed
717 -- in. We must therefore initialize the count value before calling
718 -- Deallocate_Children.
722 Deallocate_Children (Parent.Node, Count);
723 pragma Assert (Count <= Container.Count);
725 Container.Count := Container.Count - Count;
732 procedure Delete_Leaf
733 (Container : in out Tree;
734 Position : in out Cursor)
736 X : Tree_Node_Access;
739 TC_Check (Container.TC);
741 if Checks and then Position = No_Element then
742 raise Constraint_Error with "Position cursor has no element";
745 if Checks and then Position.Container /= Container'Unrestricted_Access
747 raise Program_Error with "Position cursor not in container";
750 if Checks and then Is_Root (Position) then
751 raise Program_Error with "Position cursor designates root";
754 if Checks and then not Is_Leaf (Position) then
755 raise Constraint_Error with "Position cursor does not designate leaf";
759 Position := No_Element;
761 -- Restore represention invariants before attempting the actual
765 Container.Count := Container.Count - 1;
767 -- It is now safe to attempt the deallocation. This leaf node has been
768 -- disassociated from the tree, so even if the deallocation fails,
769 -- representation invariants will remain satisfied.
778 procedure Delete_Subtree
779 (Container : in out Tree;
780 Position : in out Cursor)
782 X : Tree_Node_Access;
786 TC_Check (Container.TC);
788 if Checks and then Position = No_Element then
789 raise Constraint_Error with "Position cursor has no element";
792 if Checks and then Position.Container /= Container'Unrestricted_Access
794 raise Program_Error with "Position cursor not in container";
797 if Checks and then Is_Root (Position) then
798 raise Program_Error with "Position cursor designates root";
802 Position := No_Element;
804 -- Here is one case where a deallocation failure can result in the
805 -- violation of a representation invariant. We disassociate the subtree
806 -- from the tree now, but we only decrement the total node count after
807 -- we attempt the deallocation. However, if the deallocation fails, the
808 -- total node count will not get decremented.
810 -- One way around this dilemma is to count the nodes in the subtree
811 -- before attempt to delete the subtree, but that is an O(n) operation,
812 -- so it does not seem worth it.
814 -- Perhaps this is much ado about nothing, since the only way
815 -- deallocation can fail is if Controlled Finalization fails: this
816 -- propagates Program_Error so all bets are off anyway. ???
820 -- Deallocate_Subtree returns a count of the number of nodes that it
821 -- deallocates, but it works by incrementing the value that is passed
822 -- in. We must therefore initialize the count value before calling
823 -- Deallocate_Subtree.
827 Deallocate_Subtree (X, Count);
828 pragma Assert (Count <= Container.Count);
830 -- See comments above. We would prefer to do this sooner, but there's no
831 -- way to satisfy that goal without a potentially severe execution
834 Container.Count := Container.Count - Count;
841 function Depth (Position : Cursor) return Count_Type is
843 N : Tree_Node_Access;
850 Result := Result + 1;
860 function Element (Position : Cursor) return Element_Type is
862 if Checks and then Position.Container = null then
863 raise Constraint_Error with "Position cursor has no element";
866 if Checks and then Position.Node = Root_Node (Position.Container.all)
868 raise Program_Error with "Position cursor designates root";
871 return Position.Node.Element;
878 function Equal_Children
879 (Left_Subtree : Tree_Node_Access;
880 Right_Subtree : Tree_Node_Access) return Boolean
882 Left_Children : Children_Type renames Left_Subtree.Children;
883 Right_Children : Children_Type renames Right_Subtree.Children;
885 L, R : Tree_Node_Access;
888 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
892 L := Left_Children.First;
893 R := Right_Children.First;
895 if not Equal_Subtree (L, R) then
910 function Equal_Subtree
911 (Left_Position : Cursor;
912 Right_Position : Cursor) return Boolean
915 if Checks and then Left_Position = No_Element then
916 raise Constraint_Error with "Left cursor has no element";
919 if Checks and then Right_Position = No_Element then
920 raise Constraint_Error with "Right cursor has no element";
923 if Left_Position = Right_Position then
927 if Is_Root (Left_Position) then
928 if not Is_Root (Right_Position) then
932 return Equal_Children (Left_Position.Node, Right_Position.Node);
935 if Is_Root (Right_Position) then
939 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
942 function Equal_Subtree
943 (Left_Subtree : Tree_Node_Access;
944 Right_Subtree : Tree_Node_Access) return Boolean
947 if Left_Subtree.Element /= Right_Subtree.Element then
951 return Equal_Children (Left_Subtree, Right_Subtree);
958 procedure Finalize (Object : in out Root_Iterator) is
960 Unbusy (Object.Container.TC);
969 Item : Element_Type) return Cursor
971 N : constant Tree_Node_Access :=
972 Find_In_Children (Root_Node (Container), Item);
977 return Cursor'(Container
'Unrestricted_Access, N
);
985 overriding
function First
(Object
: Subtree_Iterator
) return Cursor
is
987 if Object
.Subtree
= Root_Node
(Object
.Container
.all) then
988 return First_Child
(Root
(Object
.Container
.all));
990 return Cursor
'(Object.Container, Object.Subtree);
994 overriding function First (Object : Child_Iterator) return Cursor is
996 return First_Child (Cursor'(Object
.Container
, Object
.Subtree
));
1003 function First_Child
(Parent
: Cursor
) return Cursor
is
1004 Node
: Tree_Node_Access
;
1007 if Checks
and then Parent
= No_Element
then
1008 raise Constraint_Error
with "Parent cursor has no element";
1011 Node
:= Parent
.Node
.Children
.First
;
1017 return Cursor
'(Parent.Container, Node);
1020 -------------------------
1021 -- First_Child_Element --
1022 -------------------------
1024 function First_Child_Element (Parent : Cursor) return Element_Type is
1026 return Element (First_Child (Parent));
1027 end First_Child_Element;
1029 ----------------------
1030 -- Find_In_Children --
1031 ----------------------
1033 function Find_In_Children
1034 (Subtree : Tree_Node_Access;
1035 Item : Element_Type) return Tree_Node_Access
1037 N, Result : Tree_Node_Access;
1040 N := Subtree.Children.First;
1041 while N /= null loop
1042 Result := Find_In_Subtree (N, Item);
1044 if Result /= null then
1052 end Find_In_Children;
1054 ---------------------
1055 -- Find_In_Subtree --
1056 ---------------------
1058 function Find_In_Subtree
1060 Item : Element_Type) return Cursor
1062 Result : Tree_Node_Access;
1065 if Checks and then Position = No_Element then
1066 raise Constraint_Error with "Position cursor has no element";
1069 -- Commented out pending official ruling by ARG. ???
1071 -- if Checks and then
1072 -- Position.Container /= Container'Unrestricted_Access
1074 -- raise Program_Error with "Position cursor not in container";
1078 (if Is_Root (Position)
1079 then Find_In_Children (Position.Node, Item)
1080 else Find_In_Subtree (Position.Node, Item));
1082 if Result = null then
1086 return Cursor'(Position
.Container
, Result
);
1087 end Find_In_Subtree
;
1089 function Find_In_Subtree
1090 (Subtree
: Tree_Node_Access
;
1091 Item
: Element_Type
) return Tree_Node_Access
1094 if Subtree
.Element
= Item
then
1098 return Find_In_Children
(Subtree
, Item
);
1099 end Find_In_Subtree
;
1101 ------------------------
1102 -- Get_Element_Access --
1103 ------------------------
1105 function Get_Element_Access
1106 (Position
: Cursor
) return not null Element_Access
is
1108 return Position
.Node
.Element
'Access;
1109 end Get_Element_Access
;
1115 function Has_Element
(Position
: Cursor
) return Boolean is
1117 return (if Position
= No_Element
then False
1118 else Position
.Node
.Parent
/= null);
1125 procedure Insert_Child
1126 (Container
: in out Tree
;
1129 New_Item
: Element_Type
;
1130 Count
: Count_Type
:= 1)
1135 Insert_Child
(Container
, Parent
, Before
, New_Item
, Position
, Count
);
1138 procedure Insert_Child
1139 (Container
: in out Tree
;
1142 New_Item
: Element_Type
;
1143 Position
: out Cursor
;
1144 Count
: Count_Type
:= 1)
1146 First
: Tree_Node_Access
;
1147 Last
: Tree_Node_Access
;
1150 TC_Check
(Container
.TC
);
1152 if Checks
and then Parent
= No_Element
then
1153 raise Constraint_Error
with "Parent cursor has no element";
1156 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
1157 raise Program_Error
with "Parent cursor not in container";
1160 if Before
/= No_Element
then
1161 if Checks
and then Before
.Container
/= Container
'Unrestricted_Access
1163 raise Program_Error
with "Before cursor not in container";
1166 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
1167 raise Constraint_Error
with "Parent cursor not parent of Before";
1172 Position
:= No_Element
; -- Need ruling from ARG ???
1176 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
1177 Element => New_Item,
1181 for J in Count_Type'(2) .. Count
loop
1183 -- Reclaim other nodes if Storage_Error. ???
1185 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
1187 Element => New_Item,
1196 Parent => Parent.Node,
1197 Before => Before.Node);
1199 -- In order for operation Node_Count to complete in O(1) time, we cache
1200 -- the count value. Here we increment the total count by the number of
1201 -- nodes we just inserted.
1203 Container.Count := Container.Count + Count;
1205 Position := Cursor'(Parent
.Container
, First
);
1208 procedure Insert_Child
1209 (Container
: in out Tree
;
1212 Position
: out Cursor
;
1213 Count
: Count_Type
:= 1)
1215 First
: Tree_Node_Access
;
1216 Last
: Tree_Node_Access
;
1219 TC_Check
(Container
.TC
);
1221 if Checks
and then Parent
= No_Element
then
1222 raise Constraint_Error
with "Parent cursor has no element";
1225 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
1226 raise Program_Error
with "Parent cursor not in container";
1229 if Before
/= No_Element
then
1230 if Checks
and then Before
.Container
/= Container
'Unrestricted_Access
1232 raise Program_Error
with "Before cursor not in container";
1235 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
1236 raise Constraint_Error
with "Parent cursor not parent of Before";
1241 Position
:= No_Element
; -- Need ruling from ARG ???
1245 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
1250 for J in Count_Type'(2) .. Count
loop
1252 -- Reclaim other nodes if Storage_Error. ???
1254 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.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;
1274 Position := Cursor'(Parent
.Container
, First
);
1277 -------------------------
1278 -- Insert_Subtree_List --
1279 -------------------------
1281 procedure Insert_Subtree_List
1282 (First
: Tree_Node_Access
;
1283 Last
: Tree_Node_Access
;
1284 Parent
: Tree_Node_Access
;
1285 Before
: Tree_Node_Access
)
1287 pragma Assert
(Parent
/= null);
1288 C
: Children_Type
renames Parent
.Children
;
1291 -- This is a simple utility operation to insert a list of nodes (from
1292 -- First..Last) as children of Parent. The Before node specifies where
1293 -- the new children should be inserted relative to the existing
1296 if First
= null then
1297 pragma Assert
(Last
= null);
1301 pragma Assert
(Last
/= null);
1302 pragma Assert
(Before
= null or else Before
.Parent
= Parent
);
1304 if C
.First
= null then
1306 C
.First
.Prev
:= null;
1308 C
.Last
.Next
:= null;
1310 elsif Before
= null then -- means "insert after existing nodes"
1311 C
.Last
.Next
:= First
;
1312 First
.Prev
:= C
.Last
;
1314 C
.Last
.Next
:= null;
1316 elsif Before
= C
.First
then
1317 Last
.Next
:= C
.First
;
1318 C
.First
.Prev
:= Last
;
1320 C
.First
.Prev
:= null;
1323 Before
.Prev
.Next
:= First
;
1324 First
.Prev
:= Before
.Prev
;
1325 Last
.Next
:= Before
;
1326 Before
.Prev
:= Last
;
1328 end Insert_Subtree_List
;
1330 -------------------------
1331 -- Insert_Subtree_Node --
1332 -------------------------
1334 procedure Insert_Subtree_Node
1335 (Subtree
: Tree_Node_Access
;
1336 Parent
: Tree_Node_Access
;
1337 Before
: Tree_Node_Access
)
1340 -- This is a simple wrapper operation to insert a single child into the
1341 -- Parent's children list.
1348 end Insert_Subtree_Node
;
1354 function Is_Empty
(Container
: Tree
) return Boolean is
1356 return Container
.Root
.Children
.First
= null;
1363 function Is_Leaf
(Position
: Cursor
) return Boolean is
1365 return (if Position
= No_Element
then False
1366 else Position
.Node
.Children
.First
= null);
1373 function Is_Reachable
(From
, To
: Tree_Node_Access
) return Boolean is
1374 pragma Assert
(From
/= null);
1375 pragma Assert
(To
/= null);
1377 N
: Tree_Node_Access
;
1381 while N
/= null loop
1396 function Is_Root
(Position
: Cursor
) return Boolean is
1398 return (if Position
.Container
= null then False
1399 else Position
= Root
(Position
.Container
.all));
1408 Process
: not null access procedure (Position
: Cursor
))
1410 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
1413 (Container
=> Container
'Unrestricted_Access,
1414 Subtree
=> Root_Node
(Container
),
1415 Process
=> Process
);
1418 function Iterate
(Container
: Tree
)
1419 return Tree_Iterator_Interfaces
.Forward_Iterator
'Class
1422 return Iterate_Subtree
(Root
(Container
));
1425 ----------------------
1426 -- Iterate_Children --
1427 ----------------------
1429 procedure Iterate_Children
1431 Process
: not null access procedure (Position
: Cursor
))
1433 C
: Tree_Node_Access
;
1434 Busy
: With_Busy
(Parent
.Container
.TC
'Unrestricted_Access);
1436 if Checks
and then Parent
= No_Element
then
1437 raise Constraint_Error
with "Parent cursor has no element";
1440 C
:= Parent
.Node
.Children
.First
;
1441 while C
/= null loop
1442 Process
(Position
=> Cursor
'(Parent.Container, Node => C));
1445 end Iterate_Children;
1447 procedure Iterate_Children
1448 (Container : Tree_Access;
1449 Subtree : Tree_Node_Access;
1450 Process : not null access procedure (Position : Cursor))
1452 Node : Tree_Node_Access;
1455 -- This is a helper function to recursively iterate over all the nodes
1456 -- in a subtree, in depth-first fashion. This particular helper just
1457 -- visits the children of this subtree, not the root of the subtree node
1458 -- itself. This is useful when starting from the ultimate root of the
1459 -- entire tree (see Iterate), as that root does not have an element.
1461 Node := Subtree.Children.First;
1462 while Node /= null loop
1463 Iterate_Subtree (Container, Node, Process);
1466 end Iterate_Children;
1468 function Iterate_Children
1471 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1473 C : constant Tree_Access := Container'Unrestricted_Access;
1475 if Checks and then Parent = No_Element then
1476 raise Constraint_Error with "Parent cursor has no element";
1479 if Checks and then Parent.Container /= C then
1480 raise Program_Error with "Parent cursor not in container";
1483 return It : constant Child_Iterator :=
1484 (Limited_Controlled with
1486 Subtree => Parent.Node)
1490 end Iterate_Children;
1492 ---------------------
1493 -- Iterate_Subtree --
1494 ---------------------
1496 function Iterate_Subtree
1498 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1500 C : constant Tree_Access := Position.Container;
1502 if Checks and then Position = No_Element then
1503 raise Constraint_Error with "Position cursor has no element";
1506 -- Implement Vet for multiway trees???
1507 -- pragma Assert (Vet (Position), "bad subtree cursor");
1509 return It : constant Subtree_Iterator :=
1510 (Limited_Controlled with
1512 Subtree => Position.Node)
1516 end Iterate_Subtree;
1518 procedure Iterate_Subtree
1520 Process : not null access procedure (Position : Cursor))
1522 Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
1524 if Checks and then Position = No_Element then
1525 raise Constraint_Error with "Position cursor has no element";
1528 if Is_Root (Position) then
1529 Iterate_Children (Position.Container, Position.Node, Process);
1531 Iterate_Subtree (Position.Container, Position.Node, Process);
1533 end Iterate_Subtree;
1535 procedure Iterate_Subtree
1536 (Container : Tree_Access;
1537 Subtree : Tree_Node_Access;
1538 Process : not null access procedure (Position : Cursor))
1541 -- This is a helper function to recursively iterate over all the nodes
1542 -- in a subtree, in depth-first fashion. It first visits the root of the
1543 -- subtree, then visits its children.
1545 Process (Cursor'(Container
, Subtree
));
1546 Iterate_Children
(Container
, Subtree
, Process
);
1547 end Iterate_Subtree
;
1553 overriding
function Last
(Object
: Child_Iterator
) return Cursor
is
1555 return Last_Child
(Cursor
'(Object.Container, Object.Subtree));
1562 function Last_Child (Parent : Cursor) return Cursor is
1563 Node : Tree_Node_Access;
1566 if Checks and then Parent = No_Element then
1567 raise Constraint_Error with "Parent cursor has no element";
1570 Node := Parent.Node.Children.Last;
1576 return (Parent.Container, Node);
1579 ------------------------
1580 -- Last_Child_Element --
1581 ------------------------
1583 function Last_Child_Element (Parent : Cursor) return Element_Type is
1585 return Element (Last_Child (Parent));
1586 end Last_Child_Element;
1592 procedure Move (Target : in out Tree; Source : in out Tree) is
1593 Node : Tree_Node_Access;
1596 if Target'Address = Source'Address then
1600 TC_Check (Source.TC);
1602 Target.Clear; -- checks busy bit
1604 Target.Root.Children := Source.Root.Children;
1605 Source.Root.Children := Children_Type'(others => null);
1607 Node
:= Target
.Root
.Children
.First
;
1608 while Node
/= null loop
1609 Node
.Parent
:= Root_Node
(Target
);
1613 Target
.Count
:= Source
.Count
;
1622 (Object
: Subtree_Iterator
;
1623 Position
: Cursor
) return Cursor
1625 Node
: Tree_Node_Access
;
1628 if Position
.Container
= null then
1632 if Checks
and then Position
.Container
/= Object
.Container
then
1633 raise Program_Error
with
1634 "Position cursor of Next designates wrong tree";
1637 Node
:= Position
.Node
;
1639 if Node
.Children
.First
/= null then
1640 return Cursor
'(Object.Container, Node.Children.First);
1643 while Node /= Object.Subtree loop
1644 if Node.Next /= null then
1645 return Cursor'(Object
.Container
, Node
.Next
);
1648 Node
:= Node
.Parent
;
1655 (Object
: Child_Iterator
;
1656 Position
: Cursor
) return Cursor
1659 if Position
.Container
= null then
1663 if Checks
and then Position
.Container
/= Object
.Container
then
1664 raise Program_Error
with
1665 "Position cursor of Next designates wrong tree";
1668 return Next_Sibling
(Position
);
1675 function Next_Sibling
(Position
: Cursor
) return Cursor
is
1677 if Position
= No_Element
then
1681 if Position
.Node
.Next
= null then
1685 return Cursor
'(Position.Container, Position.Node.Next);
1688 procedure Next_Sibling (Position : in out Cursor) is
1690 Position := Next_Sibling (Position);
1697 function Node_Count (Container : Tree) return Count_Type is
1699 -- Container.Count is the number of nodes we have actually allocated. We
1700 -- cache the value specifically so this Node_Count operation can execute
1701 -- in O(1) time, which makes it behave similarly to how the Length
1702 -- selector function behaves for other containers.
1704 -- The cached node count value only describes the nodes we have
1705 -- allocated; the root node itself is not included in that count. The
1706 -- Node_Count operation returns a value that includes the root node
1707 -- (because the RM says so), so we must add 1 to our cached value.
1709 return 1 + Container.Count;
1716 function Parent (Position : Cursor) return Cursor is
1718 if Position = No_Element then
1722 if Position.Node.Parent = null then
1726 return Cursor'(Position
.Container
, Position
.Node
.Parent
);
1733 procedure Prepend_Child
1734 (Container
: in out Tree
;
1736 New_Item
: Element_Type
;
1737 Count
: Count_Type
:= 1)
1739 First
, Last
: Tree_Node_Access
;
1742 TC_Check
(Container
.TC
);
1744 if Checks
and then Parent
= No_Element
then
1745 raise Constraint_Error
with "Parent cursor has no element";
1748 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
1749 raise Program_Error
with "Parent cursor not in container";
1756 First
:= new Tree_Node_Type
'(Parent => Parent.Node,
1757 Element => New_Item,
1762 for J in Count_Type'(2) .. Count
loop
1764 -- Reclaim other nodes if Storage_Error???
1766 Last
.Next
:= new Tree_Node_Type
'(Parent => Parent.Node,
1768 Element => New_Item,
1777 Parent => Parent.Node,
1778 Before => Parent.Node.Children.First);
1780 -- In order for operation Node_Count to complete in O(1) time, we cache
1781 -- the count value. Here we increment the total count by the number of
1782 -- nodes we just inserted.
1784 Container.Count := Container.Count + Count;
1791 overriding function Previous
1792 (Object : Child_Iterator;
1793 Position : Cursor) return Cursor
1796 if Position.Container = null then
1800 if Checks and then Position.Container /= Object.Container then
1801 raise Program_Error with
1802 "Position cursor of Previous designates wrong tree";
1805 return Previous_Sibling (Position);
1808 ----------------------
1809 -- Previous_Sibling --
1810 ----------------------
1812 function Previous_Sibling (Position : Cursor) return Cursor is
1815 (if Position = No_Element then No_Element
1816 elsif Position.Node.Prev = null then No_Element
1817 else Cursor'(Position
.Container
, Position
.Node
.Prev
));
1818 end Previous_Sibling
;
1820 procedure Previous_Sibling
(Position
: in out Cursor
) is
1822 Position
:= Previous_Sibling
(Position
);
1823 end Previous_Sibling
;
1825 ----------------------
1826 -- Pseudo_Reference --
1827 ----------------------
1829 function Pseudo_Reference
1830 (Container
: aliased Tree
'Class) return Reference_Control_Type
1832 TC
: constant Tamper_Counts_Access
:= Container
.TC
'Unrestricted_Access;
1834 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
1837 end Pseudo_Reference
;
1843 procedure Query_Element
1845 Process
: not null access procedure (Element
: Element_Type
))
1847 T
: Tree
renames Position
.Container
.all'Unrestricted_Access.all;
1848 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
1850 if Checks
and then Position
= No_Element
then
1851 raise Constraint_Error
with "Position cursor has no element";
1854 if Checks
and then Is_Root
(Position
) then
1855 raise Program_Error
with "Position cursor designates root";
1858 Process
(Position
.Node
.Element
);
1866 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Tree
)
1868 use System
.Put_Images
;
1870 procedure Rec
(Position
: Cursor
);
1871 -- Recursive routine operating on cursors
1873 procedure Rec
(Position
: Cursor
) is
1874 First_Time
: Boolean := True;
1878 for X
in Iterate_Children
(V
, Position
) loop
1880 First_Time
:= False;
1885 Element_Type
'Put_Image (S
, Element
(X
));
1886 if Child_Count
(X
) > 0 then
1887 Simple_Array_Between
(S
);
1896 if First_Child
(Root
(V
)) = No_Element
then
1900 Rec
(First_Child
(Root
(V
)));
1909 (Stream
: not null access Root_Stream_Type
'Class;
1910 Container
: out Tree
)
1912 procedure Read_Children
(Subtree
: Tree_Node_Access
);
1914 function Read_Subtree
1915 (Parent
: Tree_Node_Access
) return Tree_Node_Access
;
1917 Total_Count
: Count_Type
'Base;
1918 -- Value read from the stream that says how many elements follow
1920 Read_Count
: Count_Type
'Base;
1921 -- Actual number of elements read from the stream
1927 procedure Read_Children
(Subtree
: Tree_Node_Access
) is
1928 pragma Assert
(Subtree
/= null);
1929 pragma Assert
(Subtree
.Children
.First
= null);
1930 pragma Assert
(Subtree
.Children
.Last
= null);
1932 Count
: Count_Type
'Base;
1933 -- Number of child subtrees
1938 Count_Type
'Read (Stream
, Count
);
1940 if Checks
and then Count
< 0 then
1941 raise Program_Error
with "attempt to read from corrupt stream";
1948 C
.First
:= Read_Subtree
(Parent
=> Subtree
);
1951 for J
in Count_Type
'(2) .. Count loop
1952 C.Last.Next := Read_Subtree (Parent => Subtree);
1953 C.Last.Next.Prev := C.Last;
1954 C.Last := C.Last.Next;
1957 -- Now that the allocation and reads have completed successfully, it
1958 -- is safe to link the children to their parent.
1960 Subtree.Children := C;
1967 function Read_Subtree
1968 (Parent : Tree_Node_Access) return Tree_Node_Access
1970 Subtree : constant Tree_Node_Access :=
1973 Element
=> Element_Type
'Input (Stream
),
1977 Read_Count
:= Read_Count
+ 1;
1979 Read_Children
(Subtree
);
1984 -- Start of processing for Read
1987 Container
.Clear
; -- checks busy bit
1989 Count_Type
'Read (Stream
, Total_Count
);
1991 if Checks
and then Total_Count
< 0 then
1992 raise Program_Error
with "attempt to read from corrupt stream";
1995 if Total_Count
= 0 then
2001 Read_Children
(Root_Node
(Container
));
2003 if Checks
and then Read_Count
/= Total_Count
then
2004 raise Program_Error
with "attempt to read from corrupt stream";
2007 Container
.Count
:= Total_Count
;
2011 (Stream
: not null access Root_Stream_Type
'Class;
2012 Position
: out Cursor
)
2015 raise Program_Error
with "attempt to read tree cursor from stream";
2019 (Stream
: not null access Root_Stream_Type
'Class;
2020 Item
: out Reference_Type
)
2023 raise Program_Error
with "attempt to stream reference";
2027 (Stream
: not null access Root_Stream_Type
'Class;
2028 Item
: out Constant_Reference_Type
)
2031 raise Program_Error
with "attempt to stream reference";
2039 (Container
: aliased in out Tree
;
2040 Position
: Cursor
) return Reference_Type
2043 if Checks
and then Position
.Container
= null then
2044 raise Constraint_Error
with
2045 "Position cursor has no element";
2048 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2050 raise Program_Error
with
2051 "Position cursor designates wrong container";
2054 if Checks
and then Position
.Node
= Root_Node
(Container
) then
2055 raise Program_Error
with "Position cursor designates root";
2058 -- Implement Vet for multiway tree???
2059 -- pragma Assert (Vet (Position),
2060 -- "Position cursor in Constant_Reference is bad");
2063 C
: Tree
renames Position
.Container
.all;
2064 TC
: constant Tamper_Counts_Access
:=
2065 C
.TC
'Unrestricted_Access;
2067 return R
: constant Reference_Type
:=
2068 (Element
=> Position
.Node
.Element
'Access,
2069 Control
=> (Controlled
with TC
))
2076 --------------------
2077 -- Remove_Subtree --
2078 --------------------
2080 procedure Remove_Subtree
(Subtree
: Tree_Node_Access
) is
2081 C
: Children_Type
renames Subtree
.Parent
.Children
;
2084 -- This is a utility operation to remove a subtree node from its
2085 -- parent's list of children.
2087 if C
.First
= Subtree
then
2088 pragma Assert
(Subtree
.Prev
= null);
2090 if C
.Last
= Subtree
then
2091 pragma Assert
(Subtree
.Next
= null);
2096 C
.First
:= Subtree
.Next
;
2097 C
.First
.Prev
:= null;
2100 elsif C
.Last
= Subtree
then
2101 pragma Assert
(Subtree
.Next
= null);
2102 C
.Last
:= Subtree
.Prev
;
2103 C
.Last
.Next
:= null;
2106 Subtree
.Prev
.Next
:= Subtree
.Next
;
2107 Subtree
.Next
.Prev
:= Subtree
.Prev
;
2111 ----------------------
2112 -- Replace_Element --
2113 ----------------------
2115 procedure Replace_Element
2116 (Container
: in out Tree
;
2118 New_Item
: Element_Type
)
2121 TE_Check
(Container
.TC
);
2123 if Checks
and then Position
= No_Element
then
2124 raise Constraint_Error
with "Position cursor has no element";
2127 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2129 raise Program_Error
with "Position cursor not in container";
2132 if Checks
and then Is_Root
(Position
) then
2133 raise Program_Error
with "Position cursor designates root";
2136 Position
.Node
.Element
:= New_Item
;
2137 end Replace_Element
;
2139 ------------------------------
2140 -- Reverse_Iterate_Children --
2141 ------------------------------
2143 procedure Reverse_Iterate_Children
2145 Process
: not null access procedure (Position
: Cursor
))
2147 C
: Tree_Node_Access
;
2148 Busy
: With_Busy
(Parent
.Container
.TC
'Unrestricted_Access);
2150 if Checks
and then Parent
= No_Element
then
2151 raise Constraint_Error
with "Parent cursor has no element";
2154 C
:= Parent
.Node
.Children
.Last
;
2155 while C
/= null loop
2156 Process
(Position
=> Cursor
'(Parent.Container, Node => C));
2159 end Reverse_Iterate_Children;
2165 function Root (Container : Tree) return Cursor is
2167 return (Container'Unrestricted_Access, Root_Node (Container));
2174 function Root_Node (Container : Tree) return Tree_Node_Access is
2175 type Root_Node_Access is access all Root_Node_Type;
2176 for Root_Node_Access'Storage_Size use 0;
2177 pragma Convention (C, Root_Node_Access);
2179 function To_Tree_Node_Access is
2180 new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access);
2182 -- Start of processing for Root_Node
2185 -- This is a utility function for converting from an access type that
2186 -- designates the distinguished root node to an access type designating
2187 -- a non-root node. The representation of a root node does not have an
2188 -- element, but is otherwise identical to a non-root node, so the
2189 -- conversion itself is safe.
2191 return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
2194 ---------------------
2195 -- Splice_Children --
2196 ---------------------
2198 procedure Splice_Children
2199 (Target : in out Tree;
2200 Target_Parent : Cursor;
2202 Source : in out Tree;
2203 Source_Parent : Cursor)
2208 TC_Check (Target.TC);
2209 TC_Check (Source.TC);
2211 if Checks and then Target_Parent = No_Element then
2212 raise Constraint_Error with "Target_Parent cursor has no element";
2215 if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
2218 with "Target_Parent cursor not in Target container";
2221 if Before /= No_Element then
2222 if Checks and then Before.Container /= Target'Unrestricted_Access then
2224 with "Before cursor not in Target container";
2227 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2228 raise Constraint_Error
2229 with "Before cursor not child of Target_Parent";
2233 if Checks and then Source_Parent = No_Element then
2234 raise Constraint_Error with "Source_Parent cursor has no element";
2237 if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
2240 with "Source_Parent cursor not in Source container";
2243 if Target'Address = Source'Address then
2244 if Target_Parent = Source_Parent then
2248 if Checks and then Is_Reachable (From => Target_Parent.Node,
2249 To => Source_Parent.Node)
2251 raise Constraint_Error
2252 with "Source_Parent is ancestor of Target_Parent";
2256 (Target_Parent => Target_Parent.Node,
2257 Before => Before.Node,
2258 Source_Parent => Source_Parent.Node);
2263 -- We cache the count of the nodes we have allocated, so that operation
2264 -- Node_Count can execute in O(1) time. But that means we must count the
2265 -- nodes in the subtree we remove from Source and insert into Target, in
2266 -- order to keep the count accurate.
2268 Count := Subtree_Node_Count (Source_Parent.Node);
2269 pragma Assert (Count >= 1);
2271 Count := Count - 1; -- because Source_Parent node does not move
2274 (Target_Parent => Target_Parent.Node,
2275 Before => Before.Node,
2276 Source_Parent => Source_Parent.Node);
2278 Source.Count := Source.Count - Count;
2279 Target.Count := Target.Count + Count;
2280 end Splice_Children;
2282 procedure Splice_Children
2283 (Container : in out Tree;
2284 Target_Parent : Cursor;
2286 Source_Parent : Cursor)
2289 TC_Check (Container.TC);
2291 if Checks and then Target_Parent = No_Element then
2292 raise Constraint_Error with "Target_Parent cursor has no element";
2296 Target_Parent.Container /= Container'Unrestricted_Access
2299 with "Target_Parent cursor not in container";
2302 if Before /= No_Element then
2303 if Checks and then Before.Container /= Container'Unrestricted_Access
2306 with "Before cursor not in container";
2309 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2310 raise Constraint_Error
2311 with "Before cursor not child of Target_Parent";
2315 if Checks and then Source_Parent = No_Element then
2316 raise Constraint_Error with "Source_Parent cursor has no element";
2320 Source_Parent.Container /= Container'Unrestricted_Access
2323 with "Source_Parent cursor not in container";
2326 if Target_Parent = Source_Parent then
2330 if Checks and then Is_Reachable (From => Target_Parent.Node,
2331 To => Source_Parent.Node)
2333 raise Constraint_Error
2334 with "Source_Parent is ancestor of Target_Parent";
2338 (Target_Parent => Target_Parent.Node,
2339 Before => Before.Node,
2340 Source_Parent => Source_Parent.Node);
2341 end Splice_Children;
2343 procedure Splice_Children
2344 (Target_Parent : Tree_Node_Access;
2345 Before : Tree_Node_Access;
2346 Source_Parent : Tree_Node_Access)
2348 CC : constant Children_Type := Source_Parent.Children;
2349 C : Tree_Node_Access;
2352 -- This is a utility operation to remove the children from
2353 -- Source parent and insert them into Target parent.
2355 Source_Parent.Children := Children_Type'(others => null);
2357 -- Fix up the Parent pointers of each child to designate
2358 -- its new Target parent.
2361 while C
/= null loop
2362 C
.Parent
:= Target_Parent
;
2369 Parent
=> Target_Parent
,
2371 end Splice_Children
;
2373 --------------------
2374 -- Splice_Subtree --
2375 --------------------
2377 procedure Splice_Subtree
2378 (Target
: in out Tree
;
2381 Source
: in out Tree
;
2382 Position
: in out Cursor
)
2384 Subtree_Count
: Count_Type
;
2387 TC_Check
(Target
.TC
);
2388 TC_Check
(Source
.TC
);
2390 if Checks
and then Parent
= No_Element
then
2391 raise Constraint_Error
with "Parent cursor has no element";
2394 if Checks
and then Parent
.Container
/= Target
'Unrestricted_Access then
2395 raise Program_Error
with "Parent cursor not in Target container";
2398 if Before
/= No_Element
then
2399 if Checks
and then Before
.Container
/= Target
'Unrestricted_Access then
2400 raise Program_Error
with "Before cursor not in Target container";
2403 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
2404 raise Constraint_Error
with "Before cursor not child of Parent";
2408 if Checks
and then Position
= No_Element
then
2409 raise Constraint_Error
with "Position cursor has no element";
2412 if Checks
and then Position
.Container
/= Source
'Unrestricted_Access then
2413 raise Program_Error
with "Position cursor not in Source container";
2416 if Checks
and then Is_Root
(Position
) then
2417 raise Program_Error
with "Position cursor designates root";
2420 if Target
'Address = Source
'Address then
2421 if Position
.Node
.Parent
= Parent
.Node
then
2422 if Position
.Node
= Before
.Node
then
2426 if Position
.Node
.Next
= Before
.Node
then
2432 Is_Reachable
(From
=> Parent
.Node
, To
=> Position
.Node
)
2434 raise Constraint_Error
with "Position is ancestor of Parent";
2437 Remove_Subtree
(Position
.Node
);
2439 Position
.Node
.Parent
:= Parent
.Node
;
2440 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2445 -- This is an unfortunate feature of this API: we must count the nodes
2446 -- in the subtree that we remove from the source tree, which is an O(n)
2447 -- operation. It would have been better if the Tree container did not
2448 -- have a Node_Count selector; a user that wants the number of nodes in
2449 -- the tree could simply call Subtree_Node_Count, with the understanding
2450 -- that such an operation is O(n).
2452 -- Of course, we could choose to implement the Node_Count selector as an
2453 -- O(n) operation, which would turn this splice operation into an O(1)
2456 Subtree_Count
:= Subtree_Node_Count
(Position
.Node
);
2457 pragma Assert
(Subtree_Count
<= Source
.Count
);
2459 Remove_Subtree
(Position
.Node
);
2460 Source
.Count
:= Source
.Count
- Subtree_Count
;
2462 Position
.Node
.Parent
:= Parent
.Node
;
2463 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2465 Target
.Count
:= Target
.Count
+ Subtree_Count
;
2467 Position
.Container
:= Target
'Unrestricted_Access;
2470 procedure Splice_Subtree
2471 (Container
: in out Tree
;
2477 TC_Check
(Container
.TC
);
2479 if Checks
and then Parent
= No_Element
then
2480 raise Constraint_Error
with "Parent cursor has no element";
2483 if Checks
and then Parent
.Container
/= Container
'Unrestricted_Access then
2484 raise Program_Error
with "Parent cursor not in container";
2487 if Before
/= No_Element
then
2488 if Checks
and then Before
.Container
/= Container
'Unrestricted_Access
2490 raise Program_Error
with "Before cursor not in container";
2493 if Checks
and then Before
.Node
.Parent
/= Parent
.Node
then
2494 raise Constraint_Error
with "Before cursor not child of Parent";
2498 if Checks
and then Position
= No_Element
then
2499 raise Constraint_Error
with "Position cursor has no element";
2502 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2504 raise Program_Error
with "Position cursor not in container";
2507 if Checks
and then Is_Root
(Position
) then
2509 -- Should this be PE instead? Need ARG confirmation. ???
2511 raise Constraint_Error
with "Position cursor designates root";
2514 if Position
.Node
.Parent
= Parent
.Node
then
2515 if Position
.Node
= Before
.Node
then
2519 if Position
.Node
.Next
= Before
.Node
then
2525 Is_Reachable
(From
=> Parent
.Node
, To
=> Position
.Node
)
2527 raise Constraint_Error
with "Position is ancestor of Parent";
2530 Remove_Subtree
(Position
.Node
);
2532 Position
.Node
.Parent
:= Parent
.Node
;
2533 Insert_Subtree_Node
(Position
.Node
, Parent
.Node
, Before
.Node
);
2536 ------------------------
2537 -- Subtree_Node_Count --
2538 ------------------------
2540 function Subtree_Node_Count
(Position
: Cursor
) return Count_Type
is
2542 if Position
= No_Element
then
2546 return Subtree_Node_Count
(Position
.Node
);
2547 end Subtree_Node_Count
;
2549 function Subtree_Node_Count
2550 (Subtree
: Tree_Node_Access
) return Count_Type
2552 Result
: Count_Type
;
2553 Node
: Tree_Node_Access
;
2557 Node
:= Subtree
.Children
.First
;
2558 while Node
/= null loop
2559 Result
:= Result
+ Subtree_Node_Count
(Node
);
2564 end Subtree_Node_Count
;
2571 (Container
: in out Tree
;
2575 TE_Check
(Container
.TC
);
2577 if Checks
and then I
= No_Element
then
2578 raise Constraint_Error
with "I cursor has no element";
2581 if Checks
and then I
.Container
/= Container
'Unrestricted_Access then
2582 raise Program_Error
with "I cursor not in container";
2585 if Checks
and then Is_Root
(I
) then
2586 raise Program_Error
with "I cursor designates root";
2589 if I
= J
then -- make this test sooner???
2593 if Checks
and then J
= No_Element
then
2594 raise Constraint_Error
with "J cursor has no element";
2597 if Checks
and then J
.Container
/= Container
'Unrestricted_Access then
2598 raise Program_Error
with "J cursor not in container";
2601 if Checks
and then Is_Root
(J
) then
2602 raise Program_Error
with "J cursor designates root";
2606 EI
: constant Element_Type
:= I
.Node
.Element
;
2609 I
.Node
.Element
:= J
.Node
.Element
;
2610 J
.Node
.Element
:= EI
;
2614 --------------------
2615 -- Update_Element --
2616 --------------------
2618 procedure Update_Element
2619 (Container
: in out Tree
;
2621 Process
: not null access procedure (Element
: in out Element_Type
))
2623 T
: Tree
renames Position
.Container
.all'Unrestricted_Access.all;
2624 Lock
: With_Lock
(T
.TC
'Unrestricted_Access);
2626 if Checks
and then Position
= No_Element
then
2627 raise Constraint_Error
with "Position cursor has no element";
2630 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
2632 raise Program_Error
with "Position cursor not in container";
2635 if Checks
and then Is_Root
(Position
) then
2636 raise Program_Error
with "Position cursor designates root";
2639 Process
(Position
.Node
.Element
);
2647 (Stream
: not null access Root_Stream_Type
'Class;
2650 procedure Write_Children
(Subtree
: Tree_Node_Access
);
2651 procedure Write_Subtree
(Subtree
: Tree_Node_Access
);
2653 --------------------
2654 -- Write_Children --
2655 --------------------
2657 procedure Write_Children
(Subtree
: Tree_Node_Access
) is
2658 CC
: Children_Type
renames Subtree
.Children
;
2659 C
: Tree_Node_Access
;
2662 Count_Type
'Write (Stream
, Child_Count
(CC
));
2665 while C
/= null loop
2675 procedure Write_Subtree
(Subtree
: Tree_Node_Access
) is
2677 Element_Type
'Output (Stream
, Subtree
.Element
);
2678 Write_Children
(Subtree
);
2681 -- Start of processing for Write
2684 Count_Type
'Write (Stream
, Container
.Count
);
2686 if Container
.Count
= 0 then
2690 Write_Children
(Root_Node
(Container
));
2694 (Stream
: not null access Root_Stream_Type
'Class;
2698 raise Program_Error
with "attempt to write tree cursor to stream";
2702 (Stream
: not null access Root_Stream_Type
'Class;
2703 Item
: Reference_Type
)
2706 raise Program_Error
with "attempt to stream reference";
2710 (Stream
: not null access Root_Stream_Type
'Class;
2711 Item
: Constant_Reference_Type
)
2714 raise Program_Error
with "attempt to stream reference";
2717 end Ada
.Containers
.Multiway_Trees
;