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-2011, 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;
32 with System; use type System.Address;
34 package body Ada.Containers.Multiway_Trees is
36 -----------------------
37 -- Local Subprograms --
38 -----------------------
40 function Root_Node (Container : Tree) return Tree_Node_Access;
42 procedure Deallocate_Node is
43 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
45 procedure Deallocate_Children
46 (Subtree : Tree_Node_Access;
47 Count : in out Count_Type);
49 procedure Deallocate_Subtree
50 (Subtree : in out Tree_Node_Access;
51 Count : in out Count_Type);
53 function Equal_Children
54 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
56 function Equal_Subtree
57 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
59 procedure Iterate_Children
60 (Container : Tree_Access;
61 Subtree : Tree_Node_Access;
62 Process : not null access procedure (Position : Cursor));
64 procedure Iterate_Subtree
65 (Container : Tree_Access;
66 Subtree : Tree_Node_Access;
67 Process : not null access procedure (Position : Cursor));
69 procedure Copy_Children
70 (Source : Children_Type;
71 Parent : Tree_Node_Access;
72 Count : in out Count_Type);
74 procedure Copy_Subtree
75 (Source : Tree_Node_Access;
76 Parent : Tree_Node_Access;
77 Target : out Tree_Node_Access;
78 Count : in out Count_Type);
80 function Find_In_Children
81 (Subtree : Tree_Node_Access;
82 Item : Element_Type) return Tree_Node_Access;
84 function Find_In_Subtree
85 (Subtree : Tree_Node_Access;
86 Item : Element_Type) return Tree_Node_Access;
88 function Child_Count (Children : Children_Type) return Count_Type;
90 function Subtree_Node_Count
91 (Subtree : Tree_Node_Access) return Count_Type;
93 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
95 procedure Remove_Subtree (Subtree : Tree_Node_Access);
97 procedure Insert_Subtree_Node
98 (Subtree : Tree_Node_Access;
99 Parent : Tree_Node_Access;
100 Before : Tree_Node_Access);
102 procedure Insert_Subtree_List
103 (First : Tree_Node_Access;
104 Last : Tree_Node_Access;
105 Parent : Tree_Node_Access;
106 Before : Tree_Node_Access);
108 procedure Splice_Children
109 (Target_Parent : Tree_Node_Access;
110 Before : Tree_Node_Access;
111 Source_Parent : Tree_Node_Access);
117 function "=" (Left, Right : Tree) return Boolean is
119 if Left'Address = Right'Address then
123 return Equal_Children (Root_Node (Left), Root_Node (Right));
130 procedure Adjust (Container : in out Tree) is
131 Source : constant Children_Type := Container.Root.Children;
132 Source_Count : constant Count_Type := Container.Count;
133 Target_Count : Count_Type;
136 -- We first restore the target container to its default-initialized
137 -- state, before we attempt any allocation, to ensure that invariants
138 -- are preserved in the event that the allocation fails.
140 Container.Root.Children := Children_Type'(others => null);
143 Container.Count := 0;
145 -- Copy_Children returns a count of the number of nodes that it
146 -- allocates, but it works by incrementing the value that is passed
147 -- in. We must therefore initialize the count value before calling
152 -- Now we attempt the allocation of subtrees. The invariants are
153 -- satisfied even if the allocation fails.
155 Copy_Children (Source, Root_Node (Container), Target_Count);
156 pragma Assert (Target_Count = Source_Count);
158 Container.Count := Source_Count;
165 function Ancestor_Find
167 Item : Element_Type) return Cursor
169 R, N : Tree_Node_Access;
172 if Position = No_Element then
173 raise Constraint_Error with "Position cursor has no element";
176 -- Commented-out pending official ruling from ARG. ???
178 -- if Position.Container /= Container'Unrestricted_Access then
179 -- raise Program_Error with "Position cursor not in container";
182 -- AI-0136 says to raise PE if Position equals the root node. This does
183 -- not seem correct, as this value is just the limiting condition of the
184 -- search. For now we omit this check, pending a ruling from the ARG.???
186 -- if Is_Root (Position) then
187 -- raise Program_Error with "Position cursor designates root";
190 R := Root_Node (Position.Container.all);
193 if N.Element = Item then
194 return Cursor'(Position.Container, N);
207 procedure Append_Child
208 (Container : in out Tree;
210 New_Item : Element_Type;
211 Count : Count_Type := 1)
213 First, Last : Tree_Node_Access;
216 if Parent = No_Element then
217 raise Constraint_Error with "Parent cursor has no element";
220 if Parent.Container /= Container'Unrestricted_Access then
221 raise Program_Error with "Parent cursor not in container";
228 if Container.Busy > 0 then
230 with "attempt to tamper with cursors (tree is busy)";
233 First := new Tree_Node_Type'(Parent => Parent.Node,
239 for J in Count_Type'(2) .. Count loop
241 -- Reclaim other nodes if Storage_Error. ???
243 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
254 Parent => Parent.Node,
255 Before => null); -- null means "insert at end of list"
257 -- In order for operation Node_Count to complete in O(1) time, we cache
258 -- the count value. Here we increment the total count by the number of
259 -- nodes we just inserted.
261 Container.Count := Container.Count + Count;
268 procedure Assign (Target : in out Tree; Source : Tree) is
269 Source_Count : constant Count_Type := Source.Count;
270 Target_Count : Count_Type;
273 if Target'Address = Source'Address then
277 Target.Clear; -- checks busy bit
279 -- Copy_Children returns the number of nodes that it allocates, but it
280 -- does this by incrementing the count value passed in, so we must
281 -- initialize the count before calling Copy_Children.
285 -- Note that Copy_Children inserts the newly-allocated children into
286 -- their parent list only after the allocation of all the children has
287 -- succeeded. This preserves invariants even if the allocation fails.
289 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
290 pragma Assert (Target_Count = Source_Count);
292 Target.Count := Source_Count;
299 function Child_Count (Parent : Cursor) return Count_Type is
301 if Parent = No_Element then
304 return Child_Count (Parent.Node.Children);
308 function Child_Count (Children : Children_Type) return Count_Type is
310 Node : Tree_Node_Access;
314 Node := Children.First;
315 while Node /= null loop
316 Result := Result + 1;
327 function Child_Depth (Parent, Child : Cursor) return Count_Type is
329 N : Tree_Node_Access;
332 if Parent = No_Element then
333 raise Constraint_Error with "Parent cursor has no element";
336 if Child = No_Element then
337 raise Constraint_Error with "Child cursor has no element";
340 if Parent.Container /= Child.Container then
341 raise Program_Error with "Parent and Child in different containers";
346 while N /= Parent.Node loop
347 Result := Result + 1;
351 raise Program_Error with "Parent is not ancestor of Child";
362 procedure Clear (Container : in out Tree) is
363 Container_Count, Children_Count : Count_Type;
366 if Container.Busy > 0 then
368 with "attempt to tamper with cursors (tree is busy)";
371 -- We first set the container count to 0, in order to preserve
372 -- invariants in case the deallocation fails. (This works because
373 -- Deallocate_Children immediately removes the children from their
374 -- parent, and then does the actual deallocation.)
376 Container_Count := Container.Count;
377 Container.Count := 0;
379 -- Deallocate_Children returns the number of nodes that it deallocates,
380 -- but it does this by incrementing the count value that is passed in,
381 -- so we must first initialize the count return value before calling it.
385 -- See comment above. Deallocate_Children immediately removes the
386 -- children list from their parent node (here, the root of the tree),
387 -- and only after that does it attempt the actual deallocation. So even
388 -- if the deallocation fails, the representation invariants for the tree
391 Deallocate_Children (Root_Node (Container), Children_Count);
392 pragma Assert (Children_Count = Container_Count);
401 Item : Element_Type) return Boolean
404 return Find (Container, Item) /= No_Element;
411 function Copy (Source : Tree) return Tree is
413 return Target : Tree do
415 (Source => Source.Root.Children,
416 Parent => Root_Node (Target),
417 Count => Target.Count);
419 pragma Assert (Target.Count = Source.Count);
427 procedure Copy_Children
428 (Source : Children_Type;
429 Parent : Tree_Node_Access;
430 Count : in out Count_Type)
432 pragma Assert (Parent /= null);
433 pragma Assert (Parent.Children.First = null);
434 pragma Assert (Parent.Children.Last = null);
437 C : Tree_Node_Access;
440 -- We special-case the first allocation, in order to establish the
441 -- representation invariants for type Children_Type.
457 -- The representation invariants for the Children_Type list have been
458 -- established, so we can now copy the remaining children of Source.
465 Target => CC.Last.Next,
468 CC.Last.Next.Prev := CC.Last;
469 CC.Last := CC.Last.Next;
474 -- Add the newly-allocated children to their parent list only after the
475 -- allocation has succeeded, so as to preserve invariants of the parent.
477 Parent.Children := CC;
484 procedure Copy_Subtree
485 (Target : in out Tree;
490 Target_Subtree : Tree_Node_Access;
491 Target_Count : Count_Type;
494 if Parent = No_Element then
495 raise Constraint_Error with "Parent cursor has no element";
498 if Parent.Container /= Target'Unrestricted_Access then
499 raise Program_Error with "Parent cursor not in container";
502 if Before /= No_Element then
503 if Before.Container /= Target'Unrestricted_Access then
504 raise Program_Error with "Before cursor not in container";
507 if Before.Node.Parent /= Parent.Node then
508 raise Constraint_Error with "Before cursor not child of Parent";
512 if Source = No_Element then
516 if Is_Root (Source) then
517 raise Constraint_Error with "Source cursor designates root";
520 -- Copy_Subtree returns a count of the number of nodes that it
521 -- allocates, but it works by incrementing the value that is passed
522 -- in. We must therefore initialize the count value before calling
528 (Source => Source.Node,
529 Parent => Parent.Node,
530 Target => Target_Subtree,
531 Count => Target_Count);
533 pragma Assert (Target_Subtree /= null);
534 pragma Assert (Target_Subtree.Parent = Parent.Node);
535 pragma Assert (Target_Count >= 1);
538 (Subtree => Target_Subtree,
539 Parent => Parent.Node,
540 Before => Before.Node);
542 -- In order for operation Node_Count to complete in O(1) time, we cache
543 -- the count value. Here we increment the total count by the number of
544 -- nodes we just inserted.
546 Target.Count := Target.Count + Target_Count;
549 procedure Copy_Subtree
550 (Source : Tree_Node_Access;
551 Parent : Tree_Node_Access;
552 Target : out Tree_Node_Access;
553 Count : in out Count_Type)
556 Target := new Tree_Node_Type'(Element => Source.Element,
563 (Source => Source.Children,
568 -------------------------
569 -- Deallocate_Children --
570 -------------------------
572 procedure Deallocate_Children
573 (Subtree : Tree_Node_Access;
574 Count : in out Count_Type)
576 pragma Assert (Subtree /= null);
578 CC : Children_Type := Subtree.Children;
579 C : Tree_Node_Access;
582 -- We immediately remove the children from their parent, in order to
583 -- preserve invariants in case the deallocation fails.
585 Subtree.Children := Children_Type'(others => null);
587 while CC.First /= null loop
591 Deallocate_Subtree (C, Count);
593 end Deallocate_Children;
595 ------------------------
596 -- Deallocate_Subtree --
597 ------------------------
599 procedure Deallocate_Subtree
600 (Subtree : in out Tree_Node_Access;
601 Count : in out Count_Type)
604 Deallocate_Children (Subtree, Count);
605 Deallocate_Node (Subtree);
607 end Deallocate_Subtree;
609 ---------------------
610 -- Delete_Children --
611 ---------------------
613 procedure Delete_Children
614 (Container : in out Tree;
620 if Parent = No_Element then
621 raise Constraint_Error with "Parent cursor has no element";
624 if Parent.Container /= Container'Unrestricted_Access then
625 raise Program_Error with "Parent cursor not in container";
628 if Container.Busy > 0 then
630 with "attempt to tamper with cursors (tree is busy)";
633 -- Deallocate_Children returns a count of the number of nodes that it
634 -- deallocates, but it works by incrementing the value that is passed
635 -- in. We must therefore initialize the count value before calling
636 -- Deallocate_Children.
640 Deallocate_Children (Parent.Node, Count);
641 pragma Assert (Count <= Container.Count);
643 Container.Count := Container.Count - Count;
650 procedure Delete_Leaf
651 (Container : in out Tree;
652 Position : in out Cursor)
654 X : Tree_Node_Access;
657 if Position = No_Element then
658 raise Constraint_Error with "Position cursor has no element";
661 if Position.Container /= Container'Unrestricted_Access then
662 raise Program_Error with "Position cursor not in container";
665 if Is_Root (Position) then
666 raise Program_Error with "Position cursor designates root";
669 if not Is_Leaf (Position) then
670 raise Constraint_Error with "Position cursor does not designate leaf";
673 if Container.Busy > 0 then
675 with "attempt to tamper with cursors (tree is busy)";
679 Position := No_Element;
681 -- Restore represention invariants before attempting the actual
685 Container.Count := Container.Count - 1;
687 -- It is now safe to attempt the deallocation. This leaf node has been
688 -- disassociated from the tree, so even if the deallocation fails,
689 -- representation invariants will remain satisfied.
698 procedure Delete_Subtree
699 (Container : in out Tree;
700 Position : in out Cursor)
702 X : Tree_Node_Access;
706 if Position = No_Element then
707 raise Constraint_Error with "Position cursor has no element";
710 if Position.Container /= Container'Unrestricted_Access then
711 raise Program_Error with "Position cursor not in container";
714 if Is_Root (Position) then
715 raise Program_Error with "Position cursor designates root";
718 if Container.Busy > 0 then
720 with "attempt to tamper with cursors (tree is busy)";
724 Position := No_Element;
726 -- Here is one case where a deallocation failure can result in the
727 -- violation of a representation invariant. We disassociate the subtree
728 -- from the tree now, but we only decrement the total node count after
729 -- we attempt the deallocation. However, if the deallocation fails, the
730 -- total node count will not get decremented.
732 -- One way around this dilemma is to count the nodes in the subtree
733 -- before attempt to delete the subtree, but that is an O(n) operation,
734 -- so it does not seem worth it.
736 -- Perhaps this is much ado about nothing, since the only way
737 -- deallocation can fail is if Controlled Finalization fails: this
738 -- propagates Program_Error so all bets are off anyway. ???
742 -- Deallocate_Subtree returns a count of the number of nodes that it
743 -- deallocates, but it works by incrementing the value that is passed
744 -- in. We must therefore initialize the count value before calling
745 -- Deallocate_Subtree.
749 Deallocate_Subtree (X, Count);
750 pragma Assert (Count <= Container.Count);
752 -- See comments above. We would prefer to do this sooner, but there's no
753 -- way to satisfy that goal without a potentially severe execution
756 Container.Count := Container.Count - Count;
763 function Depth (Position : Cursor) return Count_Type is
765 N : Tree_Node_Access;
772 Result := Result + 1;
782 function Element (Position : Cursor) return Element_Type is
784 if Position.Container = null then
785 raise Constraint_Error with "Position cursor has no element";
788 if Position.Node = Root_Node (Position.Container.all) then
789 raise Program_Error with "Position cursor designates root";
792 return Position.Node.Element;
799 function Equal_Children
800 (Left_Subtree : Tree_Node_Access;
801 Right_Subtree : Tree_Node_Access) return Boolean
803 Left_Children : Children_Type renames Left_Subtree.Children;
804 Right_Children : Children_Type renames Right_Subtree.Children;
806 L, R : Tree_Node_Access;
809 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
813 L := Left_Children.First;
814 R := Right_Children.First;
816 if not Equal_Subtree (L, R) then
831 function Equal_Subtree
832 (Left_Position : Cursor;
833 Right_Position : Cursor) return Boolean
836 if Left_Position = No_Element then
837 raise Constraint_Error with "Left cursor has no element";
840 if Right_Position = No_Element then
841 raise Constraint_Error with "Right cursor has no element";
844 if Left_Position = Right_Position then
848 if Is_Root (Left_Position) then
849 if not Is_Root (Right_Position) then
853 return Equal_Children (Left_Position.Node, Right_Position.Node);
856 if Is_Root (Right_Position) then
860 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
863 function Equal_Subtree
864 (Left_Subtree : Tree_Node_Access;
865 Right_Subtree : Tree_Node_Access) return Boolean
868 if Left_Subtree.Element /= Right_Subtree.Element then
872 return Equal_Children (Left_Subtree, Right_Subtree);
881 Item : Element_Type) return Cursor
883 N : constant Tree_Node_Access :=
884 Find_In_Children (Root_Node (Container), Item);
891 return Cursor'(Container'Unrestricted_Access, N);
898 function First_Child (Parent : Cursor) return Cursor is
899 Node : Tree_Node_Access;
902 if Parent = No_Element then
903 raise Constraint_Error with "Parent cursor has no element";
906 Node := Parent.Node.Children.First;
912 return Cursor'(Parent.Container, Node);
915 -------------------------
916 -- First_Child_Element --
917 -------------------------
919 function First_Child_Element (Parent : Cursor) return Element_Type is
921 return Element (First_Child (Parent));
922 end First_Child_Element;
924 ----------------------
925 -- Find_In_Children --
926 ----------------------
928 function Find_In_Children
929 (Subtree : Tree_Node_Access;
930 Item : Element_Type) return Tree_Node_Access
932 N, Result : Tree_Node_Access;
935 N := Subtree.Children.First;
937 Result := Find_In_Subtree (N, Item);
939 if Result /= null then
947 end Find_In_Children;
949 ---------------------
950 -- Find_In_Subtree --
951 ---------------------
953 function Find_In_Subtree
955 Item : Element_Type) return Cursor
957 Result : Tree_Node_Access;
960 if Position = No_Element then
961 raise Constraint_Error with "Position cursor has no element";
964 -- Commented out pending official ruling by ARG. ???
966 -- if Position.Container /= Container'Unrestricted_Access then
967 -- raise Program_Error with "Position cursor not in container";
970 if Is_Root (Position) then
971 Result := Find_In_Children (Position.Node, Item);
974 Result := Find_In_Subtree (Position.Node, Item);
977 if Result = null then
981 return Cursor'(Position.Container, Result);
984 function Find_In_Subtree
985 (Subtree : Tree_Node_Access;
986 Item : Element_Type) return Tree_Node_Access
989 if Subtree.Element = Item then
993 return Find_In_Children (Subtree, Item);
1000 function Has_Element (Position : Cursor) return Boolean is
1002 if Position = No_Element then
1006 return Position.Node.Parent /= null;
1013 procedure Insert_Child
1014 (Container : in out Tree;
1017 New_Item : Element_Type;
1018 Count : Count_Type := 1)
1021 pragma Unreferenced (Position);
1024 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1027 procedure Insert_Child
1028 (Container : in out Tree;
1031 New_Item : Element_Type;
1032 Position : out Cursor;
1033 Count : Count_Type := 1)
1035 Last : Tree_Node_Access;
1038 if Parent = No_Element then
1039 raise Constraint_Error with "Parent cursor has no element";
1042 if Parent.Container /= Container'Unrestricted_Access then
1043 raise Program_Error with "Parent cursor not in container";
1046 if Before /= No_Element then
1047 if Before.Container /= Container'Unrestricted_Access then
1048 raise Program_Error with "Before cursor not in container";
1051 if Before.Node.Parent /= Parent.Node then
1052 raise Constraint_Error with "Parent cursor not parent of Before";
1057 Position := No_Element; -- Need ruling from ARG ???
1061 if Container.Busy > 0 then
1063 with "attempt to tamper with cursors (tree is busy)";
1066 Position.Container := Parent.Container;
1067 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1068 Element => New_Item,
1071 Last := Position.Node;
1073 for J in Count_Type'(2) .. Count loop
1075 -- Reclaim other nodes if Storage_Error. ???
1077 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1079 Element => New_Item,
1086 (First => Position.Node,
1088 Parent => Parent.Node,
1089 Before => Before.Node);
1091 -- In order for operation Node_Count to complete in O(1) time, we cache
1092 -- the count value. Here we increment the total count by the number of
1093 -- nodes we just inserted.
1095 Container.Count := Container.Count + Count;
1098 procedure Insert_Child
1099 (Container : in out Tree;
1102 Position : out Cursor;
1103 Count : Count_Type := 1)
1105 Last : Tree_Node_Access;
1108 if Parent = No_Element then
1109 raise Constraint_Error with "Parent cursor has no element";
1112 if Parent.Container /= Container'Unrestricted_Access then
1113 raise Program_Error with "Parent cursor not in container";
1116 if Before /= No_Element then
1117 if Before.Container /= Container'Unrestricted_Access then
1118 raise Program_Error with "Before cursor not in container";
1121 if Before.Node.Parent /= Parent.Node then
1122 raise Constraint_Error with "Parent cursor not parent of Before";
1127 Position := No_Element; -- Need ruling from ARG ???
1131 if Container.Busy > 0 then
1133 with "attempt to tamper with cursors (tree is busy)";
1136 Position.Container := Parent.Container;
1137 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1141 Last := Position.Node;
1143 for J in Count_Type'(2) .. Count loop
1145 -- Reclaim other nodes if Storage_Error. ???
1147 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1156 (First => Position.Node,
1158 Parent => Parent.Node,
1159 Before => Before.Node);
1161 -- In order for operation Node_Count to complete in O(1) time, we cache
1162 -- the count value. Here we increment the total count by the number of
1163 -- nodes we just inserted.
1165 Container.Count := Container.Count + Count;
1168 -------------------------
1169 -- Insert_Subtree_List --
1170 -------------------------
1172 procedure Insert_Subtree_List
1173 (First : Tree_Node_Access;
1174 Last : Tree_Node_Access;
1175 Parent : Tree_Node_Access;
1176 Before : Tree_Node_Access)
1178 pragma Assert (Parent /= null);
1179 C : Children_Type renames Parent.Children;
1182 -- This is a simple utility operation to insert a list of nodes (from
1183 -- First..Last) as children of Parent. The Before node specifies where
1184 -- the new children should be inserted relative to the existing
1187 if First = null then
1188 pragma Assert (Last = null);
1192 pragma Assert (Last /= null);
1193 pragma Assert (Before = null or else Before.Parent = Parent);
1195 if C.First = null then
1197 C.First.Prev := null;
1199 C.Last.Next := null;
1201 elsif Before = null then -- means "insert after existing nodes"
1202 C.Last.Next := First;
1203 First.Prev := C.Last;
1205 C.Last.Next := null;
1207 elsif Before = C.First then
1208 Last.Next := C.First;
1209 C.First.Prev := Last;
1211 C.First.Prev := null;
1214 Before.Prev.Next := First;
1215 First.Prev := Before.Prev;
1216 Last.Next := Before;
1217 Before.Prev := Last;
1219 end Insert_Subtree_List;
1221 -------------------------
1222 -- Insert_Subtree_Node --
1223 -------------------------
1225 procedure Insert_Subtree_Node
1226 (Subtree : Tree_Node_Access;
1227 Parent : Tree_Node_Access;
1228 Before : Tree_Node_Access)
1231 -- This is a simple wrapper operation to insert a single child into the
1232 -- Parent's children list.
1239 end Insert_Subtree_Node;
1245 function Is_Empty (Container : Tree) return Boolean is
1247 return Container.Root.Children.First = null;
1254 function Is_Leaf (Position : Cursor) return Boolean is
1256 if Position = No_Element then
1260 return Position.Node.Children.First = null;
1267 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1268 pragma Assert (From /= null);
1269 pragma Assert (To /= null);
1271 N : Tree_Node_Access;
1275 while N /= null loop
1290 function Is_Root (Position : Cursor) return Boolean is
1292 if Position.Container = null then
1296 return Position = Root (Position.Container.all);
1305 Process : not null access procedure (Position : Cursor))
1307 T : Tree renames Container'Unrestricted_Access.all;
1308 B : Integer renames T.Busy;
1314 (Container => Container'Unrestricted_Access,
1315 Subtree => Root_Node (Container),
1316 Process => Process);
1326 ----------------------
1327 -- Iterate_Children --
1328 ----------------------
1330 procedure Iterate_Children
1332 Process : not null access procedure (Position : Cursor))
1335 if Parent = No_Element then
1336 raise Constraint_Error with "Parent cursor has no element";
1340 B : Integer renames Parent.Container.Busy;
1341 C : Tree_Node_Access;
1346 C := Parent.Node.Children.First;
1347 while C /= null loop
1348 Process (Position => Cursor'(Parent.Container, Node => C));
1359 end Iterate_Children;
1361 procedure Iterate_Children
1362 (Container : Tree_Access;
1363 Subtree : Tree_Node_Access;
1364 Process : not null access procedure (Position : Cursor))
1366 Node : Tree_Node_Access;
1369 -- This is a helper function to recursively iterate over all the nodes
1370 -- in a subtree, in depth-first fashion. This particular helper just
1371 -- visits the children of this subtree, not the root of the subtree node
1372 -- itself. This is useful when starting from the ultimate root of the
1373 -- entire tree (see Iterate), as that root does not have an element.
1375 Node := Subtree.Children.First;
1376 while Node /= null loop
1377 Iterate_Subtree (Container, Node, Process);
1380 end Iterate_Children;
1382 ---------------------
1383 -- Iterate_Subtree --
1384 ---------------------
1386 procedure Iterate_Subtree
1388 Process : not null access procedure (Position : Cursor))
1391 if Position = No_Element then
1392 raise Constraint_Error with "Position cursor has no element";
1396 B : Integer renames Position.Container.Busy;
1401 if Is_Root (Position) then
1402 Iterate_Children (Position.Container, Position.Node, Process);
1405 Iterate_Subtree (Position.Container, Position.Node, Process);
1415 end Iterate_Subtree;
1417 procedure Iterate_Subtree
1418 (Container : Tree_Access;
1419 Subtree : Tree_Node_Access;
1420 Process : not null access procedure (Position : Cursor))
1423 -- This is a helper function to recursively iterate over all the nodes
1424 -- in a subtree, in depth-first fashion. It first visits the root of the
1425 -- subtree, then visits its children.
1427 Process (Cursor'(Container, Subtree));
1428 Iterate_Children (Container, Subtree, Process);
1429 end Iterate_Subtree;
1435 function Last_Child (Parent : Cursor) return Cursor is
1436 Node : Tree_Node_Access;
1439 if Parent = No_Element then
1440 raise Constraint_Error with "Parent cursor has no element";
1443 Node := Parent.Node.Children.Last;
1449 return (Parent.Container, Node);
1452 ------------------------
1453 -- Last_Child_Element --
1454 ------------------------
1456 function Last_Child_Element (Parent : Cursor) return Element_Type is
1458 return Element (Last_Child (Parent));
1459 end Last_Child_Element;
1465 procedure Move (Target : in out Tree; Source : in out Tree) is
1466 Node : Tree_Node_Access;
1469 if Target'Address = Source'Address then
1473 if Source.Busy > 0 then
1475 with "attempt to tamper with cursors of Source (tree is busy)";
1478 Target.Clear; -- checks busy bit
1480 Target.Root.Children := Source.Root.Children;
1481 Source.Root.Children := Children_Type'(others => null);
1483 Node := Target.Root.Children.First;
1484 while Node /= null loop
1485 Node.Parent := Root_Node (Target);
1489 Target.Count := Source.Count;
1497 function Next_Sibling (Position : Cursor) return Cursor is
1499 if Position = No_Element then
1503 if Position.Node.Next = null then
1507 return Cursor'(Position.Container, Position.Node.Next);
1510 procedure Next_Sibling (Position : in out Cursor) is
1512 Position := Next_Sibling (Position);
1519 function Node_Count (Container : Tree) return Count_Type is
1521 -- Container.Count is the number of nodes we have actually allocated. We
1522 -- cache the value specifically so this Node_Count operation can execute
1523 -- in O(1) time, which makes it behave similarly to how the Length
1524 -- selector function behaves for other containers.
1526 -- The cached node count value only describes the nodes we have
1527 -- allocated; the root node itself is not included in that count. The
1528 -- Node_Count operation returns a value that includes the root node
1529 -- (because the RM says so), so we must add 1 to our cached value.
1531 return 1 + Container.Count;
1538 function Parent (Position : Cursor) return Cursor is
1540 if Position = No_Element then
1544 if Position.Node.Parent = null then
1548 return Cursor'(Position.Container, Position.Node.Parent);
1555 procedure Prepend_Child
1556 (Container : in out Tree;
1558 New_Item : Element_Type;
1559 Count : Count_Type := 1)
1561 First, Last : Tree_Node_Access;
1564 if Parent = No_Element then
1565 raise Constraint_Error with "Parent cursor has no element";
1568 if Parent.Container /= Container'Unrestricted_Access then
1569 raise Program_Error with "Parent cursor not in container";
1576 if Container.Busy > 0 then
1578 with "attempt to tamper with cursors (tree is busy)";
1581 First := new Tree_Node_Type'(Parent => Parent.Node,
1582 Element => New_Item,
1587 for J in Count_Type'(2) .. Count loop
1589 -- Reclaim other nodes if Storage_Error. ???
1591 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1593 Element => New_Item,
1602 Parent => Parent.Node,
1603 Before => Parent.Node.Children.First);
1605 -- In order for operation Node_Count to complete in O(1) time, we cache
1606 -- the count value. Here we increment the total count by the number of
1607 -- nodes we just inserted.
1609 Container.Count := Container.Count + Count;
1612 ----------------------
1613 -- Previous_Sibling --
1614 ----------------------
1616 function Previous_Sibling (Position : Cursor) return Cursor is
1618 if Position = No_Element then
1622 if Position.Node.Prev = null then
1626 return Cursor'(Position.Container, Position.Node.Prev);
1627 end Previous_Sibling;
1629 procedure Previous_Sibling (Position : in out Cursor) is
1631 Position := Previous_Sibling (Position);
1632 end Previous_Sibling;
1638 procedure Query_Element
1640 Process : not null access procedure (Element : Element_Type))
1643 if Position = No_Element then
1644 raise Constraint_Error with "Position cursor has no element";
1647 if Is_Root (Position) then
1648 raise Program_Error with "Position cursor designates root";
1652 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1653 B : Integer renames T.Busy;
1654 L : Integer renames T.Lock;
1660 Process (Position.Node.Element);
1678 (Stream : not null access Root_Stream_Type'Class;
1679 Container : out Tree)
1681 procedure Read_Children (Subtree : Tree_Node_Access);
1683 function Read_Subtree
1684 (Parent : Tree_Node_Access) return Tree_Node_Access;
1686 Total_Count : Count_Type'Base;
1687 -- Value read from the stream that says how many elements follow
1689 Read_Count : Count_Type'Base;
1690 -- Actual number of elements read from the stream
1696 procedure Read_Children (Subtree : Tree_Node_Access) is
1697 pragma Assert (Subtree /= null);
1698 pragma Assert (Subtree.Children.First = null);
1699 pragma Assert (Subtree.Children.Last = null);
1701 Count : Count_Type'Base;
1702 -- Number of child subtrees
1707 Count_Type'Read (Stream, Count);
1710 raise Program_Error with "attempt to read from corrupt stream";
1717 C.First := Read_Subtree (Parent => Subtree);
1720 for J in Count_Type'(2) .. Count loop
1721 C.Last.Next := Read_Subtree (Parent => Subtree);
1722 C.Last.Next.Prev := C.Last;
1723 C.Last := C.Last.Next;
1726 -- Now that the allocation and reads have completed successfully, it
1727 -- is safe to link the children to their parent.
1729 Subtree.Children := C;
1736 function Read_Subtree
1737 (Parent : Tree_Node_Access) return Tree_Node_Access
1739 Subtree : constant Tree_Node_Access :=
1742 Element => Element_Type'Input (Stream),
1746 Read_Count := Read_Count + 1;
1748 Read_Children (Subtree);
1753 -- Start of processing for Read
1756 Container.Clear; -- checks busy bit
1758 Count_Type'Read (Stream, Total_Count);
1760 if Total_Count < 0 then
1761 raise Program_Error with "attempt to read from corrupt stream";
1764 if Total_Count = 0 then
1770 Read_Children (Root_Node (Container));
1772 if Read_Count /= Total_Count then
1773 raise Program_Error with "attempt to read from corrupt stream";
1776 Container.Count := Total_Count;
1780 (Stream : not null access Root_Stream_Type'Class;
1781 Position : out Cursor)
1784 raise Program_Error with "attempt to read tree cursor from stream";
1787 --------------------
1788 -- Remove_Subtree --
1789 --------------------
1791 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
1792 C : Children_Type renames Subtree.Parent.Children;
1795 -- This is a utility operation to remove a subtree
1796 -- node from its parent's list of children.
1798 if C.First = Subtree then
1799 pragma Assert (Subtree.Prev = null);
1801 if C.Last = Subtree then
1802 pragma Assert (Subtree.Next = null);
1807 C.First := Subtree.Next;
1808 C.First.Prev := null;
1811 elsif C.Last = Subtree then
1812 pragma Assert (Subtree.Next = null);
1813 C.Last := Subtree.Prev;
1814 C.Last.Next := null;
1817 Subtree.Prev.Next := Subtree.Next;
1818 Subtree.Next.Prev := Subtree.Prev;
1822 ----------------------
1823 -- Replace_Element --
1824 ----------------------
1826 procedure Replace_Element
1827 (Container : in out Tree;
1829 New_Item : Element_Type)
1832 if Position = No_Element then
1833 raise Constraint_Error with "Position cursor has no element";
1836 if Position.Container /= Container'Unrestricted_Access then
1837 raise Program_Error with "Position cursor not in container";
1840 if Is_Root (Position) then
1841 raise Program_Error with "Position cursor designates root";
1844 if Container.Lock > 0 then
1846 with "attempt to tamper with elements (tree is locked)";
1849 Position.Node.Element := New_Item;
1850 end Replace_Element;
1852 ------------------------------
1853 -- Reverse_Iterate_Children --
1854 ------------------------------
1856 procedure Reverse_Iterate_Children
1858 Process : not null access procedure (Position : Cursor))
1861 if Parent = No_Element then
1862 raise Constraint_Error with "Parent cursor has no element";
1866 B : Integer renames Parent.Container.Busy;
1867 C : Tree_Node_Access;
1872 C := Parent.Node.Children.Last;
1873 while C /= null loop
1874 Process (Position => Cursor'(Parent.Container, Node => C));
1885 end Reverse_Iterate_Children;
1891 function Root (Container : Tree) return Cursor is
1893 return (Container'Unrestricted_Access, Root_Node (Container));
1900 function Root_Node (Container : Tree) return Tree_Node_Access is
1901 type Root_Node_Access is access all Root_Node_Type;
1902 for Root_Node_Access'Storage_Size use 0;
1903 pragma Convention (C, Root_Node_Access);
1905 function To_Tree_Node_Access is
1906 new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access);
1908 -- Start of processing for Root_Node
1911 -- This is a utility function for converting from an access type that
1912 -- designates the distinguished root node to an access type designating
1913 -- a non-root node. The representation of a root node does not have an
1914 -- element, but is otherwise identical to a non-root node, so the
1915 -- conversion itself is safe.
1917 return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
1920 ---------------------
1921 -- Splice_Children --
1922 ---------------------
1924 procedure Splice_Children
1925 (Target : in out Tree;
1926 Target_Parent : Cursor;
1928 Source : in out Tree;
1929 Source_Parent : Cursor)
1934 if Target_Parent = No_Element then
1935 raise Constraint_Error with "Target_Parent cursor has no element";
1938 if Target_Parent.Container /= Target'Unrestricted_Access then
1940 with "Target_Parent cursor not in Target container";
1943 if Before /= No_Element then
1944 if Before.Container /= Target'Unrestricted_Access then
1946 with "Before cursor not in Target container";
1949 if Before.Node.Parent /= Target_Parent.Node then
1950 raise Constraint_Error
1951 with "Before cursor not child of Target_Parent";
1955 if Source_Parent = No_Element then
1956 raise Constraint_Error with "Source_Parent cursor has no element";
1959 if Source_Parent.Container /= Source'Unrestricted_Access then
1961 with "Source_Parent cursor not in Source container";
1964 if Target'Address = Source'Address then
1965 if Target_Parent = Source_Parent then
1969 if Target.Busy > 0 then
1971 with "attempt to tamper with cursors (Target tree is busy)";
1974 if Is_Reachable (From => Target_Parent.Node,
1975 To => Source_Parent.Node)
1977 raise Constraint_Error
1978 with "Source_Parent is ancestor of Target_Parent";
1982 (Target_Parent => Target_Parent.Node,
1983 Before => Before.Node,
1984 Source_Parent => Source_Parent.Node);
1989 if Target.Busy > 0 then
1991 with "attempt to tamper with cursors (Target tree is busy)";
1994 if Source.Busy > 0 then
1996 with "attempt to tamper with cursors (Source tree is busy)";
1999 -- We cache the count of the nodes we have allocated, so that operation
2000 -- Node_Count can execute in O(1) time. But that means we must count the
2001 -- nodes in the subtree we remove from Source and insert into Target, in
2002 -- order to keep the count accurate.
2004 Count := Subtree_Node_Count (Source_Parent.Node);
2005 pragma Assert (Count >= 1);
2007 Count := Count - 1; -- because Source_Parent node does not move
2010 (Target_Parent => Target_Parent.Node,
2011 Before => Before.Node,
2012 Source_Parent => Source_Parent.Node);
2014 Source.Count := Source.Count - Count;
2015 Target.Count := Target.Count + Count;
2016 end Splice_Children;
2018 procedure Splice_Children
2019 (Container : in out Tree;
2020 Target_Parent : Cursor;
2022 Source_Parent : Cursor)
2025 if Target_Parent = No_Element then
2026 raise Constraint_Error with "Target_Parent cursor has no element";
2029 if Target_Parent.Container /= Container'Unrestricted_Access then
2031 with "Target_Parent cursor not in container";
2034 if Before /= No_Element then
2035 if Before.Container /= Container'Unrestricted_Access then
2037 with "Before cursor not in container";
2040 if Before.Node.Parent /= Target_Parent.Node then
2041 raise Constraint_Error
2042 with "Before cursor not child of Target_Parent";
2046 if Source_Parent = No_Element then
2047 raise Constraint_Error with "Source_Parent cursor has no element";
2050 if Source_Parent.Container /= Container'Unrestricted_Access then
2052 with "Source_Parent cursor not in container";
2055 if Target_Parent = Source_Parent then
2059 if Container.Busy > 0 then
2061 with "attempt to tamper with cursors (tree is busy)";
2064 if Is_Reachable (From => Target_Parent.Node,
2065 To => Source_Parent.Node)
2067 raise Constraint_Error
2068 with "Source_Parent is ancestor of Target_Parent";
2072 (Target_Parent => Target_Parent.Node,
2073 Before => Before.Node,
2074 Source_Parent => Source_Parent.Node);
2075 end Splice_Children;
2077 procedure Splice_Children
2078 (Target_Parent : Tree_Node_Access;
2079 Before : Tree_Node_Access;
2080 Source_Parent : Tree_Node_Access)
2082 CC : constant Children_Type := Source_Parent.Children;
2083 C : Tree_Node_Access;
2086 -- This is a utility operation to remove the children from
2087 -- Source parent and insert them into Target parent.
2089 Source_Parent.Children := Children_Type'(others => null);
2091 -- Fix up the Parent pointers of each child to designate
2092 -- its new Target parent.
2095 while C /= null loop
2096 C.Parent := Target_Parent;
2103 Parent => Target_Parent,
2105 end Splice_Children;
2107 --------------------
2108 -- Splice_Subtree --
2109 --------------------
2111 procedure Splice_Subtree
2112 (Target : in out Tree;
2115 Source : in out Tree;
2116 Position : in out Cursor)
2118 Subtree_Count : Count_Type;
2121 if Parent = No_Element then
2122 raise Constraint_Error with "Parent cursor has no element";
2125 if Parent.Container /= Target'Unrestricted_Access then
2126 raise Program_Error with "Parent cursor not in Target container";
2129 if Before /= No_Element then
2130 if Before.Container /= Target'Unrestricted_Access then
2131 raise Program_Error with "Before cursor not in Target container";
2134 if Before.Node.Parent /= Parent.Node then
2135 raise Constraint_Error with "Before cursor not child of Parent";
2139 if Position = No_Element then
2140 raise Constraint_Error with "Position cursor has no element";
2143 if Position.Container /= Source'Unrestricted_Access then
2144 raise Program_Error with "Position cursor not in Source container";
2147 if Is_Root (Position) then
2148 raise Program_Error with "Position cursor designates root";
2151 if Target'Address = Source'Address then
2152 if Position.Node.Parent = Parent.Node then
2153 if Position.Node = Before.Node then
2157 if Position.Node.Next = Before.Node then
2162 if Target.Busy > 0 then
2164 with "attempt to tamper with cursors (Target tree is busy)";
2167 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2168 raise Constraint_Error with "Position is ancestor of Parent";
2171 Remove_Subtree (Position.Node);
2173 Position.Node.Parent := Parent.Node;
2174 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2179 if Target.Busy > 0 then
2181 with "attempt to tamper with cursors (Target tree is busy)";
2184 if Source.Busy > 0 then
2186 with "attempt to tamper with cursors (Source tree is busy)";
2189 -- This is an unfortunate feature of this API: we must count the nodes
2190 -- in the subtree that we remove from the source tree, which is an O(n)
2191 -- operation. It would have been better if the Tree container did not
2192 -- have a Node_Count selector; a user that wants the number of nodes in
2193 -- the tree could simply call Subtree_Node_Count, with the understanding
2194 -- that such an operation is O(n).
2196 -- Of course, we could choose to implement the Node_Count selector as an
2197 -- O(n) operation, which would turn this splice operation into an O(1)
2200 Subtree_Count := Subtree_Node_Count (Position.Node);
2201 pragma Assert (Subtree_Count <= Source.Count);
2203 Remove_Subtree (Position.Node);
2204 Source.Count := Source.Count - Subtree_Count;
2206 Position.Node.Parent := Parent.Node;
2207 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2209 Target.Count := Target.Count + Subtree_Count;
2211 Position.Container := Target'Unrestricted_Access;
2214 procedure Splice_Subtree
2215 (Container : in out Tree;
2221 if Parent = No_Element then
2222 raise Constraint_Error with "Parent cursor has no element";
2225 if Parent.Container /= Container'Unrestricted_Access then
2226 raise Program_Error with "Parent cursor not in container";
2229 if Before /= No_Element then
2230 if Before.Container /= Container'Unrestricted_Access then
2231 raise Program_Error with "Before cursor not in container";
2234 if Before.Node.Parent /= Parent.Node then
2235 raise Constraint_Error with "Before cursor not child of Parent";
2239 if Position = No_Element then
2240 raise Constraint_Error with "Position cursor has no element";
2243 if Position.Container /= Container'Unrestricted_Access then
2244 raise Program_Error with "Position cursor not in container";
2247 if Is_Root (Position) then
2249 -- Should this be PE instead? Need ARG confirmation. ???
2251 raise Constraint_Error with "Position cursor designates root";
2254 if Position.Node.Parent = Parent.Node then
2255 if Position.Node = Before.Node then
2259 if Position.Node.Next = Before.Node then
2264 if Container.Busy > 0 then
2266 with "attempt to tamper with cursors (tree is busy)";
2269 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2270 raise Constraint_Error with "Position is ancestor of Parent";
2273 Remove_Subtree (Position.Node);
2275 Position.Node.Parent := Parent.Node;
2276 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2279 ------------------------
2280 -- Subtree_Node_Count --
2281 ------------------------
2283 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2285 if Position = No_Element then
2289 return Subtree_Node_Count (Position.Node);
2290 end Subtree_Node_Count;
2292 function Subtree_Node_Count
2293 (Subtree : Tree_Node_Access) return Count_Type
2295 Result : Count_Type;
2296 Node : Tree_Node_Access;
2300 Node := Subtree.Children.First;
2301 while Node /= null loop
2302 Result := Result + Subtree_Node_Count (Node);
2307 end Subtree_Node_Count;
2314 (Container : in out Tree;
2318 if I = No_Element then
2319 raise Constraint_Error with "I cursor has no element";
2322 if I.Container /= Container'Unrestricted_Access then
2323 raise Program_Error with "I cursor not in container";
2327 raise Program_Error with "I cursor designates root";
2330 if I = J then -- make this test sooner???
2334 if J = No_Element then
2335 raise Constraint_Error with "J cursor has no element";
2338 if J.Container /= Container'Unrestricted_Access then
2339 raise Program_Error with "J cursor not in container";
2343 raise Program_Error with "J cursor designates root";
2346 if Container.Lock > 0 then
2348 with "attempt to tamper with elements (tree is locked)";
2352 EI : constant Element_Type := I.Node.Element;
2355 I.Node.Element := J.Node.Element;
2356 J.Node.Element := EI;
2360 --------------------
2361 -- Update_Element --
2362 --------------------
2364 procedure Update_Element
2365 (Container : in out Tree;
2367 Process : not null access procedure (Element : in out Element_Type))
2370 if Position = No_Element then
2371 raise Constraint_Error with "Position cursor has no element";
2374 if Position.Container /= Container'Unrestricted_Access then
2375 raise Program_Error with "Position cursor not in container";
2378 if Is_Root (Position) then
2379 raise Program_Error with "Position cursor designates root";
2383 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2384 B : Integer renames T.Busy;
2385 L : Integer renames T.Lock;
2391 Process (Position.Node.Element);
2409 (Stream : not null access Root_Stream_Type'Class;
2412 procedure Write_Children (Subtree : Tree_Node_Access);
2413 procedure Write_Subtree (Subtree : Tree_Node_Access);
2415 --------------------
2416 -- Write_Children --
2417 --------------------
2419 procedure Write_Children (Subtree : Tree_Node_Access) is
2420 CC : Children_Type renames Subtree.Children;
2421 C : Tree_Node_Access;
2424 Count_Type'Write (Stream, Child_Count (CC));
2427 while C /= null loop
2437 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2439 Element_Type'Output (Stream, Subtree.Element);
2440 Write_Children (Subtree);
2443 -- Start of processing for Write
2446 Count_Type'Write (Stream, Container.Count);
2448 if Container.Count = 0 then
2452 Write_Children (Root_Node (Container));
2456 (Stream : not null access Root_Stream_Type'Class;
2460 raise Program_Error with "attempt to write tree cursor to stream";
2463 end Ada.Containers.Multiway_Trees;