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 type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
38 Container : Tree_Access;
43 type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with
45 Container : Tree_Access;
49 overriding function First (Object : Iterator) return Cursor;
50 overriding function Next
52 Position : Cursor) return Cursor;
54 overriding function First (Object : Child_Iterator) return Cursor;
55 overriding function Next
56 (Object : Child_Iterator;
57 Position : Cursor) return Cursor;
59 overriding function Previous
60 (Object : Child_Iterator;
61 Position : Cursor) return Cursor;
63 overriding function Last (Object : Child_Iterator) return Cursor;
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 function Root_Node (Container : Tree) return Tree_Node_Access;
71 procedure Deallocate_Node is
72 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
74 procedure Deallocate_Children
75 (Subtree : Tree_Node_Access;
76 Count : in out Count_Type);
78 procedure Deallocate_Subtree
79 (Subtree : in out Tree_Node_Access;
80 Count : in out Count_Type);
82 function Equal_Children
83 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
85 function Equal_Subtree
86 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
88 procedure Iterate_Children
89 (Container : Tree_Access;
90 Subtree : Tree_Node_Access;
91 Process : not null access procedure (Position : Cursor));
93 procedure Iterate_Subtree
94 (Container : Tree_Access;
95 Subtree : Tree_Node_Access;
96 Process : not null access procedure (Position : Cursor));
98 procedure Copy_Children
99 (Source : Children_Type;
100 Parent : Tree_Node_Access;
101 Count : in out Count_Type);
103 procedure Copy_Subtree
104 (Source : Tree_Node_Access;
105 Parent : Tree_Node_Access;
106 Target : out Tree_Node_Access;
107 Count : in out Count_Type);
109 function Find_In_Children
110 (Subtree : Tree_Node_Access;
111 Item : Element_Type) return Tree_Node_Access;
113 function Find_In_Subtree
114 (Subtree : Tree_Node_Access;
115 Item : Element_Type) return Tree_Node_Access;
117 function Child_Count (Children : Children_Type) return Count_Type;
119 function Subtree_Node_Count
120 (Subtree : Tree_Node_Access) return Count_Type;
122 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
124 procedure Remove_Subtree (Subtree : Tree_Node_Access);
126 procedure Insert_Subtree_Node
127 (Subtree : Tree_Node_Access;
128 Parent : Tree_Node_Access;
129 Before : Tree_Node_Access);
131 procedure Insert_Subtree_List
132 (First : Tree_Node_Access;
133 Last : Tree_Node_Access;
134 Parent : Tree_Node_Access;
135 Before : Tree_Node_Access);
137 procedure Splice_Children
138 (Target_Parent : Tree_Node_Access;
139 Before : Tree_Node_Access;
140 Source_Parent : Tree_Node_Access);
146 function "=" (Left, Right : Tree) return Boolean is
148 if Left'Address = Right'Address then
152 return Equal_Children (Root_Node (Left), Root_Node (Right));
159 procedure Adjust (Container : in out Tree) is
160 Source : constant Children_Type := Container.Root.Children;
161 Source_Count : constant Count_Type := Container.Count;
162 Target_Count : Count_Type;
165 -- We first restore the target container to its default-initialized
166 -- state, before we attempt any allocation, to ensure that invariants
167 -- are preserved in the event that the allocation fails.
169 Container.Root.Children := Children_Type'(others => null);
172 Container.Count := 0;
174 -- Copy_Children returns a count of the number of nodes that it
175 -- allocates, but it works by incrementing the value that is passed
176 -- in. We must therefore initialize the count value before calling
181 -- Now we attempt the allocation of subtrees. The invariants are
182 -- satisfied even if the allocation fails.
184 Copy_Children (Source, Root_Node (Container), Target_Count);
185 pragma Assert (Target_Count = Source_Count);
187 Container.Count := Source_Count;
194 function Ancestor_Find
196 Item : Element_Type) return Cursor
198 R, N : Tree_Node_Access;
201 if Position = No_Element then
202 raise Constraint_Error with "Position cursor has no element";
205 -- Commented-out pending official ruling from ARG. ???
207 -- if Position.Container /= Container'Unrestricted_Access then
208 -- raise Program_Error with "Position cursor not in container";
211 -- AI-0136 says to raise PE if Position equals the root node. This does
212 -- not seem correct, as this value is just the limiting condition of the
213 -- search. For now we omit this check, pending a ruling from the ARG.???
215 -- if Is_Root (Position) then
216 -- raise Program_Error with "Position cursor designates root";
219 R := Root_Node (Position.Container.all);
222 if N.Element = Item then
223 return Cursor'(Position.Container, N);
236 procedure Append_Child
237 (Container : in out Tree;
239 New_Item : Element_Type;
240 Count : Count_Type := 1)
242 First, Last : Tree_Node_Access;
245 if Parent = No_Element then
246 raise Constraint_Error with "Parent cursor has no element";
249 if Parent.Container /= Container'Unrestricted_Access then
250 raise Program_Error with "Parent cursor not in container";
257 if Container.Busy > 0 then
259 with "attempt to tamper with cursors (tree is busy)";
262 First := new Tree_Node_Type'(Parent => Parent.Node,
268 for J in Count_Type'(2) .. Count loop
270 -- Reclaim other nodes if Storage_Error. ???
272 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
283 Parent => Parent.Node,
284 Before => null); -- null means "insert at end of list"
286 -- In order for operation Node_Count to complete in O(1) time, we cache
287 -- the count value. Here we increment the total count by the number of
288 -- nodes we just inserted.
290 Container.Count := Container.Count + Count;
297 procedure Assign (Target : in out Tree; Source : Tree) is
298 Source_Count : constant Count_Type := Source.Count;
299 Target_Count : Count_Type;
302 if Target'Address = Source'Address then
306 Target.Clear; -- checks busy bit
308 -- Copy_Children returns the number of nodes that it allocates, but it
309 -- does this by incrementing the count value passed in, so we must
310 -- initialize the count before calling Copy_Children.
314 -- Note that Copy_Children inserts the newly-allocated children into
315 -- their parent list only after the allocation of all the children has
316 -- succeeded. This preserves invariants even if the allocation fails.
318 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
319 pragma Assert (Target_Count = Source_Count);
321 Target.Count := Source_Count;
328 function Child_Count (Parent : Cursor) return Count_Type is
330 return (if Parent = No_Element
331 then 0 else Child_Count (Parent.Node.Children));
334 function Child_Count (Children : Children_Type) return Count_Type is
336 Node : Tree_Node_Access;
340 Node := Children.First;
341 while Node /= null loop
342 Result := Result + 1;
353 function Child_Depth (Parent, Child : Cursor) return Count_Type is
355 N : Tree_Node_Access;
358 if Parent = No_Element then
359 raise Constraint_Error with "Parent cursor has no element";
362 if Child = No_Element then
363 raise Constraint_Error with "Child cursor has no element";
366 if Parent.Container /= Child.Container then
367 raise Program_Error with "Parent and Child in different containers";
372 while N /= Parent.Node loop
373 Result := Result + 1;
377 raise Program_Error with "Parent is not ancestor of Child";
388 procedure Clear (Container : in out Tree) is
389 Container_Count, Children_Count : Count_Type;
392 if Container.Busy > 0 then
394 with "attempt to tamper with cursors (tree is busy)";
397 -- We first set the container count to 0, in order to preserve
398 -- invariants in case the deallocation fails. (This works because
399 -- Deallocate_Children immediately removes the children from their
400 -- parent, and then does the actual deallocation.)
402 Container_Count := Container.Count;
403 Container.Count := 0;
405 -- Deallocate_Children returns the number of nodes that it deallocates,
406 -- but it does this by incrementing the count value that is passed in,
407 -- so we must first initialize the count return value before calling it.
411 -- See comment above. Deallocate_Children immediately removes the
412 -- children list from their parent node (here, the root of the tree),
413 -- and only after that does it attempt the actual deallocation. So even
414 -- if the deallocation fails, the representation invariants for the tree
417 Deallocate_Children (Root_Node (Container), Children_Count);
418 pragma Assert (Children_Count = Container_Count);
427 Item : Element_Type) return Boolean
430 return Find (Container, Item) /= No_Element;
437 function Copy (Source : Tree) return Tree is
439 return Target : Tree do
441 (Source => Source.Root.Children,
442 Parent => Root_Node (Target),
443 Count => Target.Count);
445 pragma Assert (Target.Count = Source.Count);
453 procedure Copy_Children
454 (Source : Children_Type;
455 Parent : Tree_Node_Access;
456 Count : in out Count_Type)
458 pragma Assert (Parent /= null);
459 pragma Assert (Parent.Children.First = null);
460 pragma Assert (Parent.Children.Last = null);
463 C : Tree_Node_Access;
466 -- We special-case the first allocation, in order to establish the
467 -- representation invariants for type Children_Type.
483 -- The representation invariants for the Children_Type list have been
484 -- established, so we can now copy the remaining children of Source.
491 Target => CC.Last.Next,
494 CC.Last.Next.Prev := CC.Last;
495 CC.Last := CC.Last.Next;
500 -- Add the newly-allocated children to their parent list only after the
501 -- allocation has succeeded, so as to preserve invariants of the parent.
503 Parent.Children := CC;
510 procedure Copy_Subtree
511 (Target : in out Tree;
516 Target_Subtree : Tree_Node_Access;
517 Target_Count : Count_Type;
520 if Parent = No_Element then
521 raise Constraint_Error with "Parent cursor has no element";
524 if Parent.Container /= Target'Unrestricted_Access then
525 raise Program_Error with "Parent cursor not in container";
528 if Before /= No_Element then
529 if Before.Container /= Target'Unrestricted_Access then
530 raise Program_Error with "Before cursor not in container";
533 if Before.Node.Parent /= Parent.Node then
534 raise Constraint_Error with "Before cursor not child of Parent";
538 if Source = No_Element then
542 if Is_Root (Source) then
543 raise Constraint_Error with "Source cursor designates root";
546 -- Copy_Subtree returns a count of the number of nodes that it
547 -- allocates, but it works by incrementing the value that is passed
548 -- in. We must therefore initialize the count value before calling
554 (Source => Source.Node,
555 Parent => Parent.Node,
556 Target => Target_Subtree,
557 Count => Target_Count);
559 pragma Assert (Target_Subtree /= null);
560 pragma Assert (Target_Subtree.Parent = Parent.Node);
561 pragma Assert (Target_Count >= 1);
564 (Subtree => Target_Subtree,
565 Parent => Parent.Node,
566 Before => Before.Node);
568 -- In order for operation Node_Count to complete in O(1) time, we cache
569 -- the count value. Here we increment the total count by the number of
570 -- nodes we just inserted.
572 Target.Count := Target.Count + Target_Count;
575 procedure Copy_Subtree
576 (Source : Tree_Node_Access;
577 Parent : Tree_Node_Access;
578 Target : out Tree_Node_Access;
579 Count : in out Count_Type)
582 Target := new Tree_Node_Type'(Element => Source.Element,
589 (Source => Source.Children,
594 -------------------------
595 -- Deallocate_Children --
596 -------------------------
598 procedure Deallocate_Children
599 (Subtree : Tree_Node_Access;
600 Count : in out Count_Type)
602 pragma Assert (Subtree /= null);
604 CC : Children_Type := Subtree.Children;
605 C : Tree_Node_Access;
608 -- We immediately remove the children from their parent, in order to
609 -- preserve invariants in case the deallocation fails.
611 Subtree.Children := Children_Type'(others => null);
613 while CC.First /= null loop
617 Deallocate_Subtree (C, Count);
619 end Deallocate_Children;
621 ------------------------
622 -- Deallocate_Subtree --
623 ------------------------
625 procedure Deallocate_Subtree
626 (Subtree : in out Tree_Node_Access;
627 Count : in out Count_Type)
630 Deallocate_Children (Subtree, Count);
631 Deallocate_Node (Subtree);
633 end Deallocate_Subtree;
635 ---------------------
636 -- Delete_Children --
637 ---------------------
639 procedure Delete_Children
640 (Container : in out Tree;
646 if Parent = No_Element then
647 raise Constraint_Error with "Parent cursor has no element";
650 if Parent.Container /= Container'Unrestricted_Access then
651 raise Program_Error with "Parent cursor not in container";
654 if Container.Busy > 0 then
656 with "attempt to tamper with cursors (tree is busy)";
659 -- Deallocate_Children returns a count of the number of nodes that it
660 -- deallocates, but it works by incrementing the value that is passed
661 -- in. We must therefore initialize the count value before calling
662 -- Deallocate_Children.
666 Deallocate_Children (Parent.Node, Count);
667 pragma Assert (Count <= Container.Count);
669 Container.Count := Container.Count - Count;
676 procedure Delete_Leaf
677 (Container : in out Tree;
678 Position : in out Cursor)
680 X : Tree_Node_Access;
683 if Position = No_Element then
684 raise Constraint_Error with "Position cursor has no element";
687 if Position.Container /= Container'Unrestricted_Access then
688 raise Program_Error with "Position cursor not in container";
691 if Is_Root (Position) then
692 raise Program_Error with "Position cursor designates root";
695 if not Is_Leaf (Position) then
696 raise Constraint_Error with "Position cursor does not designate leaf";
699 if Container.Busy > 0 then
701 with "attempt to tamper with cursors (tree is busy)";
705 Position := No_Element;
707 -- Restore represention invariants before attempting the actual
711 Container.Count := Container.Count - 1;
713 -- It is now safe to attempt the deallocation. This leaf node has been
714 -- disassociated from the tree, so even if the deallocation fails,
715 -- representation invariants will remain satisfied.
724 procedure Delete_Subtree
725 (Container : in out Tree;
726 Position : in out Cursor)
728 X : Tree_Node_Access;
732 if Position = No_Element then
733 raise Constraint_Error with "Position cursor has no element";
736 if Position.Container /= Container'Unrestricted_Access then
737 raise Program_Error with "Position cursor not in container";
740 if Is_Root (Position) then
741 raise Program_Error with "Position cursor designates root";
744 if Container.Busy > 0 then
746 with "attempt to tamper with cursors (tree is busy)";
750 Position := No_Element;
752 -- Here is one case where a deallocation failure can result in the
753 -- violation of a representation invariant. We disassociate the subtree
754 -- from the tree now, but we only decrement the total node count after
755 -- we attempt the deallocation. However, if the deallocation fails, the
756 -- total node count will not get decremented.
758 -- One way around this dilemma is to count the nodes in the subtree
759 -- before attempt to delete the subtree, but that is an O(n) operation,
760 -- so it does not seem worth it.
762 -- Perhaps this is much ado about nothing, since the only way
763 -- deallocation can fail is if Controlled Finalization fails: this
764 -- propagates Program_Error so all bets are off anyway. ???
768 -- Deallocate_Subtree returns a count of the number of nodes that it
769 -- deallocates, but it works by incrementing the value that is passed
770 -- in. We must therefore initialize the count value before calling
771 -- Deallocate_Subtree.
775 Deallocate_Subtree (X, Count);
776 pragma Assert (Count <= Container.Count);
778 -- See comments above. We would prefer to do this sooner, but there's no
779 -- way to satisfy that goal without a potentially severe execution
782 Container.Count := Container.Count - Count;
789 function Depth (Position : Cursor) return Count_Type is
791 N : Tree_Node_Access;
798 Result := Result + 1;
808 function Element (Position : Cursor) return Element_Type is
810 if Position.Container = null then
811 raise Constraint_Error with "Position cursor has no element";
814 if Position.Node = Root_Node (Position.Container.all) then
815 raise Program_Error with "Position cursor designates root";
818 return Position.Node.Element;
825 function Equal_Children
826 (Left_Subtree : Tree_Node_Access;
827 Right_Subtree : Tree_Node_Access) return Boolean
829 Left_Children : Children_Type renames Left_Subtree.Children;
830 Right_Children : Children_Type renames Right_Subtree.Children;
832 L, R : Tree_Node_Access;
835 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
839 L := Left_Children.First;
840 R := Right_Children.First;
842 if not Equal_Subtree (L, R) then
857 function Equal_Subtree
858 (Left_Position : Cursor;
859 Right_Position : Cursor) return Boolean
862 if Left_Position = No_Element then
863 raise Constraint_Error with "Left cursor has no element";
866 if Right_Position = No_Element then
867 raise Constraint_Error with "Right cursor has no element";
870 if Left_Position = Right_Position then
874 if Is_Root (Left_Position) then
875 if not Is_Root (Right_Position) then
879 return Equal_Children (Left_Position.Node, Right_Position.Node);
882 if Is_Root (Right_Position) then
886 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
889 function Equal_Subtree
890 (Left_Subtree : Tree_Node_Access;
891 Right_Subtree : Tree_Node_Access) return Boolean
894 if Left_Subtree.Element /= Right_Subtree.Element then
898 return Equal_Children (Left_Subtree, Right_Subtree);
907 Item : Element_Type) return Cursor
909 N : constant Tree_Node_Access :=
910 Find_In_Children (Root_Node (Container), Item);
917 return Cursor'(Container'Unrestricted_Access, N);
924 function First (Object : Iterator) return Cursor is
926 return Object.Position;
929 function First (Object : Child_Iterator) return Cursor is
931 return (Object.Container, Object.Position.Node.Children.First);
938 function First_Child (Parent : Cursor) return Cursor is
939 Node : Tree_Node_Access;
942 if Parent = No_Element then
943 raise Constraint_Error with "Parent cursor has no element";
946 Node := Parent.Node.Children.First;
952 return Cursor'(Parent.Container, Node);
955 -------------------------
956 -- First_Child_Element --
957 -------------------------
959 function First_Child_Element (Parent : Cursor) return Element_Type is
961 return Element (First_Child (Parent));
962 end First_Child_Element;
964 ----------------------
965 -- Find_In_Children --
966 ----------------------
968 function Find_In_Children
969 (Subtree : Tree_Node_Access;
970 Item : Element_Type) return Tree_Node_Access
972 N, Result : Tree_Node_Access;
975 N := Subtree.Children.First;
977 Result := Find_In_Subtree (N, Item);
979 if Result /= null then
987 end Find_In_Children;
989 ---------------------
990 -- Find_In_Subtree --
991 ---------------------
993 function Find_In_Subtree
995 Item : Element_Type) return Cursor
997 Result : Tree_Node_Access;
1000 if Position = No_Element then
1001 raise Constraint_Error with "Position cursor has no element";
1004 -- Commented out pending official ruling by ARG. ???
1006 -- if Position.Container /= Container'Unrestricted_Access then
1007 -- raise Program_Error with "Position cursor not in container";
1011 (if Is_Root (Position)
1012 then Find_In_Children (Position.Node, Item)
1013 else Find_In_Subtree (Position.Node, Item));
1015 if Result = null then
1019 return Cursor'(Position.Container, Result);
1020 end Find_In_Subtree;
1022 function Find_In_Subtree
1023 (Subtree : Tree_Node_Access;
1024 Item : Element_Type) return Tree_Node_Access
1027 if Subtree.Element = Item then
1031 return Find_In_Children (Subtree, Item);
1032 end Find_In_Subtree;
1038 function Has_Element (Position : Cursor) return Boolean is
1040 if Position = No_Element then
1044 return Position.Node.Parent /= null;
1051 procedure Insert_Child
1052 (Container : in out Tree;
1055 New_Item : Element_Type;
1056 Count : Count_Type := 1)
1059 pragma Unreferenced (Position);
1062 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1065 procedure Insert_Child
1066 (Container : in out Tree;
1069 New_Item : Element_Type;
1070 Position : out Cursor;
1071 Count : Count_Type := 1)
1073 Last : Tree_Node_Access;
1076 if Parent = No_Element then
1077 raise Constraint_Error with "Parent cursor has no element";
1080 if Parent.Container /= Container'Unrestricted_Access then
1081 raise Program_Error with "Parent cursor not in container";
1084 if Before /= No_Element then
1085 if Before.Container /= Container'Unrestricted_Access then
1086 raise Program_Error with "Before cursor not in container";
1089 if Before.Node.Parent /= Parent.Node then
1090 raise Constraint_Error with "Parent cursor not parent of Before";
1095 Position := No_Element; -- Need ruling from ARG ???
1099 if Container.Busy > 0 then
1101 with "attempt to tamper with cursors (tree is busy)";
1104 Position.Container := Parent.Container;
1105 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1106 Element => New_Item,
1109 Last := Position.Node;
1111 for J in Count_Type'(2) .. Count loop
1113 -- Reclaim other nodes if Storage_Error. ???
1115 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1117 Element => New_Item,
1124 (First => Position.Node,
1126 Parent => Parent.Node,
1127 Before => Before.Node);
1129 -- In order for operation Node_Count to complete in O(1) time, we cache
1130 -- the count value. Here we increment the total count by the number of
1131 -- nodes we just inserted.
1133 Container.Count := Container.Count + Count;
1136 procedure Insert_Child
1137 (Container : in out Tree;
1140 Position : out Cursor;
1141 Count : Count_Type := 1)
1143 Last : Tree_Node_Access;
1146 if Parent = No_Element then
1147 raise Constraint_Error with "Parent cursor has no element";
1150 if Parent.Container /= Container'Unrestricted_Access then
1151 raise Program_Error with "Parent cursor not in container";
1154 if Before /= No_Element then
1155 if Before.Container /= Container'Unrestricted_Access then
1156 raise Program_Error with "Before cursor not in container";
1159 if Before.Node.Parent /= Parent.Node then
1160 raise Constraint_Error with "Parent cursor not parent of Before";
1165 Position := No_Element; -- Need ruling from ARG ???
1169 if Container.Busy > 0 then
1171 with "attempt to tamper with cursors (tree is busy)";
1174 Position.Container := Parent.Container;
1175 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1179 Last := Position.Node;
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,
1194 (First => Position.Node,
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;
1206 -------------------------
1207 -- Insert_Subtree_List --
1208 -------------------------
1210 procedure Insert_Subtree_List
1211 (First : Tree_Node_Access;
1212 Last : Tree_Node_Access;
1213 Parent : Tree_Node_Access;
1214 Before : Tree_Node_Access)
1216 pragma Assert (Parent /= null);
1217 C : Children_Type renames Parent.Children;
1220 -- This is a simple utility operation to insert a list of nodes (from
1221 -- First..Last) as children of Parent. The Before node specifies where
1222 -- the new children should be inserted relative to the existing
1225 if First = null then
1226 pragma Assert (Last = null);
1230 pragma Assert (Last /= null);
1231 pragma Assert (Before = null or else Before.Parent = Parent);
1233 if C.First = null then
1235 C.First.Prev := null;
1237 C.Last.Next := null;
1239 elsif Before = null then -- means "insert after existing nodes"
1240 C.Last.Next := First;
1241 First.Prev := C.Last;
1243 C.Last.Next := null;
1245 elsif Before = C.First then
1246 Last.Next := C.First;
1247 C.First.Prev := Last;
1249 C.First.Prev := null;
1252 Before.Prev.Next := First;
1253 First.Prev := Before.Prev;
1254 Last.Next := Before;
1255 Before.Prev := Last;
1257 end Insert_Subtree_List;
1259 -------------------------
1260 -- Insert_Subtree_Node --
1261 -------------------------
1263 procedure Insert_Subtree_Node
1264 (Subtree : Tree_Node_Access;
1265 Parent : Tree_Node_Access;
1266 Before : Tree_Node_Access)
1269 -- This is a simple wrapper operation to insert a single child into the
1270 -- Parent's children list.
1277 end Insert_Subtree_Node;
1283 function Is_Empty (Container : Tree) return Boolean is
1285 return Container.Root.Children.First = null;
1292 function Is_Leaf (Position : Cursor) return Boolean is
1294 if Position = No_Element then
1298 return Position.Node.Children.First = null;
1305 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1306 pragma Assert (From /= null);
1307 pragma Assert (To /= null);
1309 N : Tree_Node_Access;
1313 while N /= null loop
1328 function Is_Root (Position : Cursor) return Boolean is
1330 if Position.Container = null then
1334 return Position = Root (Position.Container.all);
1343 Process : not null access procedure (Position : Cursor))
1345 T : Tree renames Container'Unrestricted_Access.all;
1346 B : Integer renames T.Busy;
1352 (Container => Container'Unrestricted_Access,
1353 Subtree => Root_Node (Container),
1354 Process => Process);
1364 function Iterate (Container : Tree)
1365 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1367 Root_Cursor : constant Cursor :=
1368 (Container'Unrestricted_Access, Root_Node (Container));
1371 Iterator'(Container'Unrestricted_Access,
1372 First_Child (Root_Cursor),
1376 ----------------------
1377 -- Iterate_Children --
1378 ----------------------
1380 procedure Iterate_Children
1382 Process : not null access procedure (Position : Cursor))
1385 if Parent = No_Element then
1386 raise Constraint_Error with "Parent cursor has no element";
1390 B : Integer renames Parent.Container.Busy;
1391 C : Tree_Node_Access;
1396 C := Parent.Node.Children.First;
1397 while C /= null loop
1398 Process (Position => Cursor'(Parent.Container, Node => C));
1409 end Iterate_Children;
1411 procedure Iterate_Children
1412 (Container : Tree_Access;
1413 Subtree : Tree_Node_Access;
1414 Process : not null access procedure (Position : Cursor))
1416 Node : Tree_Node_Access;
1419 -- This is a helper function to recursively iterate over all the nodes
1420 -- in a subtree, in depth-first fashion. This particular helper just
1421 -- visits the children of this subtree, not the root of the subtree node
1422 -- itself. This is useful when starting from the ultimate root of the
1423 -- entire tree (see Iterate), as that root does not have an element.
1425 Node := Subtree.Children.First;
1426 while Node /= null loop
1427 Iterate_Subtree (Container, Node, Process);
1430 end Iterate_Children;
1432 function Iterate_Children
1435 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1437 pragma Unreferenced (Container);
1439 return Child_Iterator'(Parent.Container, Parent);
1440 end Iterate_Children;
1442 ---------------------
1443 -- Iterate_Subtree --
1444 ---------------------
1446 function Iterate_Subtree
1448 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1451 return Iterator'(Position.Container, Position, From_Root => False);
1452 end Iterate_Subtree;
1454 procedure Iterate_Subtree
1456 Process : not null access procedure (Position : Cursor))
1459 if Position = No_Element then
1460 raise Constraint_Error with "Position cursor has no element";
1464 B : Integer renames Position.Container.Busy;
1469 if Is_Root (Position) then
1470 Iterate_Children (Position.Container, Position.Node, Process);
1472 Iterate_Subtree (Position.Container, Position.Node, Process);
1482 end Iterate_Subtree;
1484 procedure Iterate_Subtree
1485 (Container : Tree_Access;
1486 Subtree : Tree_Node_Access;
1487 Process : not null access procedure (Position : Cursor))
1490 -- This is a helper function to recursively iterate over all the nodes
1491 -- in a subtree, in depth-first fashion. It first visits the root of the
1492 -- subtree, then visits its children.
1494 Process (Cursor'(Container, Subtree));
1495 Iterate_Children (Container, Subtree, Process);
1496 end Iterate_Subtree;
1502 overriding function Last (Object : Child_Iterator) return Cursor is
1504 return (Object.Container, Object.Position.Node.Children.Last);
1511 function Last_Child (Parent : Cursor) return Cursor is
1512 Node : Tree_Node_Access;
1515 if Parent = No_Element then
1516 raise Constraint_Error with "Parent cursor has no element";
1519 Node := Parent.Node.Children.Last;
1525 return (Parent.Container, Node);
1528 ------------------------
1529 -- Last_Child_Element --
1530 ------------------------
1532 function Last_Child_Element (Parent : Cursor) return Element_Type is
1534 return Element (Last_Child (Parent));
1535 end Last_Child_Element;
1541 procedure Move (Target : in out Tree; Source : in out Tree) is
1542 Node : Tree_Node_Access;
1545 if Target'Address = Source'Address then
1549 if Source.Busy > 0 then
1551 with "attempt to tamper with cursors of Source (tree is busy)";
1554 Target.Clear; -- checks busy bit
1556 Target.Root.Children := Source.Root.Children;
1557 Source.Root.Children := Children_Type'(others => null);
1559 Node := Target.Root.Children.First;
1560 while Node /= null loop
1561 Node.Parent := Root_Node (Target);
1565 Target.Count := Source.Count;
1575 Position : Cursor) return Cursor
1577 T : Tree renames Position.Container.all;
1578 N : constant Tree_Node_Access := Position.Node;
1581 if Is_Leaf (Position) then
1583 -- If sibling is present, return it.
1585 if N.Next /= null then
1586 return (Object.Container, N.Next);
1588 -- If this is the last sibling, go to sibling of first ancestor that
1589 -- has a sibling, or terminate.
1593 Par : Tree_Node_Access := N.Parent;
1596 while Par.Next = null loop
1598 -- If we are back at the root the iteration is complete.
1600 if Par = Root_Node (T) then
1603 -- If this is a subtree iterator and we are back at the
1604 -- starting node, iteration is complete.
1606 elsif Par = Object.Position.Node
1607 and then not Object.From_Root
1616 if Par = Object.Position.Node
1617 and then not Object.From_Root
1622 return (Object.Container, Par.Next);
1627 -- If an internal node, return its first child.
1629 return (Object.Container, N.Children.First);
1634 (Object : Child_Iterator;
1635 Position : Cursor) return Cursor
1637 C : constant Tree_Node_Access := Position.Node.Next;
1639 return (if C = null then No_Element else (Object.Container, C));
1646 function Next_Sibling (Position : Cursor) return Cursor is
1648 if Position = No_Element then
1652 if Position.Node.Next = null then
1656 return Cursor'(Position.Container, Position.Node.Next);
1659 procedure Next_Sibling (Position : in out Cursor) is
1661 Position := Next_Sibling (Position);
1668 function Node_Count (Container : Tree) return Count_Type is
1670 -- Container.Count is the number of nodes we have actually allocated. We
1671 -- cache the value specifically so this Node_Count operation can execute
1672 -- in O(1) time, which makes it behave similarly to how the Length
1673 -- selector function behaves for other containers.
1675 -- The cached node count value only describes the nodes we have
1676 -- allocated; the root node itself is not included in that count. The
1677 -- Node_Count operation returns a value that includes the root node
1678 -- (because the RM says so), so we must add 1 to our cached value.
1680 return 1 + Container.Count;
1687 function Parent (Position : Cursor) return Cursor is
1689 if Position = No_Element then
1693 if Position.Node.Parent = null then
1697 return Cursor'(Position.Container, Position.Node.Parent);
1704 procedure Prepend_Child
1705 (Container : in out Tree;
1707 New_Item : Element_Type;
1708 Count : Count_Type := 1)
1710 First, Last : Tree_Node_Access;
1713 if Parent = No_Element then
1714 raise Constraint_Error with "Parent cursor has no element";
1717 if Parent.Container /= Container'Unrestricted_Access then
1718 raise Program_Error with "Parent cursor not in container";
1725 if Container.Busy > 0 then
1727 with "attempt to tamper with cursors (tree is busy)";
1730 First := new Tree_Node_Type'(Parent => Parent.Node,
1731 Element => New_Item,
1736 for J in Count_Type'(2) .. Count loop
1738 -- Reclaim other nodes if Storage_Error. ???
1740 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1742 Element => New_Item,
1751 Parent => Parent.Node,
1752 Before => Parent.Node.Children.First);
1754 -- In order for operation Node_Count to complete in O(1) time, we cache
1755 -- the count value. Here we increment the total count by the number of
1756 -- nodes we just inserted.
1758 Container.Count := Container.Count + Count;
1765 overriding function Previous
1766 (Object : Child_Iterator;
1767 Position : Cursor) return Cursor
1769 C : constant Tree_Node_Access := Position.Node.Prev;
1771 return (if C = null then No_Element else (Object.Container, C));
1774 ----------------------
1775 -- Previous_Sibling --
1776 ----------------------
1778 function Previous_Sibling (Position : Cursor) return Cursor is
1781 (if Position = No_Element then No_Element
1782 elsif Position.Node.Prev = null then No_Element
1783 else Cursor'(Position.Container, Position.Node.Prev));
1784 end Previous_Sibling;
1786 procedure Previous_Sibling (Position : in out Cursor) is
1788 Position := Previous_Sibling (Position);
1789 end Previous_Sibling;
1795 procedure Query_Element
1797 Process : not null access procedure (Element : Element_Type))
1800 if Position = No_Element then
1801 raise Constraint_Error with "Position cursor has no element";
1804 if Is_Root (Position) then
1805 raise Program_Error with "Position cursor designates root";
1809 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1810 B : Integer renames T.Busy;
1811 L : Integer renames T.Lock;
1817 Process (Position.Node.Element);
1835 (Stream : not null access Root_Stream_Type'Class;
1836 Container : out Tree)
1838 procedure Read_Children (Subtree : Tree_Node_Access);
1840 function Read_Subtree
1841 (Parent : Tree_Node_Access) return Tree_Node_Access;
1843 Total_Count : Count_Type'Base;
1844 -- Value read from the stream that says how many elements follow
1846 Read_Count : Count_Type'Base;
1847 -- Actual number of elements read from the stream
1853 procedure Read_Children (Subtree : Tree_Node_Access) is
1854 pragma Assert (Subtree /= null);
1855 pragma Assert (Subtree.Children.First = null);
1856 pragma Assert (Subtree.Children.Last = null);
1858 Count : Count_Type'Base;
1859 -- Number of child subtrees
1864 Count_Type'Read (Stream, Count);
1867 raise Program_Error with "attempt to read from corrupt stream";
1874 C.First := Read_Subtree (Parent => Subtree);
1877 for J in Count_Type'(2) .. Count loop
1878 C.Last.Next := Read_Subtree (Parent => Subtree);
1879 C.Last.Next.Prev := C.Last;
1880 C.Last := C.Last.Next;
1883 -- Now that the allocation and reads have completed successfully, it
1884 -- is safe to link the children to their parent.
1886 Subtree.Children := C;
1893 function Read_Subtree
1894 (Parent : Tree_Node_Access) return Tree_Node_Access
1896 Subtree : constant Tree_Node_Access :=
1899 Element => Element_Type'Input (Stream),
1903 Read_Count := Read_Count + 1;
1905 Read_Children (Subtree);
1910 -- Start of processing for Read
1913 Container.Clear; -- checks busy bit
1915 Count_Type'Read (Stream, Total_Count);
1917 if Total_Count < 0 then
1918 raise Program_Error with "attempt to read from corrupt stream";
1921 if Total_Count = 0 then
1927 Read_Children (Root_Node (Container));
1929 if Read_Count /= Total_Count then
1930 raise Program_Error with "attempt to read from corrupt stream";
1933 Container.Count := Total_Count;
1937 (Stream : not null access Root_Stream_Type'Class;
1938 Position : out Cursor)
1941 raise Program_Error with "attempt to read tree cursor from stream";
1945 (Stream : not null access Root_Stream_Type'Class;
1946 Item : out Reference_Type)
1949 raise Program_Error with "attempt to stream reference";
1953 (Stream : not null access Root_Stream_Type'Class;
1954 Item : out Constant_Reference_Type)
1957 raise Program_Error with "attempt to stream reference";
1964 function Constant_Reference
1965 (Container : aliased Tree;
1966 Position : Cursor) return Constant_Reference_Type
1969 pragma Unreferenced (Container);
1971 return (Element => Position.Node.Element'Unrestricted_Access);
1972 end Constant_Reference;
1975 (Container : aliased Tree;
1976 Position : Cursor) return Reference_Type
1979 pragma Unreferenced (Container);
1981 return (Element => Position.Node.Element'Unrestricted_Access);
1984 --------------------
1985 -- Remove_Subtree --
1986 --------------------
1988 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
1989 C : Children_Type renames Subtree.Parent.Children;
1992 -- This is a utility operation to remove a subtree
1993 -- node from its parent's list of children.
1995 if C.First = Subtree then
1996 pragma Assert (Subtree.Prev = null);
1998 if C.Last = Subtree then
1999 pragma Assert (Subtree.Next = null);
2004 C.First := Subtree.Next;
2005 C.First.Prev := null;
2008 elsif C.Last = Subtree then
2009 pragma Assert (Subtree.Next = null);
2010 C.Last := Subtree.Prev;
2011 C.Last.Next := null;
2014 Subtree.Prev.Next := Subtree.Next;
2015 Subtree.Next.Prev := Subtree.Prev;
2019 ----------------------
2020 -- Replace_Element --
2021 ----------------------
2023 procedure Replace_Element
2024 (Container : in out Tree;
2026 New_Item : Element_Type)
2029 if Position = No_Element then
2030 raise Constraint_Error with "Position cursor has no element";
2033 if Position.Container /= Container'Unrestricted_Access then
2034 raise Program_Error with "Position cursor not in container";
2037 if Is_Root (Position) then
2038 raise Program_Error with "Position cursor designates root";
2041 if Container.Lock > 0 then
2043 with "attempt to tamper with elements (tree is locked)";
2046 Position.Node.Element := New_Item;
2047 end Replace_Element;
2049 ------------------------------
2050 -- Reverse_Iterate_Children --
2051 ------------------------------
2053 procedure Reverse_Iterate_Children
2055 Process : not null access procedure (Position : Cursor))
2058 if Parent = No_Element then
2059 raise Constraint_Error with "Parent cursor has no element";
2063 B : Integer renames Parent.Container.Busy;
2064 C : Tree_Node_Access;
2069 C := Parent.Node.Children.Last;
2070 while C /= null loop
2071 Process (Position => Cursor'(Parent.Container, Node => C));
2082 end Reverse_Iterate_Children;
2088 function Root (Container : Tree) return Cursor is
2090 return (Container'Unrestricted_Access, Root_Node (Container));
2097 function Root_Node (Container : Tree) return Tree_Node_Access is
2098 type Root_Node_Access is access all Root_Node_Type;
2099 for Root_Node_Access'Storage_Size use 0;
2100 pragma Convention (C, Root_Node_Access);
2102 function To_Tree_Node_Access is
2103 new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access);
2105 -- Start of processing for Root_Node
2108 -- This is a utility function for converting from an access type that
2109 -- designates the distinguished root node to an access type designating
2110 -- a non-root node. The representation of a root node does not have an
2111 -- element, but is otherwise identical to a non-root node, so the
2112 -- conversion itself is safe.
2114 return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
2117 ---------------------
2118 -- Splice_Children --
2119 ---------------------
2121 procedure Splice_Children
2122 (Target : in out Tree;
2123 Target_Parent : Cursor;
2125 Source : in out Tree;
2126 Source_Parent : Cursor)
2131 if Target_Parent = No_Element then
2132 raise Constraint_Error with "Target_Parent cursor has no element";
2135 if Target_Parent.Container /= Target'Unrestricted_Access then
2137 with "Target_Parent cursor not in Target container";
2140 if Before /= No_Element then
2141 if Before.Container /= Target'Unrestricted_Access then
2143 with "Before cursor not in Target container";
2146 if Before.Node.Parent /= Target_Parent.Node then
2147 raise Constraint_Error
2148 with "Before cursor not child of Target_Parent";
2152 if Source_Parent = No_Element then
2153 raise Constraint_Error with "Source_Parent cursor has no element";
2156 if Source_Parent.Container /= Source'Unrestricted_Access then
2158 with "Source_Parent cursor not in Source container";
2161 if Target'Address = Source'Address then
2162 if Target_Parent = Source_Parent then
2166 if Target.Busy > 0 then
2168 with "attempt to tamper with cursors (Target tree is busy)";
2171 if Is_Reachable (From => Target_Parent.Node,
2172 To => Source_Parent.Node)
2174 raise Constraint_Error
2175 with "Source_Parent is ancestor of Target_Parent";
2179 (Target_Parent => Target_Parent.Node,
2180 Before => Before.Node,
2181 Source_Parent => Source_Parent.Node);
2186 if Target.Busy > 0 then
2188 with "attempt to tamper with cursors (Target tree is busy)";
2191 if Source.Busy > 0 then
2193 with "attempt to tamper with cursors (Source tree is busy)";
2196 -- We cache the count of the nodes we have allocated, so that operation
2197 -- Node_Count can execute in O(1) time. But that means we must count the
2198 -- nodes in the subtree we remove from Source and insert into Target, in
2199 -- order to keep the count accurate.
2201 Count := Subtree_Node_Count (Source_Parent.Node);
2202 pragma Assert (Count >= 1);
2204 Count := Count - 1; -- because Source_Parent node does not move
2207 (Target_Parent => Target_Parent.Node,
2208 Before => Before.Node,
2209 Source_Parent => Source_Parent.Node);
2211 Source.Count := Source.Count - Count;
2212 Target.Count := Target.Count + Count;
2213 end Splice_Children;
2215 procedure Splice_Children
2216 (Container : in out Tree;
2217 Target_Parent : Cursor;
2219 Source_Parent : Cursor)
2222 if Target_Parent = No_Element then
2223 raise Constraint_Error with "Target_Parent cursor has no element";
2226 if Target_Parent.Container /= Container'Unrestricted_Access then
2228 with "Target_Parent cursor not in container";
2231 if Before /= No_Element then
2232 if Before.Container /= Container'Unrestricted_Access then
2234 with "Before cursor not in container";
2237 if Before.Node.Parent /= Target_Parent.Node then
2238 raise Constraint_Error
2239 with "Before cursor not child of Target_Parent";
2243 if Source_Parent = No_Element then
2244 raise Constraint_Error with "Source_Parent cursor has no element";
2247 if Source_Parent.Container /= Container'Unrestricted_Access then
2249 with "Source_Parent cursor not in container";
2252 if Target_Parent = Source_Parent then
2256 if Container.Busy > 0 then
2258 with "attempt to tamper with cursors (tree is busy)";
2261 if Is_Reachable (From => Target_Parent.Node,
2262 To => Source_Parent.Node)
2264 raise Constraint_Error
2265 with "Source_Parent is ancestor of Target_Parent";
2269 (Target_Parent => Target_Parent.Node,
2270 Before => Before.Node,
2271 Source_Parent => Source_Parent.Node);
2272 end Splice_Children;
2274 procedure Splice_Children
2275 (Target_Parent : Tree_Node_Access;
2276 Before : Tree_Node_Access;
2277 Source_Parent : Tree_Node_Access)
2279 CC : constant Children_Type := Source_Parent.Children;
2280 C : Tree_Node_Access;
2283 -- This is a utility operation to remove the children from
2284 -- Source parent and insert them into Target parent.
2286 Source_Parent.Children := Children_Type'(others => null);
2288 -- Fix up the Parent pointers of each child to designate
2289 -- its new Target parent.
2292 while C /= null loop
2293 C.Parent := Target_Parent;
2300 Parent => Target_Parent,
2302 end Splice_Children;
2304 --------------------
2305 -- Splice_Subtree --
2306 --------------------
2308 procedure Splice_Subtree
2309 (Target : in out Tree;
2312 Source : in out Tree;
2313 Position : in out Cursor)
2315 Subtree_Count : Count_Type;
2318 if Parent = No_Element then
2319 raise Constraint_Error with "Parent cursor has no element";
2322 if Parent.Container /= Target'Unrestricted_Access then
2323 raise Program_Error with "Parent cursor not in Target container";
2326 if Before /= No_Element then
2327 if Before.Container /= Target'Unrestricted_Access then
2328 raise Program_Error with "Before cursor not in Target container";
2331 if Before.Node.Parent /= Parent.Node then
2332 raise Constraint_Error with "Before cursor not child of Parent";
2336 if Position = No_Element then
2337 raise Constraint_Error with "Position cursor has no element";
2340 if Position.Container /= Source'Unrestricted_Access then
2341 raise Program_Error with "Position cursor not in Source container";
2344 if Is_Root (Position) then
2345 raise Program_Error with "Position cursor designates root";
2348 if Target'Address = Source'Address then
2349 if Position.Node.Parent = Parent.Node then
2350 if Position.Node = Before.Node then
2354 if Position.Node.Next = Before.Node then
2359 if Target.Busy > 0 then
2361 with "attempt to tamper with cursors (Target tree is busy)";
2364 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2365 raise Constraint_Error with "Position is ancestor of Parent";
2368 Remove_Subtree (Position.Node);
2370 Position.Node.Parent := Parent.Node;
2371 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2376 if Target.Busy > 0 then
2378 with "attempt to tamper with cursors (Target tree is busy)";
2381 if Source.Busy > 0 then
2383 with "attempt to tamper with cursors (Source tree is busy)";
2386 -- This is an unfortunate feature of this API: we must count the nodes
2387 -- in the subtree that we remove from the source tree, which is an O(n)
2388 -- operation. It would have been better if the Tree container did not
2389 -- have a Node_Count selector; a user that wants the number of nodes in
2390 -- the tree could simply call Subtree_Node_Count, with the understanding
2391 -- that such an operation is O(n).
2393 -- Of course, we could choose to implement the Node_Count selector as an
2394 -- O(n) operation, which would turn this splice operation into an O(1)
2397 Subtree_Count := Subtree_Node_Count (Position.Node);
2398 pragma Assert (Subtree_Count <= Source.Count);
2400 Remove_Subtree (Position.Node);
2401 Source.Count := Source.Count - Subtree_Count;
2403 Position.Node.Parent := Parent.Node;
2404 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2406 Target.Count := Target.Count + Subtree_Count;
2408 Position.Container := Target'Unrestricted_Access;
2411 procedure Splice_Subtree
2412 (Container : in out Tree;
2418 if Parent = No_Element then
2419 raise Constraint_Error with "Parent cursor has no element";
2422 if Parent.Container /= Container'Unrestricted_Access then
2423 raise Program_Error with "Parent cursor not in container";
2426 if Before /= No_Element then
2427 if Before.Container /= Container'Unrestricted_Access then
2428 raise Program_Error with "Before cursor not in container";
2431 if Before.Node.Parent /= Parent.Node then
2432 raise Constraint_Error with "Before cursor not child of Parent";
2436 if Position = No_Element then
2437 raise Constraint_Error with "Position cursor has no element";
2440 if Position.Container /= Container'Unrestricted_Access then
2441 raise Program_Error with "Position cursor not in container";
2444 if Is_Root (Position) then
2446 -- Should this be PE instead? Need ARG confirmation. ???
2448 raise Constraint_Error with "Position cursor designates root";
2451 if Position.Node.Parent = Parent.Node then
2452 if Position.Node = Before.Node then
2456 if Position.Node.Next = Before.Node then
2461 if Container.Busy > 0 then
2463 with "attempt to tamper with cursors (tree is busy)";
2466 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2467 raise Constraint_Error with "Position is ancestor of Parent";
2470 Remove_Subtree (Position.Node);
2472 Position.Node.Parent := Parent.Node;
2473 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2476 ------------------------
2477 -- Subtree_Node_Count --
2478 ------------------------
2480 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2482 if Position = No_Element then
2486 return Subtree_Node_Count (Position.Node);
2487 end Subtree_Node_Count;
2489 function Subtree_Node_Count
2490 (Subtree : Tree_Node_Access) return Count_Type
2492 Result : Count_Type;
2493 Node : Tree_Node_Access;
2497 Node := Subtree.Children.First;
2498 while Node /= null loop
2499 Result := Result + Subtree_Node_Count (Node);
2504 end Subtree_Node_Count;
2511 (Container : in out Tree;
2515 if I = No_Element then
2516 raise Constraint_Error with "I cursor has no element";
2519 if I.Container /= Container'Unrestricted_Access then
2520 raise Program_Error with "I cursor not in container";
2524 raise Program_Error with "I cursor designates root";
2527 if I = J then -- make this test sooner???
2531 if J = No_Element then
2532 raise Constraint_Error with "J cursor has no element";
2535 if J.Container /= Container'Unrestricted_Access then
2536 raise Program_Error with "J cursor not in container";
2540 raise Program_Error with "J cursor designates root";
2543 if Container.Lock > 0 then
2545 with "attempt to tamper with elements (tree is locked)";
2549 EI : constant Element_Type := I.Node.Element;
2552 I.Node.Element := J.Node.Element;
2553 J.Node.Element := EI;
2557 --------------------
2558 -- Update_Element --
2559 --------------------
2561 procedure Update_Element
2562 (Container : in out Tree;
2564 Process : not null access procedure (Element : in out Element_Type))
2567 if Position = No_Element then
2568 raise Constraint_Error with "Position cursor has no element";
2571 if Position.Container /= Container'Unrestricted_Access then
2572 raise Program_Error with "Position cursor not in container";
2575 if Is_Root (Position) then
2576 raise Program_Error with "Position cursor designates root";
2580 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2581 B : Integer renames T.Busy;
2582 L : Integer renames T.Lock;
2588 Process (Position.Node.Element);
2606 (Stream : not null access Root_Stream_Type'Class;
2609 procedure Write_Children (Subtree : Tree_Node_Access);
2610 procedure Write_Subtree (Subtree : Tree_Node_Access);
2612 --------------------
2613 -- Write_Children --
2614 --------------------
2616 procedure Write_Children (Subtree : Tree_Node_Access) is
2617 CC : Children_Type renames Subtree.Children;
2618 C : Tree_Node_Access;
2621 Count_Type'Write (Stream, Child_Count (CC));
2624 while C /= null loop
2634 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2636 Element_Type'Output (Stream, Subtree.Element);
2637 Write_Children (Subtree);
2640 -- Start of processing for Write
2643 Count_Type'Write (Stream, Container.Count);
2645 if Container.Count = 0 then
2649 Write_Children (Root_Node (Container));
2653 (Stream : not null access Root_Stream_Type'Class;
2657 raise Program_Error with "attempt to write tree cursor to stream";
2661 (Stream : not null access Root_Stream_Type'Class;
2662 Item : Reference_Type)
2665 raise Program_Error with "attempt to stream reference";
2669 (Stream : not null access Root_Stream_Type'Class;
2670 Item : Constant_Reference_Type)
2673 raise Program_Error with "attempt to stream reference";
2676 end Ada.Containers.Multiway_Trees;