1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
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_Deallocation;
31 with System; use type System.Address;
33 package body Ada.Containers.Indefinite_Multiway_Trees is
35 type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
37 Container : Tree_Access;
42 overriding function First (Object : Iterator) return Cursor;
43 overriding function Next
45 Position : Cursor) return Cursor;
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 function Root_Node (Container : Tree) return Tree_Node_Access;
53 procedure Free_Element is
54 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
56 procedure Deallocate_Node (X : in out Tree_Node_Access);
58 procedure Deallocate_Children
59 (Subtree : Tree_Node_Access;
60 Count : in out Count_Type);
62 procedure Deallocate_Subtree
63 (Subtree : in out Tree_Node_Access;
64 Count : in out Count_Type);
66 function Equal_Children
67 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
69 function Equal_Subtree
70 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
72 procedure Iterate_Children
73 (Container : Tree_Access;
74 Subtree : Tree_Node_Access;
75 Process : not null access procedure (Position : Cursor));
77 procedure Iterate_Subtree
78 (Container : Tree_Access;
79 Subtree : Tree_Node_Access;
80 Process : not null access procedure (Position : Cursor));
82 procedure Copy_Children
83 (Source : Children_Type;
84 Parent : Tree_Node_Access;
85 Count : in out Count_Type);
87 procedure Copy_Subtree
88 (Source : Tree_Node_Access;
89 Parent : Tree_Node_Access;
90 Target : out Tree_Node_Access;
91 Count : in out Count_Type);
93 function Find_In_Children
94 (Subtree : Tree_Node_Access;
95 Item : Element_Type) return Tree_Node_Access;
97 function Find_In_Subtree
98 (Subtree : Tree_Node_Access;
99 Item : Element_Type) return Tree_Node_Access;
101 function Child_Count (Children : Children_Type) return Count_Type;
103 function Subtree_Node_Count
104 (Subtree : Tree_Node_Access) return Count_Type;
106 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
108 procedure Remove_Subtree (Subtree : Tree_Node_Access);
110 procedure Insert_Subtree_Node
111 (Subtree : Tree_Node_Access;
112 Parent : Tree_Node_Access;
113 Before : Tree_Node_Access);
115 procedure Insert_Subtree_List
116 (First : Tree_Node_Access;
117 Last : Tree_Node_Access;
118 Parent : Tree_Node_Access;
119 Before : Tree_Node_Access);
121 procedure Splice_Children
122 (Target_Parent : Tree_Node_Access;
123 Before : Tree_Node_Access;
124 Source_Parent : Tree_Node_Access);
130 function "=" (Left, Right : Tree) return Boolean is
132 if Left'Address = Right'Address then
136 return Equal_Children (Root_Node (Left), Root_Node (Right));
143 procedure Adjust (Container : in out Tree) is
144 Source : constant Children_Type := Container.Root.Children;
145 Source_Count : constant Count_Type := Container.Count;
146 Target_Count : Count_Type;
149 -- We first restore the target container to its default-initialized
150 -- state, before we attempt any allocation, to ensure that invariants
151 -- are preserved in the event that the allocation fails.
153 Container.Root.Children := Children_Type'(others => null);
156 Container.Count := 0;
158 -- Copy_Children returns a count of the number of nodes that it
159 -- allocates, but it works by incrementing the value that is passed in.
160 -- We must therefore initialize the count value before calling
165 -- Now we attempt the allocation of subtrees. The invariants are
166 -- satisfied even if the allocation fails.
168 Copy_Children (Source, Root_Node (Container), Target_Count);
169 pragma Assert (Target_Count = Source_Count);
171 Container.Count := Source_Count;
178 function Ancestor_Find
180 Item : Element_Type) return Cursor
182 R, N : Tree_Node_Access;
185 if Position = No_Element then
186 raise Constraint_Error with "Position cursor has no element";
189 -- Commented-out pending ARG ruling. ???
191 -- if Position.Container /= Container'Unrestricted_Access then
192 -- raise Program_Error with "Position cursor not in container";
195 -- AI-0136 says to raise PE if Position equals the root node. This does
196 -- not seem correct, as this value is just the limiting condition of the
197 -- search. For now we omit this check pending a ruling from the ARG.???
199 -- if Is_Root (Position) then
200 -- raise Program_Error with "Position cursor designates root";
203 R := Root_Node (Position.Container.all);
206 if N.Element.all = Item then
207 return Cursor'(Position.Container, N);
220 procedure Append_Child
221 (Container : in out Tree;
223 New_Item : Element_Type;
224 Count : Count_Type := 1)
226 First, Last : Tree_Node_Access;
227 Element : Element_Access;
230 if Parent = No_Element then
231 raise Constraint_Error with "Parent cursor has no element";
234 if Parent.Container /= Container'Unrestricted_Access then
235 raise Program_Error with "Parent cursor not in container";
242 if Container.Busy > 0 then
244 with "attempt to tamper with cursors (tree is busy)";
247 Element := new Element_Type'(New_Item);
248 First := new Tree_Node_Type'(Parent => Parent.Node,
254 for J in Count_Type'(2) .. Count loop
256 -- Reclaim other nodes if Storage_Error. ???
258 Element := new Element_Type'(New_Item);
259 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
270 Parent => Parent.Node,
271 Before => null); -- null means "insert at end of list"
273 -- In order for operation Node_Count to complete in O(1) time, we cache
274 -- the count value. Here we increment the total count by the number of
275 -- nodes we just inserted.
277 Container.Count := Container.Count + Count;
284 procedure Assign (Target : in out Tree; Source : Tree) is
285 Source_Count : constant Count_Type := Source.Count;
286 Target_Count : Count_Type;
289 if Target'Address = Source'Address then
293 Target.Clear; -- checks busy bit
295 -- Copy_Children returns the number of nodes that it allocates, but it
296 -- does this by incrementing the count value passed in, so we must
297 -- initialize the count before calling Copy_Children.
301 -- Note that Copy_Children inserts the newly-allocated children into
302 -- their parent list only after the allocation of all the children has
303 -- succeeded. This preserves invariants even if the allocation fails.
305 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
306 pragma Assert (Target_Count = Source_Count);
308 Target.Count := Source_Count;
315 function Child_Count (Parent : Cursor) return Count_Type is
317 if Parent = No_Element then
320 return Child_Count (Parent.Node.Children);
324 function Child_Count (Children : Children_Type) return Count_Type is
326 Node : Tree_Node_Access;
330 Node := Children.First;
331 while Node /= null loop
332 Result := Result + 1;
343 function Child_Depth (Parent, Child : Cursor) return Count_Type is
345 N : Tree_Node_Access;
348 if Parent = No_Element then
349 raise Constraint_Error with "Parent cursor has no element";
352 if Child = No_Element then
353 raise Constraint_Error with "Child cursor has no element";
356 if Parent.Container /= Child.Container then
357 raise Program_Error with "Parent and Child in different containers";
362 while N /= Parent.Node loop
363 Result := Result + 1;
367 raise Program_Error with "Parent is not ancestor of Child";
378 procedure Clear (Container : in out Tree) is
379 Container_Count : Count_Type;
380 Children_Count : Count_Type;
383 if Container.Busy > 0 then
385 with "attempt to tamper with cursors (tree is busy)";
388 -- We first set the container count to 0, in order to preserve
389 -- invariants in case the deallocation fails. (This works because
390 -- Deallocate_Children immediately removes the children from their
391 -- parent, and then does the actual deallocation.)
393 Container_Count := Container.Count;
394 Container.Count := 0;
396 -- Deallocate_Children returns the number of nodes that it deallocates,
397 -- but it does this by incrementing the count value that is passed in,
398 -- so we must first initialize the count return value before calling it.
402 -- See comment above. Deallocate_Children immediately removes the
403 -- children list from their parent node (here, the root of the tree),
404 -- and only after that does it attempt the actual deallocation. So even
405 -- if the deallocation fails, the representation invariants
407 Deallocate_Children (Root_Node (Container), Children_Count);
408 pragma Assert (Children_Count = Container_Count);
417 Item : Element_Type) return Boolean
420 return Find (Container, Item) /= No_Element;
427 function Copy (Source : Tree) return Tree is
429 return Target : Tree do
431 (Source => Source.Root.Children,
432 Parent => Root_Node (Target),
433 Count => Target.Count);
435 pragma Assert (Target.Count = Source.Count);
443 procedure Copy_Children
444 (Source : Children_Type;
445 Parent : Tree_Node_Access;
446 Count : in out Count_Type)
448 pragma Assert (Parent /= null);
449 pragma Assert (Parent.Children.First = null);
450 pragma Assert (Parent.Children.Last = null);
453 C : Tree_Node_Access;
456 -- We special-case the first allocation, in order to establish the
457 -- representation invariants for type Children_Type.
473 -- The representation invariants for the Children_Type list have been
474 -- established, so we can now copy the remaining children of Source.
481 Target => CC.Last.Next,
484 CC.Last.Next.Prev := CC.Last;
485 CC.Last := CC.Last.Next;
490 -- We add the newly-allocated children to their parent list only after
491 -- the allocation has succeeded, in order to preserve invariants of the
494 Parent.Children := CC;
501 procedure Copy_Subtree
502 (Target : in out Tree;
507 Target_Subtree : Tree_Node_Access;
508 Target_Count : Count_Type;
511 if Parent = No_Element then
512 raise Constraint_Error with "Parent cursor has no element";
515 if Parent.Container /= Target'Unrestricted_Access then
516 raise Program_Error with "Parent cursor not in container";
519 if Before /= No_Element then
520 if Before.Container /= Target'Unrestricted_Access then
521 raise Program_Error with "Before cursor not in container";
524 if Before.Node.Parent /= Parent.Node then
525 raise Constraint_Error with "Before cursor not child of Parent";
529 if Source = No_Element then
533 if Is_Root (Source) then
534 raise Constraint_Error with "Source cursor designates root";
537 -- Copy_Subtree returns a count of the number of nodes that it
538 -- allocates, but it works by incrementing the value that is passed in.
539 -- We must therefore initialize the count value before calling
545 (Source => Source.Node,
546 Parent => Parent.Node,
547 Target => Target_Subtree,
548 Count => Target_Count);
550 pragma Assert (Target_Subtree /= null);
551 pragma Assert (Target_Subtree.Parent = Parent.Node);
552 pragma Assert (Target_Count >= 1);
555 (Subtree => Target_Subtree,
556 Parent => Parent.Node,
557 Before => Before.Node);
559 -- In order for operation Node_Count to complete in O(1) time, we cache
560 -- the count value. Here we increment the total count by the number of
561 -- nodes we just inserted.
563 Target.Count := Target.Count + Target_Count;
566 procedure Copy_Subtree
567 (Source : Tree_Node_Access;
568 Parent : Tree_Node_Access;
569 Target : out Tree_Node_Access;
570 Count : in out Count_Type)
572 E : constant Element_Access := new Element_Type'(Source.Element.all);
575 Target := new Tree_Node_Type'(Element => E,
582 (Source => Source.Children,
587 -------------------------
588 -- Deallocate_Children --
589 -------------------------
591 procedure Deallocate_Children
592 (Subtree : Tree_Node_Access;
593 Count : in out Count_Type)
595 pragma Assert (Subtree /= null);
597 CC : Children_Type := Subtree.Children;
598 C : Tree_Node_Access;
601 -- We immediately remove the children from their parent, in order to
602 -- preserve invariants in case the deallocation fails.
604 Subtree.Children := Children_Type'(others => null);
606 while CC.First /= null loop
610 Deallocate_Subtree (C, Count);
612 end Deallocate_Children;
614 ---------------------
615 -- Deallocate_Node --
616 ---------------------
618 procedure Deallocate_Node (X : in out Tree_Node_Access) is
619 procedure Free_Node is
620 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
622 -- Start of processing for Deallocate_Node
626 Free_Element (X.Element);
631 ------------------------
632 -- Deallocate_Subtree --
633 ------------------------
635 procedure Deallocate_Subtree
636 (Subtree : in out Tree_Node_Access;
637 Count : in out Count_Type)
640 Deallocate_Children (Subtree, Count);
641 Deallocate_Node (Subtree);
643 end Deallocate_Subtree;
645 ---------------------
646 -- Delete_Children --
647 ---------------------
649 procedure Delete_Children
650 (Container : in out Tree;
656 if Parent = No_Element then
657 raise Constraint_Error with "Parent cursor has no element";
660 if Parent.Container /= Container'Unrestricted_Access then
661 raise Program_Error with "Parent cursor not in container";
664 if Container.Busy > 0 then
666 with "attempt to tamper with cursors (tree is busy)";
669 -- Deallocate_Children returns a count of the number of nodes
670 -- that it deallocates, but it works by incrementing the
671 -- value that is passed in. We must therefore initialize
672 -- the count value before calling Deallocate_Children.
676 Deallocate_Children (Parent.Node, Count);
677 pragma Assert (Count <= Container.Count);
679 Container.Count := Container.Count - Count;
686 procedure Delete_Leaf
687 (Container : in out Tree;
688 Position : in out Cursor)
690 X : Tree_Node_Access;
693 if Position = No_Element then
694 raise Constraint_Error with "Position cursor has no element";
697 if Position.Container /= Container'Unrestricted_Access then
698 raise Program_Error with "Position cursor not in container";
701 if Is_Root (Position) then
702 raise Program_Error with "Position cursor designates root";
705 if not Is_Leaf (Position) then
706 raise Constraint_Error with "Position cursor does not designate leaf";
709 if Container.Busy > 0 then
711 with "attempt to tamper with cursors (tree is busy)";
715 Position := No_Element;
717 -- Restore represention invariants before attempting the actual
721 Container.Count := Container.Count - 1;
723 -- It is now safe to attempt the deallocation. This leaf node has been
724 -- disassociated from the tree, so even if the deallocation fails,
725 -- representation invariants will remain satisfied.
734 procedure Delete_Subtree
735 (Container : in out Tree;
736 Position : in out Cursor)
738 X : Tree_Node_Access;
742 if Position = No_Element then
743 raise Constraint_Error with "Position cursor has no element";
746 if Position.Container /= Container'Unrestricted_Access then
747 raise Program_Error with "Position cursor not in container";
750 if Is_Root (Position) then
751 raise Program_Error with "Position cursor designates root";
754 if Container.Busy > 0 then
756 with "attempt to tamper with cursors (tree is busy)";
760 Position := No_Element;
762 -- Here is one case where a deallocation failure can result in the
763 -- violation of a representation invariant. We disassociate the subtree
764 -- from the tree now, but we only decrement the total node count after
765 -- we attempt the deallocation. However, if the deallocation fails, the
766 -- total node count will not get decremented.
768 -- One way around this dilemma is to count the nodes in the subtree
769 -- before attempt to delete the subtree, but that is an O(n) operation,
770 -- so it does not seem worth it.
772 -- Perhaps this is much ado about nothing, since the only way
773 -- deallocation can fail is if Controlled Finalization fails: this
774 -- propagates Program_Error so all bets are off anyway. ???
778 -- Deallocate_Subtree returns a count of the number of nodes that it
779 -- deallocates, but it works by incrementing the value that is passed
780 -- in. We must therefore initialize the count value before calling
781 -- Deallocate_Subtree.
785 Deallocate_Subtree (X, Count);
786 pragma Assert (Count <= Container.Count);
788 -- See comments above. We would prefer to do this sooner, but there's no
789 -- way to satisfy that goal without an potentially severe execution
792 Container.Count := Container.Count - Count;
799 function Depth (Position : Cursor) return Count_Type is
801 N : Tree_Node_Access;
808 Result := Result + 1;
818 function Element (Position : Cursor) return Element_Type is
820 if Position.Container = null then
821 raise Constraint_Error with "Position cursor has no element";
824 if Position.Node = Root_Node (Position.Container.all) then
825 raise Program_Error with "Position cursor designates root";
828 return Position.Node.Element.all;
835 function Equal_Children
836 (Left_Subtree : Tree_Node_Access;
837 Right_Subtree : Tree_Node_Access) return Boolean
839 Left_Children : Children_Type renames Left_Subtree.Children;
840 Right_Children : Children_Type renames Right_Subtree.Children;
842 L, R : Tree_Node_Access;
845 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
849 L := Left_Children.First;
850 R := Right_Children.First;
852 if not Equal_Subtree (L, R) then
867 function Equal_Subtree
868 (Left_Position : Cursor;
869 Right_Position : Cursor) return Boolean
872 if Left_Position = No_Element then
873 raise Constraint_Error with "Left cursor has no element";
876 if Right_Position = No_Element then
877 raise Constraint_Error with "Right cursor has no element";
880 if Left_Position = Right_Position then
884 if Is_Root (Left_Position) then
885 if not Is_Root (Right_Position) then
889 return Equal_Children (Left_Position.Node, Right_Position.Node);
892 if Is_Root (Right_Position) then
896 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
899 function Equal_Subtree
900 (Left_Subtree : Tree_Node_Access;
901 Right_Subtree : Tree_Node_Access) return Boolean
904 if Left_Subtree.Element.all /= Right_Subtree.Element.all then
908 return Equal_Children (Left_Subtree, Right_Subtree);
917 Item : Element_Type) return Cursor
919 N : constant Tree_Node_Access :=
920 Find_In_Children (Root_Node (Container), Item);
927 return Cursor'(Container'Unrestricted_Access, N);
934 function First (Object : Iterator) return Cursor is
936 return Object.Position;
943 function First_Child (Parent : Cursor) return Cursor is
944 Node : Tree_Node_Access;
947 if Parent = No_Element then
948 raise Constraint_Error with "Parent cursor has no element";
951 Node := Parent.Node.Children.First;
957 return Cursor'(Parent.Container, Node);
960 -------------------------
961 -- First_Child_Element --
962 -------------------------
964 function First_Child_Element (Parent : Cursor) return Element_Type is
966 return Element (First_Child (Parent));
967 end First_Child_Element;
969 ----------------------
970 -- Find_In_Children --
971 ----------------------
973 function Find_In_Children
974 (Subtree : Tree_Node_Access;
975 Item : Element_Type) return Tree_Node_Access
977 N, Result : Tree_Node_Access;
980 N := Subtree.Children.First;
982 Result := Find_In_Subtree (N, Item);
984 if Result /= null then
992 end Find_In_Children;
994 ---------------------
995 -- Find_In_Subtree --
996 ---------------------
998 function Find_In_Subtree
1000 Item : Element_Type) return Cursor
1002 Result : Tree_Node_Access;
1005 if Position = No_Element then
1006 raise Constraint_Error with "Position cursor has no element";
1009 -- Commented-out pending ruling from ARG. ???
1011 -- if Position.Container /= Container'Unrestricted_Access then
1012 -- raise Program_Error with "Position cursor not in container";
1015 if Is_Root (Position) then
1016 Result := Find_In_Children (Position.Node, Item);
1019 Result := Find_In_Subtree (Position.Node, Item);
1022 if Result = null then
1026 return Cursor'(Position.Container, Result);
1027 end Find_In_Subtree;
1029 function Find_In_Subtree
1030 (Subtree : Tree_Node_Access;
1031 Item : Element_Type) return Tree_Node_Access
1034 if Subtree.Element.all = Item then
1038 return Find_In_Children (Subtree, Item);
1039 end Find_In_Subtree;
1045 function Has_Element (Position : Cursor) return Boolean is
1047 if Position = No_Element then
1051 return Position.Node.Parent /= null;
1058 procedure Insert_Child
1059 (Container : in out Tree;
1062 New_Item : Element_Type;
1063 Count : Count_Type := 1)
1066 pragma Unreferenced (Position);
1069 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1072 procedure Insert_Child
1073 (Container : in out Tree;
1076 New_Item : Element_Type;
1077 Position : out Cursor;
1078 Count : Count_Type := 1)
1080 Last : Tree_Node_Access;
1081 Element : Element_Access;
1084 if Parent = No_Element then
1085 raise Constraint_Error with "Parent cursor has no element";
1088 if Parent.Container /= Container'Unrestricted_Access then
1089 raise Program_Error with "Parent cursor not in container";
1092 if Before /= No_Element then
1093 if Before.Container /= Container'Unrestricted_Access then
1094 raise Program_Error with "Before cursor not in container";
1097 if Before.Node.Parent /= Parent.Node then
1098 raise Constraint_Error with "Parent cursor not parent of Before";
1103 Position := No_Element; -- Need ruling from ARG ???
1107 if Container.Busy > 0 then
1109 with "attempt to tamper with cursors (tree is busy)";
1112 Position.Container := Parent.Container;
1114 Element := new Element_Type'(New_Item);
1115 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1119 Last := Position.Node;
1121 for J in Count_Type'(2) .. Count loop
1122 -- Reclaim other nodes if Storage_Error. ???
1124 Element := new Element_Type'(New_Item);
1125 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1134 (First => Position.Node,
1136 Parent => Parent.Node,
1137 Before => Before.Node);
1139 -- In order for operation Node_Count to complete in O(1) time, we cache
1140 -- the count value. Here we increment the total count by the number of
1141 -- nodes we just inserted.
1143 Container.Count := Container.Count + Count;
1146 -------------------------
1147 -- Insert_Subtree_List --
1148 -------------------------
1150 procedure Insert_Subtree_List
1151 (First : Tree_Node_Access;
1152 Last : Tree_Node_Access;
1153 Parent : Tree_Node_Access;
1154 Before : Tree_Node_Access)
1156 pragma Assert (Parent /= null);
1157 C : Children_Type renames Parent.Children;
1160 -- This is a simple utility operation to insert a list of nodes (from
1161 -- First..Last) as children of Parent. The Before node specifies where
1162 -- the new children should be inserted relative to the existing
1165 if First = null then
1166 pragma Assert (Last = null);
1170 pragma Assert (Last /= null);
1171 pragma Assert (Before = null or else Before.Parent = Parent);
1173 if C.First = null then
1175 C.First.Prev := null;
1177 C.Last.Next := null;
1179 elsif Before = null then -- means "insert after existing nodes"
1180 C.Last.Next := First;
1181 First.Prev := C.Last;
1183 C.Last.Next := null;
1185 elsif Before = C.First then
1186 Last.Next := C.First;
1187 C.First.Prev := Last;
1189 C.First.Prev := null;
1192 Before.Prev.Next := First;
1193 First.Prev := Before.Prev;
1194 Last.Next := Before;
1195 Before.Prev := Last;
1197 end Insert_Subtree_List;
1199 -------------------------
1200 -- Insert_Subtree_Node --
1201 -------------------------
1203 procedure Insert_Subtree_Node
1204 (Subtree : Tree_Node_Access;
1205 Parent : Tree_Node_Access;
1206 Before : Tree_Node_Access)
1209 -- This is a simple wrapper operation to insert a single child into the
1210 -- Parent's children list.
1217 end Insert_Subtree_Node;
1223 function Is_Empty (Container : Tree) return Boolean is
1225 return Container.Root.Children.First = null;
1232 function Is_Leaf (Position : Cursor) return Boolean is
1234 if Position = No_Element then
1238 return Position.Node.Children.First = null;
1245 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1246 pragma Assert (From /= null);
1247 pragma Assert (To /= null);
1249 N : Tree_Node_Access;
1253 while N /= null loop
1268 function Is_Root (Position : Cursor) return Boolean is
1270 if Position.Container = null then
1274 return Position = Root (Position.Container.all);
1283 Process : not null access procedure (Position : Cursor))
1285 T : Tree renames Container'Unrestricted_Access.all;
1286 B : Integer renames T.Busy;
1292 (Container => Container'Unrestricted_Access,
1293 Subtree => Root_Node (Container),
1294 Process => Process);
1304 function Iterate (Container : Tree)
1305 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1307 Root_Cursor : constant Cursor :=
1308 (Container'Unrestricted_Access, Root_Node (Container));
1311 Iterator'(Container'Unrestricted_Access,
1312 First_Child (Root_Cursor), From_Root => True);
1315 function Iterate_Subtree (Position : Cursor)
1316 return Tree_Iterator_Interfaces.Forward_Iterator'Class is
1318 return Iterator'(Position.Container, Position, From_Root => False);
1319 end Iterate_Subtree;
1321 ----------------------
1322 -- Iterate_Children --
1323 ----------------------
1325 procedure Iterate_Children
1327 Process : not null access procedure (Position : Cursor))
1330 if Parent = No_Element then
1331 raise Constraint_Error with "Parent cursor has no element";
1335 B : Integer renames Parent.Container.Busy;
1336 C : Tree_Node_Access;
1341 C := Parent.Node.Children.First;
1342 while C /= null loop
1343 Process (Position => Cursor'(Parent.Container, Node => C));
1354 end Iterate_Children;
1356 procedure Iterate_Children
1357 (Container : Tree_Access;
1358 Subtree : Tree_Node_Access;
1359 Process : not null access procedure (Position : Cursor))
1361 Node : Tree_Node_Access;
1364 -- This is a helper function to recursively iterate over all the nodes
1365 -- in a subtree, in depth-first fashion. This particular helper just
1366 -- visits the children of this subtree, not the root of the subtree node
1367 -- itself. This is useful when starting from the ultimate root of the
1368 -- entire tree (see Iterate), as that root does not have an element.
1370 Node := Subtree.Children.First;
1371 while Node /= null loop
1372 Iterate_Subtree (Container, Node, Process);
1375 end Iterate_Children;
1377 ---------------------
1378 -- Iterate_Subtree --
1379 ---------------------
1381 procedure Iterate_Subtree
1383 Process : not null access procedure (Position : Cursor))
1386 if Position = No_Element then
1387 raise Constraint_Error with "Position cursor has no element";
1391 B : Integer renames Position.Container.Busy;
1396 if Is_Root (Position) then
1397 Iterate_Children (Position.Container, Position.Node, Process);
1399 Iterate_Subtree (Position.Container, Position.Node, Process);
1409 end Iterate_Subtree;
1411 procedure Iterate_Subtree
1412 (Container : Tree_Access;
1413 Subtree : Tree_Node_Access;
1414 Process : not null access procedure (Position : Cursor))
1417 -- This is a helper function to recursively iterate over all the nodes
1418 -- in a subtree, in depth-first fashion. It first visits the root of the
1419 -- subtree, then visits its children.
1421 Process (Cursor'(Container, Subtree));
1422 Iterate_Children (Container, Subtree, Process);
1423 end Iterate_Subtree;
1429 function Last_Child (Parent : Cursor) return Cursor is
1430 Node : Tree_Node_Access;
1433 if Parent = No_Element then
1434 raise Constraint_Error with "Parent cursor has no element";
1437 Node := Parent.Node.Children.Last;
1443 return (Parent.Container, Node);
1446 ------------------------
1447 -- Last_Child_Element --
1448 ------------------------
1450 function Last_Child_Element (Parent : Cursor) return Element_Type is
1452 return Element (Last_Child (Parent));
1453 end Last_Child_Element;
1459 procedure Move (Target : in out Tree; Source : in out Tree) is
1460 Node : Tree_Node_Access;
1463 if Target'Address = Source'Address then
1467 if Source.Busy > 0 then
1469 with "attempt to tamper with cursors of Source (tree is busy)";
1472 Target.Clear; -- checks busy bit
1474 Target.Root.Children := Source.Root.Children;
1475 Source.Root.Children := Children_Type'(others => null);
1477 Node := Target.Root.Children.First;
1478 while Node /= null loop
1479 Node.Parent := Root_Node (Target);
1483 Target.Count := Source.Count;
1493 Position : Cursor) return Cursor
1495 T : Tree renames Position.Container.all;
1496 N : constant Tree_Node_Access := Position.Node;
1499 if Is_Leaf (Position) then
1501 -- If sibling is present, return it.
1503 if N.Next /= null then
1504 return (Object.Container, N.Next);
1506 -- If this is the last sibling, go to sibling of first ancestor that
1507 -- has a sibling, or terminate.
1511 Par : Tree_Node_Access := N.Parent;
1514 while Par.Next = null loop
1516 -- If we are back at the root the iteration is complete.
1518 if Par = Root_Node (T) then
1521 -- If this is a subtree iterator and we are back at the
1522 -- starting node, iteration is complete.
1524 elsif Par = Object.Position.Node
1525 and then not Object.From_Root
1534 if Par = Object.Position.Node
1535 and then not Object.From_Root
1540 return (Object.Container, Par.Next);
1546 -- If an internal node, return its first child.
1548 return (Object.Container, N.Children.First);
1556 function Next_Sibling (Position : Cursor) return Cursor is
1558 if Position = No_Element then
1562 if Position.Node.Next = null then
1566 return Cursor'(Position.Container, Position.Node.Next);
1569 procedure Next_Sibling (Position : in out Cursor) is
1571 Position := Next_Sibling (Position);
1578 function Node_Count (Container : Tree) return Count_Type is
1580 -- Container.Count is the number of nodes we have actually allocated. We
1581 -- cache the value specifically so this Node_Count operation can execute
1582 -- in O(1) time, which makes it behave similarly to how the Length
1583 -- selector function behaves for other containers.
1585 -- The cached node count value only describes the nodes we have
1586 -- allocated; the root node itself is not included in that count. The
1587 -- Node_Count operation returns a value that includes the root node
1588 -- (because the RM says so), so we must add 1 to our cached value.
1590 return 1 + Container.Count;
1597 function Parent (Position : Cursor) return Cursor is
1599 if Position = No_Element then
1603 if Position.Node.Parent = null then
1607 return Cursor'(Position.Container, Position.Node.Parent);
1614 procedure Prepend_Child
1615 (Container : in out Tree;
1617 New_Item : Element_Type;
1618 Count : Count_Type := 1)
1620 First, Last : Tree_Node_Access;
1621 Element : Element_Access;
1624 if Parent = No_Element then
1625 raise Constraint_Error with "Parent cursor has no element";
1628 if Parent.Container /= Container'Unrestricted_Access then
1629 raise Program_Error with "Parent cursor not in container";
1636 if Container.Busy > 0 then
1638 with "attempt to tamper with cursors (tree is busy)";
1641 Element := new Element_Type'(New_Item);
1642 First := new Tree_Node_Type'(Parent => Parent.Node,
1648 for J in Count_Type'(2) .. Count loop
1650 -- Reclaim other nodes if Storage_Error. ???
1652 Element := new Element_Type'(New_Item);
1653 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1664 Parent => Parent.Node,
1665 Before => Parent.Node.Children.First);
1667 -- In order for operation Node_Count to complete in O(1) time, we cache
1668 -- the count value. Here we increment the total count by the number of
1669 -- nodes we just inserted.
1671 Container.Count := Container.Count + Count;
1674 ----------------------
1675 -- Previous_Sibling --
1676 ----------------------
1678 function Previous_Sibling (Position : Cursor) return Cursor is
1680 if Position = No_Element then
1684 if Position.Node.Prev = null then
1688 return Cursor'(Position.Container, Position.Node.Prev);
1689 end Previous_Sibling;
1691 procedure Previous_Sibling (Position : in out Cursor) is
1693 Position := Previous_Sibling (Position);
1694 end Previous_Sibling;
1700 procedure Query_Element
1702 Process : not null access procedure (Element : Element_Type))
1705 if Position = No_Element then
1706 raise Constraint_Error with "Position cursor has no element";
1709 if Is_Root (Position) then
1710 raise Program_Error with "Position cursor designates root";
1714 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1715 B : Integer renames T.Busy;
1716 L : Integer renames T.Lock;
1722 Process (Position.Node.Element.all);
1740 (Stream : not null access Root_Stream_Type'Class;
1741 Container : out Tree)
1743 procedure Read_Children (Subtree : Tree_Node_Access);
1745 function Read_Subtree
1746 (Parent : Tree_Node_Access) return Tree_Node_Access;
1748 Total_Count : Count_Type'Base;
1749 -- Value read from the stream that says how many elements follow
1751 Read_Count : Count_Type'Base;
1752 -- Actual number of elements read from the stream
1758 procedure Read_Children (Subtree : Tree_Node_Access) is
1759 pragma Assert (Subtree /= null);
1760 pragma Assert (Subtree.Children.First = null);
1761 pragma Assert (Subtree.Children.Last = null);
1763 Count : Count_Type'Base;
1764 -- Number of child subtrees
1769 Count_Type'Read (Stream, Count);
1772 raise Program_Error with "attempt to read from corrupt stream";
1779 C.First := Read_Subtree (Parent => Subtree);
1782 for J in Count_Type'(2) .. Count loop
1783 C.Last.Next := Read_Subtree (Parent => Subtree);
1784 C.Last.Next.Prev := C.Last;
1785 C.Last := C.Last.Next;
1788 -- Now that the allocation and reads have completed successfully, it
1789 -- is safe to link the children to their parent.
1791 Subtree.Children := C;
1798 function Read_Subtree
1799 (Parent : Tree_Node_Access) return Tree_Node_Access
1801 Element : constant Element_Access :=
1802 new Element_Type'(Element_Type'Input (Stream));
1804 Subtree : constant Tree_Node_Access :=
1811 Read_Count := Read_Count + 1;
1813 Read_Children (Subtree);
1818 -- Start of processing for Read
1821 Container.Clear; -- checks busy bit
1823 Count_Type'Read (Stream, Total_Count);
1825 if Total_Count < 0 then
1826 raise Program_Error with "attempt to read from corrupt stream";
1829 if Total_Count = 0 then
1835 Read_Children (Root_Node (Container));
1837 if Read_Count /= Total_Count then
1838 raise Program_Error with "attempt to read from corrupt stream";
1841 Container.Count := Total_Count;
1845 (Stream : not null access Root_Stream_Type'Class;
1846 Position : out Cursor)
1849 raise Program_Error with "attempt to read tree cursor from stream";
1853 (Stream : not null access Root_Stream_Type'Class;
1854 Item : out Reference_Type)
1857 raise Program_Error with "attempt to stream reference";
1861 (Stream : not null access Root_Stream_Type'Class;
1862 Item : out Constant_Reference_Type)
1865 raise Program_Error with "attempt to stream reference";
1872 function Constant_Reference
1873 (Container : aliased Tree;
1874 Position : Cursor) return Constant_Reference_Type
1877 pragma Unreferenced (Container);
1879 return (Element => Position.Node.Element.all'Unchecked_Access);
1880 end Constant_Reference;
1883 (Container : aliased Tree;
1884 Position : Cursor) return Reference_Type
1887 pragma Unreferenced (Container);
1889 return (Element => Position.Node.Element.all'Unchecked_Access);
1892 --------------------
1893 -- Remove_Subtree --
1894 --------------------
1896 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
1897 C : Children_Type renames Subtree.Parent.Children;
1900 -- This is a utility operation to remove a subtree node from its
1901 -- parent's list of children.
1903 if C.First = Subtree then
1904 pragma Assert (Subtree.Prev = null);
1906 if C.Last = Subtree then
1907 pragma Assert (Subtree.Next = null);
1912 C.First := Subtree.Next;
1913 C.First.Prev := null;
1916 elsif C.Last = Subtree then
1917 pragma Assert (Subtree.Next = null);
1918 C.Last := Subtree.Prev;
1919 C.Last.Next := null;
1922 Subtree.Prev.Next := Subtree.Next;
1923 Subtree.Next.Prev := Subtree.Prev;
1927 ----------------------
1928 -- Replace_Element --
1929 ----------------------
1931 procedure Replace_Element
1932 (Container : in out Tree;
1934 New_Item : Element_Type)
1936 E, X : Element_Access;
1939 if Position = No_Element then
1940 raise Constraint_Error with "Position cursor has no element";
1943 if Position.Container /= Container'Unrestricted_Access then
1944 raise Program_Error with "Position cursor not in container";
1947 if Is_Root (Position) then
1948 raise Program_Error with "Position cursor designates root";
1951 if Container.Lock > 0 then
1953 with "attempt to tamper with elements (tree is locked)";
1956 E := new Element_Type'(New_Item);
1958 X := Position.Node.Element;
1959 Position.Node.Element := E;
1962 end Replace_Element;
1964 ------------------------------
1965 -- Reverse_Iterate_Children --
1966 ------------------------------
1968 procedure Reverse_Iterate_Children
1970 Process : not null access procedure (Position : Cursor))
1973 if Parent = No_Element then
1974 raise Constraint_Error with "Parent cursor has no element";
1978 B : Integer renames Parent.Container.Busy;
1979 C : Tree_Node_Access;
1984 C := Parent.Node.Children.Last;
1985 while C /= null loop
1986 Process (Position => Cursor'(Parent.Container, Node => C));
1997 end Reverse_Iterate_Children;
2003 function Root (Container : Tree) return Cursor is
2005 return (Container'Unrestricted_Access, Root_Node (Container));
2012 function Root_Node (Container : Tree) return Tree_Node_Access is
2014 return Container.Root'Unrestricted_Access;
2017 ---------------------
2018 -- Splice_Children --
2019 ---------------------
2021 procedure Splice_Children
2022 (Target : in out Tree;
2023 Target_Parent : Cursor;
2025 Source : in out Tree;
2026 Source_Parent : Cursor)
2031 if Target_Parent = No_Element then
2032 raise Constraint_Error with "Target_Parent cursor has no element";
2035 if Target_Parent.Container /= Target'Unrestricted_Access then
2037 with "Target_Parent cursor not in Target container";
2040 if Before /= No_Element then
2041 if Before.Container /= Target'Unrestricted_Access then
2043 with "Before cursor not in Target container";
2046 if Before.Node.Parent /= Target_Parent.Node then
2047 raise Constraint_Error
2048 with "Before cursor not child of Target_Parent";
2052 if Source_Parent = No_Element then
2053 raise Constraint_Error with "Source_Parent cursor has no element";
2056 if Source_Parent.Container /= Source'Unrestricted_Access then
2058 with "Source_Parent cursor not in Source container";
2061 if Target'Address = Source'Address then
2062 if Target_Parent = Source_Parent then
2066 if Target.Busy > 0 then
2068 with "attempt to tamper with cursors (Target tree is busy)";
2071 if Is_Reachable (From => Target_Parent.Node,
2072 To => Source_Parent.Node)
2074 raise Constraint_Error
2075 with "Source_Parent is ancestor of Target_Parent";
2079 (Target_Parent => Target_Parent.Node,
2080 Before => Before.Node,
2081 Source_Parent => Source_Parent.Node);
2086 if Target.Busy > 0 then
2088 with "attempt to tamper with cursors (Target tree is busy)";
2091 if Source.Busy > 0 then
2093 with "attempt to tamper with cursors (Source tree is busy)";
2096 -- We cache the count of the nodes we have allocated, so that operation
2097 -- Node_Count can execute in O(1) time. But that means we must count the
2098 -- nodes in the subtree we remove from Source and insert into Target, in
2099 -- order to keep the count accurate.
2101 Count := Subtree_Node_Count (Source_Parent.Node);
2102 pragma Assert (Count >= 1);
2104 Count := Count - 1; -- because Source_Parent node does not move
2107 (Target_Parent => Target_Parent.Node,
2108 Before => Before.Node,
2109 Source_Parent => Source_Parent.Node);
2111 Source.Count := Source.Count - Count;
2112 Target.Count := Target.Count + Count;
2113 end Splice_Children;
2115 procedure Splice_Children
2116 (Container : in out Tree;
2117 Target_Parent : Cursor;
2119 Source_Parent : Cursor)
2122 if Target_Parent = No_Element then
2123 raise Constraint_Error with "Target_Parent cursor has no element";
2126 if Target_Parent.Container /= Container'Unrestricted_Access then
2128 with "Target_Parent cursor not in container";
2131 if Before /= No_Element then
2132 if Before.Container /= Container'Unrestricted_Access then
2134 with "Before cursor not in container";
2137 if Before.Node.Parent /= Target_Parent.Node then
2138 raise Constraint_Error
2139 with "Before cursor not child of Target_Parent";
2143 if Source_Parent = No_Element then
2144 raise Constraint_Error with "Source_Parent cursor has no element";
2147 if Source_Parent.Container /= Container'Unrestricted_Access then
2149 with "Source_Parent cursor not in container";
2152 if Target_Parent = Source_Parent then
2156 if Container.Busy > 0 then
2158 with "attempt to tamper with cursors (tree is busy)";
2161 if Is_Reachable (From => Target_Parent.Node,
2162 To => Source_Parent.Node)
2164 raise Constraint_Error
2165 with "Source_Parent is ancestor of Target_Parent";
2169 (Target_Parent => Target_Parent.Node,
2170 Before => Before.Node,
2171 Source_Parent => Source_Parent.Node);
2172 end Splice_Children;
2174 procedure Splice_Children
2175 (Target_Parent : Tree_Node_Access;
2176 Before : Tree_Node_Access;
2177 Source_Parent : Tree_Node_Access)
2179 CC : constant Children_Type := Source_Parent.Children;
2180 C : Tree_Node_Access;
2183 -- This is a utility operation to remove the children from Source parent
2184 -- and insert them into Target parent.
2186 Source_Parent.Children := Children_Type'(others => null);
2188 -- Fix up the Parent pointers of each child to designate its new Target
2192 while C /= null loop
2193 C.Parent := Target_Parent;
2200 Parent => Target_Parent,
2202 end Splice_Children;
2204 --------------------
2205 -- Splice_Subtree --
2206 --------------------
2208 procedure Splice_Subtree
2209 (Target : in out Tree;
2212 Source : in out Tree;
2213 Position : in out Cursor)
2215 Subtree_Count : Count_Type;
2218 if Parent = No_Element then
2219 raise Constraint_Error with "Parent cursor has no element";
2222 if Parent.Container /= Target'Unrestricted_Access then
2223 raise Program_Error with "Parent cursor not in Target container";
2226 if Before /= No_Element then
2227 if Before.Container /= Target'Unrestricted_Access then
2228 raise Program_Error with "Before cursor not in Target container";
2231 if Before.Node.Parent /= Parent.Node then
2232 raise Constraint_Error with "Before cursor not child of Parent";
2236 if Position = No_Element then
2237 raise Constraint_Error with "Position cursor has no element";
2240 if Position.Container /= Source'Unrestricted_Access then
2241 raise Program_Error with "Position cursor not in Source container";
2244 if Is_Root (Position) then
2245 raise Program_Error with "Position cursor designates root";
2248 if Target'Address = Source'Address then
2249 if Position.Node.Parent = Parent.Node then
2250 if Position.Node = Before.Node then
2254 if Position.Node.Next = Before.Node then
2259 if Target.Busy > 0 then
2261 with "attempt to tamper with cursors (Target tree is busy)";
2264 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2265 raise Constraint_Error with "Position is ancestor of Parent";
2268 Remove_Subtree (Position.Node);
2270 Position.Node.Parent := Parent.Node;
2271 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2276 if Target.Busy > 0 then
2278 with "attempt to tamper with cursors (Target tree is busy)";
2281 if Source.Busy > 0 then
2283 with "attempt to tamper with cursors (Source tree is busy)";
2286 -- This is an unfortunate feature of this API: we must count the nodes
2287 -- in the subtree that we remove from the source tree, which is an O(n)
2288 -- operation. It would have been better if the Tree container did not
2289 -- have a Node_Count selector; a user that wants the number of nodes in
2290 -- the tree could simply call Subtree_Node_Count, with the understanding
2291 -- that such an operation is O(n).
2293 -- Of course, we could choose to implement the Node_Count selector as an
2294 -- O(n) operation, which would turn this splice operation into an O(1)
2297 Subtree_Count := Subtree_Node_Count (Position.Node);
2298 pragma Assert (Subtree_Count <= Source.Count);
2300 Remove_Subtree (Position.Node);
2301 Source.Count := Source.Count - Subtree_Count;
2303 Position.Node.Parent := Parent.Node;
2304 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2306 Target.Count := Target.Count + Subtree_Count;
2308 Position.Container := Target'Unrestricted_Access;
2311 procedure Splice_Subtree
2312 (Container : in out Tree;
2318 if Parent = No_Element then
2319 raise Constraint_Error with "Parent cursor has no element";
2322 if Parent.Container /= Container'Unrestricted_Access then
2323 raise Program_Error with "Parent cursor not in container";
2326 if Before /= No_Element then
2327 if Before.Container /= Container'Unrestricted_Access then
2328 raise Program_Error with "Before cursor not in 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 /= Container'Unrestricted_Access then
2341 raise Program_Error with "Position cursor not in container";
2344 if Is_Root (Position) then
2346 -- Should this be PE instead? Need ARG confirmation. ???
2348 raise Constraint_Error with "Position cursor designates root";
2351 if Position.Node.Parent = Parent.Node then
2352 if Position.Node = Before.Node then
2356 if Position.Node.Next = Before.Node then
2361 if Container.Busy > 0 then
2363 with "attempt to tamper with cursors (tree is busy)";
2366 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2367 raise Constraint_Error with "Position is ancestor of Parent";
2370 Remove_Subtree (Position.Node);
2372 Position.Node.Parent := Parent.Node;
2373 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2376 ------------------------
2377 -- Subtree_Node_Count --
2378 ------------------------
2380 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2382 if Position = No_Element then
2386 return Subtree_Node_Count (Position.Node);
2387 end Subtree_Node_Count;
2389 function Subtree_Node_Count
2390 (Subtree : Tree_Node_Access) return Count_Type
2392 Result : Count_Type;
2393 Node : Tree_Node_Access;
2397 Node := Subtree.Children.First;
2398 while Node /= null loop
2399 Result := Result + Subtree_Node_Count (Node);
2404 end Subtree_Node_Count;
2411 (Container : in out Tree;
2415 if I = No_Element then
2416 raise Constraint_Error with "I cursor has no element";
2419 if I.Container /= Container'Unrestricted_Access then
2420 raise Program_Error with "I cursor not in container";
2424 raise Program_Error with "I cursor designates root";
2427 if I = J then -- make this test sooner???
2431 if J = No_Element then
2432 raise Constraint_Error with "J cursor has no element";
2435 if J.Container /= Container'Unrestricted_Access then
2436 raise Program_Error with "J cursor not in container";
2440 raise Program_Error with "J cursor designates root";
2443 if Container.Lock > 0 then
2445 with "attempt to tamper with elements (tree is locked)";
2449 EI : constant Element_Access := I.Node.Element;
2452 I.Node.Element := J.Node.Element;
2453 J.Node.Element := EI;
2457 --------------------
2458 -- Update_Element --
2459 --------------------
2461 procedure Update_Element
2462 (Container : in out Tree;
2464 Process : not null access procedure (Element : in out Element_Type))
2467 if Position = No_Element then
2468 raise Constraint_Error with "Position cursor has no element";
2471 if Position.Container /= Container'Unrestricted_Access then
2472 raise Program_Error with "Position cursor not in container";
2475 if Is_Root (Position) then
2476 raise Program_Error with "Position cursor designates root";
2480 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2481 B : Integer renames T.Busy;
2482 L : Integer renames T.Lock;
2488 Process (Position.Node.Element.all);
2506 (Stream : not null access Root_Stream_Type'Class;
2509 procedure Write_Children (Subtree : Tree_Node_Access);
2510 procedure Write_Subtree (Subtree : Tree_Node_Access);
2512 --------------------
2513 -- Write_Children --
2514 --------------------
2516 procedure Write_Children (Subtree : Tree_Node_Access) is
2517 CC : Children_Type renames Subtree.Children;
2518 C : Tree_Node_Access;
2521 Count_Type'Write (Stream, Child_Count (CC));
2524 while C /= null loop
2534 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2536 Element_Type'Output (Stream, Subtree.Element.all);
2537 Write_Children (Subtree);
2540 -- Start of processing for Write
2543 Count_Type'Write (Stream, Container.Count);
2545 if Container.Count = 0 then
2549 Write_Children (Root_Node (Container));
2553 (Stream : not null access Root_Stream_Type'Class;
2557 raise Program_Error with "attempt to write tree cursor to stream";
2561 (Stream : not null access Root_Stream_Type'Class;
2562 Item : Reference_Type)
2565 raise Program_Error with "attempt to stream reference";
2569 (Stream : not null access Root_Stream_Type'Class;
2570 Item : Constant_Reference_Type)
2573 raise Program_Error with "attempt to stream reference";
2576 end Ada.Containers.Indefinite_Multiway_Trees;