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 type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with
44 Container : Tree_Access;
48 overriding function First (Object : Iterator) return Cursor;
49 overriding function Next
51 Position : Cursor) return Cursor;
53 overriding function First (Object : Child_Iterator) return Cursor;
54 overriding function Next
55 (Object : Child_Iterator;
56 Position : Cursor) return Cursor;
58 overriding function Previous
59 (Object : Child_Iterator;
60 Position : Cursor) return Cursor;
62 overriding function Last (Object : Child_Iterator) return Cursor;
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function Root_Node (Container : Tree) return Tree_Node_Access;
70 procedure Free_Element is
71 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
73 procedure Deallocate_Node (X : in out Tree_Node_Access);
75 procedure Deallocate_Children
76 (Subtree : Tree_Node_Access;
77 Count : in out Count_Type);
79 procedure Deallocate_Subtree
80 (Subtree : in out Tree_Node_Access;
81 Count : in out Count_Type);
83 function Equal_Children
84 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
86 function Equal_Subtree
87 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
89 procedure Iterate_Children
90 (Container : Tree_Access;
91 Subtree : Tree_Node_Access;
92 Process : not null access procedure (Position : Cursor));
94 procedure Iterate_Subtree
95 (Container : Tree_Access;
96 Subtree : Tree_Node_Access;
97 Process : not null access procedure (Position : Cursor));
99 procedure Copy_Children
100 (Source : Children_Type;
101 Parent : Tree_Node_Access;
102 Count : in out Count_Type);
104 procedure Copy_Subtree
105 (Source : Tree_Node_Access;
106 Parent : Tree_Node_Access;
107 Target : out Tree_Node_Access;
108 Count : in out Count_Type);
110 function Find_In_Children
111 (Subtree : Tree_Node_Access;
112 Item : Element_Type) return Tree_Node_Access;
114 function Find_In_Subtree
115 (Subtree : Tree_Node_Access;
116 Item : Element_Type) return Tree_Node_Access;
118 function Child_Count (Children : Children_Type) return Count_Type;
120 function Subtree_Node_Count
121 (Subtree : Tree_Node_Access) return Count_Type;
123 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
125 procedure Remove_Subtree (Subtree : Tree_Node_Access);
127 procedure Insert_Subtree_Node
128 (Subtree : Tree_Node_Access;
129 Parent : Tree_Node_Access;
130 Before : Tree_Node_Access);
132 procedure Insert_Subtree_List
133 (First : Tree_Node_Access;
134 Last : Tree_Node_Access;
135 Parent : Tree_Node_Access;
136 Before : Tree_Node_Access);
138 procedure Splice_Children
139 (Target_Parent : Tree_Node_Access;
140 Before : Tree_Node_Access;
141 Source_Parent : Tree_Node_Access);
147 function "=" (Left, Right : Tree) return Boolean is
149 if Left'Address = Right'Address then
153 return Equal_Children (Root_Node (Left), Root_Node (Right));
160 procedure Adjust (Container : in out Tree) is
161 Source : constant Children_Type := Container.Root.Children;
162 Source_Count : constant Count_Type := Container.Count;
163 Target_Count : Count_Type;
166 -- We first restore the target container to its default-initialized
167 -- state, before we attempt any allocation, to ensure that invariants
168 -- are preserved in the event that the allocation fails.
170 Container.Root.Children := Children_Type'(others => null);
173 Container.Count := 0;
175 -- Copy_Children returns a count of the number of nodes that it
176 -- allocates, but it works by incrementing the value that is passed in.
177 -- We must therefore initialize the count value before calling
182 -- Now we attempt the allocation of subtrees. The invariants are
183 -- satisfied even if the allocation fails.
185 Copy_Children (Source, Root_Node (Container), Target_Count);
186 pragma Assert (Target_Count = Source_Count);
188 Container.Count := Source_Count;
195 function Ancestor_Find
197 Item : Element_Type) return Cursor
199 R, N : Tree_Node_Access;
202 if Position = No_Element then
203 raise Constraint_Error with "Position cursor has no element";
206 -- Commented-out pending ARG ruling. ???
208 -- if Position.Container /= Container'Unrestricted_Access then
209 -- raise Program_Error with "Position cursor not in container";
212 -- AI-0136 says to raise PE if Position equals the root node. This does
213 -- not seem correct, as this value is just the limiting condition of the
214 -- search. For now we omit this check pending a ruling from the ARG.???
216 -- if Is_Root (Position) then
217 -- raise Program_Error with "Position cursor designates root";
220 R := Root_Node (Position.Container.all);
223 if N.Element.all = Item then
224 return Cursor'(Position.Container, N);
237 procedure Append_Child
238 (Container : in out Tree;
240 New_Item : Element_Type;
241 Count : Count_Type := 1)
243 First, Last : Tree_Node_Access;
244 Element : Element_Access;
247 if Parent = No_Element then
248 raise Constraint_Error with "Parent cursor has no element";
251 if Parent.Container /= Container'Unrestricted_Access then
252 raise Program_Error with "Parent cursor not in container";
259 if Container.Busy > 0 then
261 with "attempt to tamper with cursors (tree is busy)";
264 Element := new Element_Type'(New_Item);
265 First := new Tree_Node_Type'(Parent => Parent.Node,
271 for J in Count_Type'(2) .. Count loop
273 -- Reclaim other nodes if Storage_Error. ???
275 Element := new Element_Type'(New_Item);
276 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
287 Parent => Parent.Node,
288 Before => null); -- null means "insert at end of list"
290 -- In order for operation Node_Count to complete in O(1) time, we cache
291 -- the count value. Here we increment the total count by the number of
292 -- nodes we just inserted.
294 Container.Count := Container.Count + Count;
301 procedure Assign (Target : in out Tree; Source : Tree) is
302 Source_Count : constant Count_Type := Source.Count;
303 Target_Count : Count_Type;
306 if Target'Address = Source'Address then
310 Target.Clear; -- checks busy bit
312 -- Copy_Children returns the number of nodes that it allocates, but it
313 -- does this by incrementing the count value passed in, so we must
314 -- initialize the count before calling Copy_Children.
318 -- Note that Copy_Children inserts the newly-allocated children into
319 -- their parent list only after the allocation of all the children has
320 -- succeeded. This preserves invariants even if the allocation fails.
322 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
323 pragma Assert (Target_Count = Source_Count);
325 Target.Count := Source_Count;
332 function Child_Count (Parent : Cursor) return Count_Type is
334 if Parent = No_Element then
337 return Child_Count (Parent.Node.Children);
341 function Child_Count (Children : Children_Type) return Count_Type is
343 Node : Tree_Node_Access;
347 Node := Children.First;
348 while Node /= null loop
349 Result := Result + 1;
360 function Child_Depth (Parent, Child : Cursor) return Count_Type is
362 N : Tree_Node_Access;
365 if Parent = No_Element then
366 raise Constraint_Error with "Parent cursor has no element";
369 if Child = No_Element then
370 raise Constraint_Error with "Child cursor has no element";
373 if Parent.Container /= Child.Container then
374 raise Program_Error with "Parent and Child in different containers";
379 while N /= Parent.Node loop
380 Result := Result + 1;
384 raise Program_Error with "Parent is not ancestor of Child";
395 procedure Clear (Container : in out Tree) is
396 Container_Count : Count_Type;
397 Children_Count : Count_Type;
400 if Container.Busy > 0 then
402 with "attempt to tamper with cursors (tree is busy)";
405 -- We first set the container count to 0, in order to preserve
406 -- invariants in case the deallocation fails. (This works because
407 -- Deallocate_Children immediately removes the children from their
408 -- parent, and then does the actual deallocation.)
410 Container_Count := Container.Count;
411 Container.Count := 0;
413 -- Deallocate_Children returns the number of nodes that it deallocates,
414 -- but it does this by incrementing the count value that is passed in,
415 -- so we must first initialize the count return value before calling it.
419 -- See comment above. Deallocate_Children immediately removes the
420 -- children list from their parent node (here, the root of the tree),
421 -- and only after that does it attempt the actual deallocation. So even
422 -- if the deallocation fails, the representation invariants
424 Deallocate_Children (Root_Node (Container), Children_Count);
425 pragma Assert (Children_Count = Container_Count);
434 Item : Element_Type) return Boolean
437 return Find (Container, Item) /= No_Element;
444 function Copy (Source : Tree) return Tree is
446 return Target : Tree do
448 (Source => Source.Root.Children,
449 Parent => Root_Node (Target),
450 Count => Target.Count);
452 pragma Assert (Target.Count = Source.Count);
460 procedure Copy_Children
461 (Source : Children_Type;
462 Parent : Tree_Node_Access;
463 Count : in out Count_Type)
465 pragma Assert (Parent /= null);
466 pragma Assert (Parent.Children.First = null);
467 pragma Assert (Parent.Children.Last = null);
470 C : Tree_Node_Access;
473 -- We special-case the first allocation, in order to establish the
474 -- representation invariants for type Children_Type.
490 -- The representation invariants for the Children_Type list have been
491 -- established, so we can now copy the remaining children of Source.
498 Target => CC.Last.Next,
501 CC.Last.Next.Prev := CC.Last;
502 CC.Last := CC.Last.Next;
507 -- We add the newly-allocated children to their parent list only after
508 -- the allocation has succeeded, in order to preserve invariants of the
511 Parent.Children := CC;
518 procedure Copy_Subtree
519 (Target : in out Tree;
524 Target_Subtree : Tree_Node_Access;
525 Target_Count : Count_Type;
528 if Parent = No_Element then
529 raise Constraint_Error with "Parent cursor has no element";
532 if Parent.Container /= Target'Unrestricted_Access then
533 raise Program_Error with "Parent cursor not in container";
536 if Before /= No_Element then
537 if Before.Container /= Target'Unrestricted_Access then
538 raise Program_Error with "Before cursor not in container";
541 if Before.Node.Parent /= Parent.Node then
542 raise Constraint_Error with "Before cursor not child of Parent";
546 if Source = No_Element then
550 if Is_Root (Source) then
551 raise Constraint_Error with "Source cursor designates root";
554 -- Copy_Subtree returns a count of the number of nodes that it
555 -- allocates, but it works by incrementing the value that is passed in.
556 -- We must therefore initialize the count value before calling
562 (Source => Source.Node,
563 Parent => Parent.Node,
564 Target => Target_Subtree,
565 Count => Target_Count);
567 pragma Assert (Target_Subtree /= null);
568 pragma Assert (Target_Subtree.Parent = Parent.Node);
569 pragma Assert (Target_Count >= 1);
572 (Subtree => Target_Subtree,
573 Parent => Parent.Node,
574 Before => Before.Node);
576 -- In order for operation Node_Count to complete in O(1) time, we cache
577 -- the count value. Here we increment the total count by the number of
578 -- nodes we just inserted.
580 Target.Count := Target.Count + Target_Count;
583 procedure Copy_Subtree
584 (Source : Tree_Node_Access;
585 Parent : Tree_Node_Access;
586 Target : out Tree_Node_Access;
587 Count : in out Count_Type)
589 E : constant Element_Access := new Element_Type'(Source.Element.all);
592 Target := new Tree_Node_Type'(Element => E,
599 (Source => Source.Children,
604 -------------------------
605 -- Deallocate_Children --
606 -------------------------
608 procedure Deallocate_Children
609 (Subtree : Tree_Node_Access;
610 Count : in out Count_Type)
612 pragma Assert (Subtree /= null);
614 CC : Children_Type := Subtree.Children;
615 C : Tree_Node_Access;
618 -- We immediately remove the children from their parent, in order to
619 -- preserve invariants in case the deallocation fails.
621 Subtree.Children := Children_Type'(others => null);
623 while CC.First /= null loop
627 Deallocate_Subtree (C, Count);
629 end Deallocate_Children;
631 ---------------------
632 -- Deallocate_Node --
633 ---------------------
635 procedure Deallocate_Node (X : in out Tree_Node_Access) is
636 procedure Free_Node is
637 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
639 -- Start of processing for Deallocate_Node
643 Free_Element (X.Element);
648 ------------------------
649 -- Deallocate_Subtree --
650 ------------------------
652 procedure Deallocate_Subtree
653 (Subtree : in out Tree_Node_Access;
654 Count : in out Count_Type)
657 Deallocate_Children (Subtree, Count);
658 Deallocate_Node (Subtree);
660 end Deallocate_Subtree;
662 ---------------------
663 -- Delete_Children --
664 ---------------------
666 procedure Delete_Children
667 (Container : in out Tree;
673 if Parent = No_Element then
674 raise Constraint_Error with "Parent cursor has no element";
677 if Parent.Container /= Container'Unrestricted_Access then
678 raise Program_Error with "Parent cursor not in container";
681 if Container.Busy > 0 then
683 with "attempt to tamper with cursors (tree is busy)";
686 -- Deallocate_Children returns a count of the number of nodes
687 -- that it deallocates, but it works by incrementing the
688 -- value that is passed in. We must therefore initialize
689 -- the count value before calling Deallocate_Children.
693 Deallocate_Children (Parent.Node, Count);
694 pragma Assert (Count <= Container.Count);
696 Container.Count := Container.Count - Count;
703 procedure Delete_Leaf
704 (Container : in out Tree;
705 Position : in out Cursor)
707 X : Tree_Node_Access;
710 if Position = No_Element then
711 raise Constraint_Error with "Position cursor has no element";
714 if Position.Container /= Container'Unrestricted_Access then
715 raise Program_Error with "Position cursor not in container";
718 if Is_Root (Position) then
719 raise Program_Error with "Position cursor designates root";
722 if not Is_Leaf (Position) then
723 raise Constraint_Error with "Position cursor does not designate leaf";
726 if Container.Busy > 0 then
728 with "attempt to tamper with cursors (tree is busy)";
732 Position := No_Element;
734 -- Restore represention invariants before attempting the actual
738 Container.Count := Container.Count - 1;
740 -- It is now safe to attempt the deallocation. This leaf node has been
741 -- disassociated from the tree, so even if the deallocation fails,
742 -- representation invariants will remain satisfied.
751 procedure Delete_Subtree
752 (Container : in out Tree;
753 Position : in out Cursor)
755 X : Tree_Node_Access;
759 if Position = No_Element then
760 raise Constraint_Error with "Position cursor has no element";
763 if Position.Container /= Container'Unrestricted_Access then
764 raise Program_Error with "Position cursor not in container";
767 if Is_Root (Position) then
768 raise Program_Error with "Position cursor designates root";
771 if Container.Busy > 0 then
773 with "attempt to tamper with cursors (tree is busy)";
777 Position := No_Element;
779 -- Here is one case where a deallocation failure can result in the
780 -- violation of a representation invariant. We disassociate the subtree
781 -- from the tree now, but we only decrement the total node count after
782 -- we attempt the deallocation. However, if the deallocation fails, the
783 -- total node count will not get decremented.
785 -- One way around this dilemma is to count the nodes in the subtree
786 -- before attempt to delete the subtree, but that is an O(n) operation,
787 -- so it does not seem worth it.
789 -- Perhaps this is much ado about nothing, since the only way
790 -- deallocation can fail is if Controlled Finalization fails: this
791 -- propagates Program_Error so all bets are off anyway. ???
795 -- Deallocate_Subtree returns a count of the number of nodes that it
796 -- deallocates, but it works by incrementing the value that is passed
797 -- in. We must therefore initialize the count value before calling
798 -- Deallocate_Subtree.
802 Deallocate_Subtree (X, Count);
803 pragma Assert (Count <= Container.Count);
805 -- See comments above. We would prefer to do this sooner, but there's no
806 -- way to satisfy that goal without an potentially severe execution
809 Container.Count := Container.Count - Count;
816 function Depth (Position : Cursor) return Count_Type is
818 N : Tree_Node_Access;
825 Result := Result + 1;
835 function Element (Position : Cursor) return Element_Type is
837 if Position.Container = null then
838 raise Constraint_Error with "Position cursor has no element";
841 if Position.Node = Root_Node (Position.Container.all) then
842 raise Program_Error with "Position cursor designates root";
845 return Position.Node.Element.all;
852 function Equal_Children
853 (Left_Subtree : Tree_Node_Access;
854 Right_Subtree : Tree_Node_Access) return Boolean
856 Left_Children : Children_Type renames Left_Subtree.Children;
857 Right_Children : Children_Type renames Right_Subtree.Children;
859 L, R : Tree_Node_Access;
862 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
866 L := Left_Children.First;
867 R := Right_Children.First;
869 if not Equal_Subtree (L, R) then
884 function Equal_Subtree
885 (Left_Position : Cursor;
886 Right_Position : Cursor) return Boolean
889 if Left_Position = No_Element then
890 raise Constraint_Error with "Left cursor has no element";
893 if Right_Position = No_Element then
894 raise Constraint_Error with "Right cursor has no element";
897 if Left_Position = Right_Position then
901 if Is_Root (Left_Position) then
902 if not Is_Root (Right_Position) then
906 return Equal_Children (Left_Position.Node, Right_Position.Node);
909 if Is_Root (Right_Position) then
913 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
916 function Equal_Subtree
917 (Left_Subtree : Tree_Node_Access;
918 Right_Subtree : Tree_Node_Access) return Boolean
921 if Left_Subtree.Element.all /= Right_Subtree.Element.all then
925 return Equal_Children (Left_Subtree, Right_Subtree);
934 Item : Element_Type) return Cursor
936 N : constant Tree_Node_Access :=
937 Find_In_Children (Root_Node (Container), Item);
944 return Cursor'(Container'Unrestricted_Access, N);
951 function First (Object : Iterator) return Cursor is
953 return Object.Position;
956 function First (Object : Child_Iterator) return Cursor is
958 return (Object.Container, Object.Position.Node.Children.First);
965 function First_Child (Parent : Cursor) return Cursor is
966 Node : Tree_Node_Access;
969 if Parent = No_Element then
970 raise Constraint_Error with "Parent cursor has no element";
973 Node := Parent.Node.Children.First;
979 return Cursor'(Parent.Container, Node);
982 -------------------------
983 -- First_Child_Element --
984 -------------------------
986 function First_Child_Element (Parent : Cursor) return Element_Type is
988 return Element (First_Child (Parent));
989 end First_Child_Element;
991 ----------------------
992 -- Find_In_Children --
993 ----------------------
995 function Find_In_Children
996 (Subtree : Tree_Node_Access;
997 Item : Element_Type) return Tree_Node_Access
999 N, Result : Tree_Node_Access;
1002 N := Subtree.Children.First;
1003 while N /= null loop
1004 Result := Find_In_Subtree (N, Item);
1006 if Result /= null then
1014 end Find_In_Children;
1016 ---------------------
1017 -- Find_In_Subtree --
1018 ---------------------
1020 function Find_In_Subtree
1022 Item : Element_Type) return Cursor
1024 Result : Tree_Node_Access;
1027 if Position = No_Element then
1028 raise Constraint_Error with "Position cursor has no element";
1031 -- Commented-out pending ruling from ARG. ???
1033 -- if Position.Container /= Container'Unrestricted_Access then
1034 -- raise Program_Error with "Position cursor not in container";
1037 if Is_Root (Position) then
1038 Result := Find_In_Children (Position.Node, Item);
1041 Result := Find_In_Subtree (Position.Node, Item);
1044 if Result = null then
1048 return Cursor'(Position.Container, Result);
1049 end Find_In_Subtree;
1051 function Find_In_Subtree
1052 (Subtree : Tree_Node_Access;
1053 Item : Element_Type) return Tree_Node_Access
1056 if Subtree.Element.all = Item then
1060 return Find_In_Children (Subtree, Item);
1061 end Find_In_Subtree;
1067 function Has_Element (Position : Cursor) return Boolean is
1069 if Position = No_Element then
1073 return Position.Node.Parent /= null;
1080 procedure Insert_Child
1081 (Container : in out Tree;
1084 New_Item : Element_Type;
1085 Count : Count_Type := 1)
1088 pragma Unreferenced (Position);
1091 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1094 procedure Insert_Child
1095 (Container : in out Tree;
1098 New_Item : Element_Type;
1099 Position : out Cursor;
1100 Count : Count_Type := 1)
1102 Last : Tree_Node_Access;
1103 Element : Element_Access;
1106 if Parent = No_Element then
1107 raise Constraint_Error with "Parent cursor has no element";
1110 if Parent.Container /= Container'Unrestricted_Access then
1111 raise Program_Error with "Parent cursor not in container";
1114 if Before /= No_Element then
1115 if Before.Container /= Container'Unrestricted_Access then
1116 raise Program_Error with "Before cursor not in container";
1119 if Before.Node.Parent /= Parent.Node then
1120 raise Constraint_Error with "Parent cursor not parent of Before";
1125 Position := No_Element; -- Need ruling from ARG ???
1129 if Container.Busy > 0 then
1131 with "attempt to tamper with cursors (tree is busy)";
1134 Position.Container := Parent.Container;
1136 Element := new Element_Type'(New_Item);
1137 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1141 Last := Position.Node;
1143 for J in Count_Type'(2) .. Count loop
1144 -- Reclaim other nodes if Storage_Error. ???
1146 Element := new Element_Type'(New_Item);
1147 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1156 (First => Position.Node,
1158 Parent => Parent.Node,
1159 Before => Before.Node);
1161 -- In order for operation Node_Count to complete in O(1) time, we cache
1162 -- the count value. Here we increment the total count by the number of
1163 -- nodes we just inserted.
1165 Container.Count := Container.Count + Count;
1168 -------------------------
1169 -- Insert_Subtree_List --
1170 -------------------------
1172 procedure Insert_Subtree_List
1173 (First : Tree_Node_Access;
1174 Last : Tree_Node_Access;
1175 Parent : Tree_Node_Access;
1176 Before : Tree_Node_Access)
1178 pragma Assert (Parent /= null);
1179 C : Children_Type renames Parent.Children;
1182 -- This is a simple utility operation to insert a list of nodes (from
1183 -- First..Last) as children of Parent. The Before node specifies where
1184 -- the new children should be inserted relative to the existing
1187 if First = null then
1188 pragma Assert (Last = null);
1192 pragma Assert (Last /= null);
1193 pragma Assert (Before = null or else Before.Parent = Parent);
1195 if C.First = null then
1197 C.First.Prev := null;
1199 C.Last.Next := null;
1201 elsif Before = null then -- means "insert after existing nodes"
1202 C.Last.Next := First;
1203 First.Prev := C.Last;
1205 C.Last.Next := null;
1207 elsif Before = C.First then
1208 Last.Next := C.First;
1209 C.First.Prev := Last;
1211 C.First.Prev := null;
1214 Before.Prev.Next := First;
1215 First.Prev := Before.Prev;
1216 Last.Next := Before;
1217 Before.Prev := Last;
1219 end Insert_Subtree_List;
1221 -------------------------
1222 -- Insert_Subtree_Node --
1223 -------------------------
1225 procedure Insert_Subtree_Node
1226 (Subtree : Tree_Node_Access;
1227 Parent : Tree_Node_Access;
1228 Before : Tree_Node_Access)
1231 -- This is a simple wrapper operation to insert a single child into the
1232 -- Parent's children list.
1239 end Insert_Subtree_Node;
1245 function Is_Empty (Container : Tree) return Boolean is
1247 return Container.Root.Children.First = null;
1254 function Is_Leaf (Position : Cursor) return Boolean is
1256 if Position = No_Element then
1260 return Position.Node.Children.First = null;
1267 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1268 pragma Assert (From /= null);
1269 pragma Assert (To /= null);
1271 N : Tree_Node_Access;
1275 while N /= null loop
1290 function Is_Root (Position : Cursor) return Boolean is
1292 if Position.Container = null then
1296 return Position = Root (Position.Container.all);
1305 Process : not null access procedure (Position : Cursor))
1307 T : Tree renames Container'Unrestricted_Access.all;
1308 B : Integer renames T.Busy;
1314 (Container => Container'Unrestricted_Access,
1315 Subtree => Root_Node (Container),
1316 Process => Process);
1326 function Iterate (Container : Tree)
1327 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1329 Root_Cursor : constant Cursor :=
1330 (Container'Unrestricted_Access, Root_Node (Container));
1333 Iterator'(Container'Unrestricted_Access,
1334 First_Child (Root_Cursor),
1338 ----------------------
1339 -- Iterate_Children --
1340 ----------------------
1342 procedure Iterate_Children
1344 Process : not null access procedure (Position : Cursor))
1347 if Parent = No_Element then
1348 raise Constraint_Error with "Parent cursor has no element";
1352 B : Integer renames Parent.Container.Busy;
1353 C : Tree_Node_Access;
1358 C := Parent.Node.Children.First;
1359 while C /= null loop
1360 Process (Position => Cursor'(Parent.Container, Node => C));
1371 end Iterate_Children;
1373 procedure Iterate_Children
1374 (Container : Tree_Access;
1375 Subtree : Tree_Node_Access;
1376 Process : not null access procedure (Position : Cursor))
1378 Node : Tree_Node_Access;
1381 -- This is a helper function to recursively iterate over all the nodes
1382 -- in a subtree, in depth-first fashion. This particular helper just
1383 -- visits the children of this subtree, not the root of the subtree node
1384 -- itself. This is useful when starting from the ultimate root of the
1385 -- entire tree (see Iterate), as that root does not have an element.
1387 Node := Subtree.Children.First;
1388 while Node /= null loop
1389 Iterate_Subtree (Container, Node, Process);
1392 end Iterate_Children;
1394 function Iterate_Children
1397 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1399 pragma Unreferenced (Container);
1401 return Child_Iterator'(Parent.Container, Parent);
1402 end Iterate_Children;
1404 ---------------------
1405 -- Iterate_Subtree --
1406 ---------------------
1408 function Iterate_Subtree
1410 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1413 return Iterator'(Position.Container, Position, From_Root => False);
1414 end Iterate_Subtree;
1416 procedure Iterate_Subtree
1418 Process : not null access procedure (Position : Cursor))
1421 if Position = No_Element then
1422 raise Constraint_Error with "Position cursor has no element";
1426 B : Integer renames Position.Container.Busy;
1431 if Is_Root (Position) then
1432 Iterate_Children (Position.Container, Position.Node, Process);
1434 Iterate_Subtree (Position.Container, Position.Node, Process);
1444 end Iterate_Subtree;
1446 procedure Iterate_Subtree
1447 (Container : Tree_Access;
1448 Subtree : Tree_Node_Access;
1449 Process : not null access procedure (Position : Cursor))
1452 -- This is a helper function to recursively iterate over all the nodes
1453 -- in a subtree, in depth-first fashion. It first visits the root of the
1454 -- subtree, then visits its children.
1456 Process (Cursor'(Container, Subtree));
1457 Iterate_Children (Container, Subtree, Process);
1458 end Iterate_Subtree;
1464 overriding function Last (Object : Child_Iterator) return Cursor is
1466 return (Object.Container, Object.Position.Node.Children.Last);
1473 function Last_Child (Parent : Cursor) return Cursor is
1474 Node : Tree_Node_Access;
1477 if Parent = No_Element then
1478 raise Constraint_Error with "Parent cursor has no element";
1481 Node := Parent.Node.Children.Last;
1487 return (Parent.Container, Node);
1490 ------------------------
1491 -- Last_Child_Element --
1492 ------------------------
1494 function Last_Child_Element (Parent : Cursor) return Element_Type is
1496 return Element (Last_Child (Parent));
1497 end Last_Child_Element;
1503 procedure Move (Target : in out Tree; Source : in out Tree) is
1504 Node : Tree_Node_Access;
1507 if Target'Address = Source'Address then
1511 if Source.Busy > 0 then
1513 with "attempt to tamper with cursors of Source (tree is busy)";
1516 Target.Clear; -- checks busy bit
1518 Target.Root.Children := Source.Root.Children;
1519 Source.Root.Children := Children_Type'(others => null);
1521 Node := Target.Root.Children.First;
1522 while Node /= null loop
1523 Node.Parent := Root_Node (Target);
1527 Target.Count := Source.Count;
1537 Position : Cursor) return Cursor
1539 T : Tree renames Position.Container.all;
1540 N : constant Tree_Node_Access := Position.Node;
1543 if Is_Leaf (Position) then
1545 -- If sibling is present, return it
1547 if N.Next /= null then
1548 return (Object.Container, N.Next);
1550 -- If this is the last sibling, go to sibling of first ancestor that
1551 -- has a sibling, or terminate.
1555 Par : Tree_Node_Access := N.Parent;
1558 while Par.Next = null loop
1560 -- If we are back at the root the iteration is complete
1562 if Par = Root_Node (T) then
1565 -- If this is a subtree iterator and we are back at the
1566 -- starting node, iteration is complete.
1568 elsif Par = Object.Position.Node
1569 and then not Object.From_Root
1578 if Par = Object.Position.Node
1579 and then not Object.From_Root
1584 return (Object.Container, Par.Next);
1588 -- If an internal node, return its first child
1591 return (Object.Container, N.Children.First);
1596 (Object : Child_Iterator;
1597 Position : Cursor) return Cursor
1599 C : constant Tree_Node_Access := Position.Node.Next;
1606 return (Object.Container, C);
1614 function Next_Sibling (Position : Cursor) return Cursor is
1616 if Position = No_Element then
1620 if Position.Node.Next = null then
1624 return Cursor'(Position.Container, Position.Node.Next);
1627 procedure Next_Sibling (Position : in out Cursor) is
1629 Position := Next_Sibling (Position);
1636 function Node_Count (Container : Tree) return Count_Type is
1638 -- Container.Count is the number of nodes we have actually allocated. We
1639 -- cache the value specifically so this Node_Count operation can execute
1640 -- in O(1) time, which makes it behave similarly to how the Length
1641 -- selector function behaves for other containers.
1643 -- The cached node count value only describes the nodes we have
1644 -- allocated; the root node itself is not included in that count. The
1645 -- Node_Count operation returns a value that includes the root node
1646 -- (because the RM says so), so we must add 1 to our cached value.
1648 return 1 + Container.Count;
1655 function Parent (Position : Cursor) return Cursor is
1657 if Position = No_Element then
1661 if Position.Node.Parent = null then
1665 return Cursor'(Position.Container, Position.Node.Parent);
1672 procedure Prepend_Child
1673 (Container : in out Tree;
1675 New_Item : Element_Type;
1676 Count : Count_Type := 1)
1678 First, Last : Tree_Node_Access;
1679 Element : Element_Access;
1682 if Parent = No_Element then
1683 raise Constraint_Error with "Parent cursor has no element";
1686 if Parent.Container /= Container'Unrestricted_Access then
1687 raise Program_Error with "Parent cursor not in container";
1694 if Container.Busy > 0 then
1696 with "attempt to tamper with cursors (tree is busy)";
1699 Element := new Element_Type'(New_Item);
1700 First := new Tree_Node_Type'(Parent => Parent.Node,
1706 for J in Count_Type'(2) .. Count loop
1708 -- Reclaim other nodes if Storage_Error. ???
1710 Element := new Element_Type'(New_Item);
1711 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1722 Parent => Parent.Node,
1723 Before => Parent.Node.Children.First);
1725 -- In order for operation Node_Count to complete in O(1) time, we cache
1726 -- the count value. Here we increment the total count by the number of
1727 -- nodes we just inserted.
1729 Container.Count := Container.Count + Count;
1736 overriding function Previous
1737 (Object : Child_Iterator;
1738 Position : Cursor) return Cursor
1740 C : constant Tree_Node_Access := Position.Node.Prev;
1747 return (Object.Container, C);
1751 ----------------------
1752 -- Previous_Sibling --
1753 ----------------------
1755 function Previous_Sibling (Position : Cursor) return Cursor is
1757 if Position = No_Element then
1761 if Position.Node.Prev = null then
1765 return Cursor'(Position.Container, Position.Node.Prev);
1766 end Previous_Sibling;
1768 procedure Previous_Sibling (Position : in out Cursor) is
1770 Position := Previous_Sibling (Position);
1771 end Previous_Sibling;
1777 procedure Query_Element
1779 Process : not null access procedure (Element : Element_Type))
1782 if Position = No_Element then
1783 raise Constraint_Error with "Position cursor has no element";
1786 if Is_Root (Position) then
1787 raise Program_Error with "Position cursor designates root";
1791 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1792 B : Integer renames T.Busy;
1793 L : Integer renames T.Lock;
1799 Process (Position.Node.Element.all);
1817 (Stream : not null access Root_Stream_Type'Class;
1818 Container : out Tree)
1820 procedure Read_Children (Subtree : Tree_Node_Access);
1822 function Read_Subtree
1823 (Parent : Tree_Node_Access) return Tree_Node_Access;
1825 Total_Count : Count_Type'Base;
1826 -- Value read from the stream that says how many elements follow
1828 Read_Count : Count_Type'Base;
1829 -- Actual number of elements read from the stream
1835 procedure Read_Children (Subtree : Tree_Node_Access) is
1836 pragma Assert (Subtree /= null);
1837 pragma Assert (Subtree.Children.First = null);
1838 pragma Assert (Subtree.Children.Last = null);
1840 Count : Count_Type'Base;
1841 -- Number of child subtrees
1846 Count_Type'Read (Stream, Count);
1849 raise Program_Error with "attempt to read from corrupt stream";
1856 C.First := Read_Subtree (Parent => Subtree);
1859 for J in Count_Type'(2) .. Count loop
1860 C.Last.Next := Read_Subtree (Parent => Subtree);
1861 C.Last.Next.Prev := C.Last;
1862 C.Last := C.Last.Next;
1865 -- Now that the allocation and reads have completed successfully, it
1866 -- is safe to link the children to their parent.
1868 Subtree.Children := C;
1875 function Read_Subtree
1876 (Parent : Tree_Node_Access) return Tree_Node_Access
1878 Element : constant Element_Access :=
1879 new Element_Type'(Element_Type'Input (Stream));
1881 Subtree : constant Tree_Node_Access :=
1888 Read_Count := Read_Count + 1;
1890 Read_Children (Subtree);
1895 -- Start of processing for Read
1898 Container.Clear; -- checks busy bit
1900 Count_Type'Read (Stream, Total_Count);
1902 if Total_Count < 0 then
1903 raise Program_Error with "attempt to read from corrupt stream";
1906 if Total_Count = 0 then
1912 Read_Children (Root_Node (Container));
1914 if Read_Count /= Total_Count then
1915 raise Program_Error with "attempt to read from corrupt stream";
1918 Container.Count := Total_Count;
1922 (Stream : not null access Root_Stream_Type'Class;
1923 Position : out Cursor)
1926 raise Program_Error with "attempt to read tree cursor from stream";
1930 (Stream : not null access Root_Stream_Type'Class;
1931 Item : out Reference_Type)
1934 raise Program_Error with "attempt to stream reference";
1938 (Stream : not null access Root_Stream_Type'Class;
1939 Item : out Constant_Reference_Type)
1942 raise Program_Error with "attempt to stream reference";
1949 function Constant_Reference
1950 (Container : aliased Tree;
1951 Position : Cursor) return Constant_Reference_Type
1954 pragma Unreferenced (Container);
1956 return (Element => Position.Node.Element.all'Unchecked_Access);
1957 end Constant_Reference;
1960 (Container : aliased Tree;
1961 Position : Cursor) return Reference_Type
1964 pragma Unreferenced (Container);
1966 return (Element => Position.Node.Element.all'Unchecked_Access);
1969 --------------------
1970 -- Remove_Subtree --
1971 --------------------
1973 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
1974 C : Children_Type renames Subtree.Parent.Children;
1977 -- This is a utility operation to remove a subtree node from its
1978 -- parent's list of children.
1980 if C.First = Subtree then
1981 pragma Assert (Subtree.Prev = null);
1983 if C.Last = Subtree then
1984 pragma Assert (Subtree.Next = null);
1989 C.First := Subtree.Next;
1990 C.First.Prev := null;
1993 elsif C.Last = Subtree then
1994 pragma Assert (Subtree.Next = null);
1995 C.Last := Subtree.Prev;
1996 C.Last.Next := null;
1999 Subtree.Prev.Next := Subtree.Next;
2000 Subtree.Next.Prev := Subtree.Prev;
2004 ----------------------
2005 -- Replace_Element --
2006 ----------------------
2008 procedure Replace_Element
2009 (Container : in out Tree;
2011 New_Item : Element_Type)
2013 E, X : Element_Access;
2016 if Position = No_Element then
2017 raise Constraint_Error with "Position cursor has no element";
2020 if Position.Container /= Container'Unrestricted_Access then
2021 raise Program_Error with "Position cursor not in container";
2024 if Is_Root (Position) then
2025 raise Program_Error with "Position cursor designates root";
2028 if Container.Lock > 0 then
2030 with "attempt to tamper with elements (tree is locked)";
2033 E := new Element_Type'(New_Item);
2035 X := Position.Node.Element;
2036 Position.Node.Element := E;
2039 end Replace_Element;
2041 ------------------------------
2042 -- Reverse_Iterate_Children --
2043 ------------------------------
2045 procedure Reverse_Iterate_Children
2047 Process : not null access procedure (Position : Cursor))
2050 if Parent = No_Element then
2051 raise Constraint_Error with "Parent cursor has no element";
2055 B : Integer renames Parent.Container.Busy;
2056 C : Tree_Node_Access;
2061 C := Parent.Node.Children.Last;
2062 while C /= null loop
2063 Process (Position => Cursor'(Parent.Container, Node => C));
2074 end Reverse_Iterate_Children;
2080 function Root (Container : Tree) return Cursor is
2082 return (Container'Unrestricted_Access, Root_Node (Container));
2089 function Root_Node (Container : Tree) return Tree_Node_Access is
2091 return Container.Root'Unrestricted_Access;
2094 ---------------------
2095 -- Splice_Children --
2096 ---------------------
2098 procedure Splice_Children
2099 (Target : in out Tree;
2100 Target_Parent : Cursor;
2102 Source : in out Tree;
2103 Source_Parent : Cursor)
2108 if Target_Parent = No_Element then
2109 raise Constraint_Error with "Target_Parent cursor has no element";
2112 if Target_Parent.Container /= Target'Unrestricted_Access then
2114 with "Target_Parent cursor not in Target container";
2117 if Before /= No_Element then
2118 if Before.Container /= Target'Unrestricted_Access then
2120 with "Before cursor not in Target container";
2123 if Before.Node.Parent /= Target_Parent.Node then
2124 raise Constraint_Error
2125 with "Before cursor not child of Target_Parent";
2129 if Source_Parent = No_Element then
2130 raise Constraint_Error with "Source_Parent cursor has no element";
2133 if Source_Parent.Container /= Source'Unrestricted_Access then
2135 with "Source_Parent cursor not in Source container";
2138 if Target'Address = Source'Address then
2139 if Target_Parent = Source_Parent then
2143 if Target.Busy > 0 then
2145 with "attempt to tamper with cursors (Target tree is busy)";
2148 if Is_Reachable (From => Target_Parent.Node,
2149 To => Source_Parent.Node)
2151 raise Constraint_Error
2152 with "Source_Parent is ancestor of Target_Parent";
2156 (Target_Parent => Target_Parent.Node,
2157 Before => Before.Node,
2158 Source_Parent => Source_Parent.Node);
2163 if Target.Busy > 0 then
2165 with "attempt to tamper with cursors (Target tree is busy)";
2168 if Source.Busy > 0 then
2170 with "attempt to tamper with cursors (Source tree is busy)";
2173 -- We cache the count of the nodes we have allocated, so that operation
2174 -- Node_Count can execute in O(1) time. But that means we must count the
2175 -- nodes in the subtree we remove from Source and insert into Target, in
2176 -- order to keep the count accurate.
2178 Count := Subtree_Node_Count (Source_Parent.Node);
2179 pragma Assert (Count >= 1);
2181 Count := Count - 1; -- because Source_Parent node does not move
2184 (Target_Parent => Target_Parent.Node,
2185 Before => Before.Node,
2186 Source_Parent => Source_Parent.Node);
2188 Source.Count := Source.Count - Count;
2189 Target.Count := Target.Count + Count;
2190 end Splice_Children;
2192 procedure Splice_Children
2193 (Container : in out Tree;
2194 Target_Parent : Cursor;
2196 Source_Parent : Cursor)
2199 if Target_Parent = No_Element then
2200 raise Constraint_Error with "Target_Parent cursor has no element";
2203 if Target_Parent.Container /= Container'Unrestricted_Access then
2205 with "Target_Parent cursor not in container";
2208 if Before /= No_Element then
2209 if Before.Container /= Container'Unrestricted_Access then
2211 with "Before cursor not in container";
2214 if Before.Node.Parent /= Target_Parent.Node then
2215 raise Constraint_Error
2216 with "Before cursor not child of Target_Parent";
2220 if Source_Parent = No_Element then
2221 raise Constraint_Error with "Source_Parent cursor has no element";
2224 if Source_Parent.Container /= Container'Unrestricted_Access then
2226 with "Source_Parent cursor not in container";
2229 if Target_Parent = Source_Parent then
2233 if Container.Busy > 0 then
2235 with "attempt to tamper with cursors (tree is busy)";
2238 if Is_Reachable (From => Target_Parent.Node,
2239 To => Source_Parent.Node)
2241 raise Constraint_Error
2242 with "Source_Parent is ancestor of Target_Parent";
2246 (Target_Parent => Target_Parent.Node,
2247 Before => Before.Node,
2248 Source_Parent => Source_Parent.Node);
2249 end Splice_Children;
2251 procedure Splice_Children
2252 (Target_Parent : Tree_Node_Access;
2253 Before : Tree_Node_Access;
2254 Source_Parent : Tree_Node_Access)
2256 CC : constant Children_Type := Source_Parent.Children;
2257 C : Tree_Node_Access;
2260 -- This is a utility operation to remove the children from Source parent
2261 -- and insert them into Target parent.
2263 Source_Parent.Children := Children_Type'(others => null);
2265 -- Fix up the Parent pointers of each child to designate its new Target
2269 while C /= null loop
2270 C.Parent := Target_Parent;
2277 Parent => Target_Parent,
2279 end Splice_Children;
2281 --------------------
2282 -- Splice_Subtree --
2283 --------------------
2285 procedure Splice_Subtree
2286 (Target : in out Tree;
2289 Source : in out Tree;
2290 Position : in out Cursor)
2292 Subtree_Count : Count_Type;
2295 if Parent = No_Element then
2296 raise Constraint_Error with "Parent cursor has no element";
2299 if Parent.Container /= Target'Unrestricted_Access then
2300 raise Program_Error with "Parent cursor not in Target container";
2303 if Before /= No_Element then
2304 if Before.Container /= Target'Unrestricted_Access then
2305 raise Program_Error with "Before cursor not in Target container";
2308 if Before.Node.Parent /= Parent.Node then
2309 raise Constraint_Error with "Before cursor not child of Parent";
2313 if Position = No_Element then
2314 raise Constraint_Error with "Position cursor has no element";
2317 if Position.Container /= Source'Unrestricted_Access then
2318 raise Program_Error with "Position cursor not in Source container";
2321 if Is_Root (Position) then
2322 raise Program_Error with "Position cursor designates root";
2325 if Target'Address = Source'Address then
2326 if Position.Node.Parent = Parent.Node then
2327 if Position.Node = Before.Node then
2331 if Position.Node.Next = Before.Node then
2336 if Target.Busy > 0 then
2338 with "attempt to tamper with cursors (Target tree is busy)";
2341 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2342 raise Constraint_Error with "Position is ancestor of Parent";
2345 Remove_Subtree (Position.Node);
2347 Position.Node.Parent := Parent.Node;
2348 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2353 if Target.Busy > 0 then
2355 with "attempt to tamper with cursors (Target tree is busy)";
2358 if Source.Busy > 0 then
2360 with "attempt to tamper with cursors (Source tree is busy)";
2363 -- This is an unfortunate feature of this API: we must count the nodes
2364 -- in the subtree that we remove from the source tree, which is an O(n)
2365 -- operation. It would have been better if the Tree container did not
2366 -- have a Node_Count selector; a user that wants the number of nodes in
2367 -- the tree could simply call Subtree_Node_Count, with the understanding
2368 -- that such an operation is O(n).
2370 -- Of course, we could choose to implement the Node_Count selector as an
2371 -- O(n) operation, which would turn this splice operation into an O(1)
2374 Subtree_Count := Subtree_Node_Count (Position.Node);
2375 pragma Assert (Subtree_Count <= Source.Count);
2377 Remove_Subtree (Position.Node);
2378 Source.Count := Source.Count - Subtree_Count;
2380 Position.Node.Parent := Parent.Node;
2381 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2383 Target.Count := Target.Count + Subtree_Count;
2385 Position.Container := Target'Unrestricted_Access;
2388 procedure Splice_Subtree
2389 (Container : in out Tree;
2395 if Parent = No_Element then
2396 raise Constraint_Error with "Parent cursor has no element";
2399 if Parent.Container /= Container'Unrestricted_Access then
2400 raise Program_Error with "Parent cursor not in container";
2403 if Before /= No_Element then
2404 if Before.Container /= Container'Unrestricted_Access then
2405 raise Program_Error with "Before cursor not in container";
2408 if Before.Node.Parent /= Parent.Node then
2409 raise Constraint_Error with "Before cursor not child of Parent";
2413 if Position = No_Element then
2414 raise Constraint_Error with "Position cursor has no element";
2417 if Position.Container /= Container'Unrestricted_Access then
2418 raise Program_Error with "Position cursor not in container";
2421 if Is_Root (Position) then
2423 -- Should this be PE instead? Need ARG confirmation. ???
2425 raise Constraint_Error with "Position cursor designates root";
2428 if Position.Node.Parent = Parent.Node then
2429 if Position.Node = Before.Node then
2433 if Position.Node.Next = Before.Node then
2438 if Container.Busy > 0 then
2440 with "attempt to tamper with cursors (tree is busy)";
2443 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2444 raise Constraint_Error with "Position is ancestor of Parent";
2447 Remove_Subtree (Position.Node);
2449 Position.Node.Parent := Parent.Node;
2450 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2453 ------------------------
2454 -- Subtree_Node_Count --
2455 ------------------------
2457 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2459 if Position = No_Element then
2463 return Subtree_Node_Count (Position.Node);
2464 end Subtree_Node_Count;
2466 function Subtree_Node_Count
2467 (Subtree : Tree_Node_Access) return Count_Type
2469 Result : Count_Type;
2470 Node : Tree_Node_Access;
2474 Node := Subtree.Children.First;
2475 while Node /= null loop
2476 Result := Result + Subtree_Node_Count (Node);
2481 end Subtree_Node_Count;
2488 (Container : in out Tree;
2492 if I = No_Element then
2493 raise Constraint_Error with "I cursor has no element";
2496 if I.Container /= Container'Unrestricted_Access then
2497 raise Program_Error with "I cursor not in container";
2501 raise Program_Error with "I cursor designates root";
2504 if I = J then -- make this test sooner???
2508 if J = No_Element then
2509 raise Constraint_Error with "J cursor has no element";
2512 if J.Container /= Container'Unrestricted_Access then
2513 raise Program_Error with "J cursor not in container";
2517 raise Program_Error with "J cursor designates root";
2520 if Container.Lock > 0 then
2522 with "attempt to tamper with elements (tree is locked)";
2526 EI : constant Element_Access := I.Node.Element;
2529 I.Node.Element := J.Node.Element;
2530 J.Node.Element := EI;
2534 --------------------
2535 -- Update_Element --
2536 --------------------
2538 procedure Update_Element
2539 (Container : in out Tree;
2541 Process : not null access procedure (Element : in out Element_Type))
2544 if Position = No_Element then
2545 raise Constraint_Error with "Position cursor has no element";
2548 if Position.Container /= Container'Unrestricted_Access then
2549 raise Program_Error with "Position cursor not in container";
2552 if Is_Root (Position) then
2553 raise Program_Error with "Position cursor designates root";
2557 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2558 B : Integer renames T.Busy;
2559 L : Integer renames T.Lock;
2565 Process (Position.Node.Element.all);
2583 (Stream : not null access Root_Stream_Type'Class;
2586 procedure Write_Children (Subtree : Tree_Node_Access);
2587 procedure Write_Subtree (Subtree : Tree_Node_Access);
2589 --------------------
2590 -- Write_Children --
2591 --------------------
2593 procedure Write_Children (Subtree : Tree_Node_Access) is
2594 CC : Children_Type renames Subtree.Children;
2595 C : Tree_Node_Access;
2598 Count_Type'Write (Stream, Child_Count (CC));
2601 while C /= null loop
2611 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2613 Element_Type'Output (Stream, Subtree.Element.all);
2614 Write_Children (Subtree);
2617 -- Start of processing for Write
2620 Count_Type'Write (Stream, Container.Count);
2622 if Container.Count = 0 then
2626 Write_Children (Root_Node (Container));
2630 (Stream : not null access Root_Stream_Type'Class;
2634 raise Program_Error with "attempt to write tree cursor to stream";
2638 (Stream : not null access Root_Stream_Type'Class;
2639 Item : Reference_Type)
2642 raise Program_Error with "attempt to stream reference";
2646 (Stream : not null access Root_Stream_Type'Class;
2647 Item : Constant_Reference_Type)
2650 raise Program_Error with "attempt to stream reference";
2653 end Ada.Containers.Indefinite_Multiway_Trees;