1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Conversion;
31 with Ada.Unchecked_Deallocation;
32 with System; use type System.Address;
34 package body Ada.Containers.Multiway_Trees is
36 type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with
38 Container : Tree_Access;
43 overriding function First (Object : Iterator) return Cursor;
44 overriding function Next
46 Position : Cursor) return Cursor;
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
52 function Root_Node (Container : Tree) return Tree_Node_Access;
54 procedure Deallocate_Node is
55 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
57 procedure Deallocate_Children
58 (Subtree : Tree_Node_Access;
59 Count : in out Count_Type);
61 procedure Deallocate_Subtree
62 (Subtree : in out Tree_Node_Access;
63 Count : in out Count_Type);
65 function Equal_Children
66 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
68 function Equal_Subtree
69 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
71 procedure Iterate_Children
72 (Container : Tree_Access;
73 Subtree : Tree_Node_Access;
74 Process : not null access procedure (Position : Cursor));
76 procedure Iterate_Subtree
77 (Container : Tree_Access;
78 Subtree : Tree_Node_Access;
79 Process : not null access procedure (Position : Cursor));
81 procedure Copy_Children
82 (Source : Children_Type;
83 Parent : Tree_Node_Access;
84 Count : in out Count_Type);
86 procedure Copy_Subtree
87 (Source : Tree_Node_Access;
88 Parent : Tree_Node_Access;
89 Target : out Tree_Node_Access;
90 Count : in out Count_Type);
92 function Find_In_Children
93 (Subtree : Tree_Node_Access;
94 Item : Element_Type) return Tree_Node_Access;
96 function Find_In_Subtree
97 (Subtree : Tree_Node_Access;
98 Item : Element_Type) return Tree_Node_Access;
100 function Child_Count (Children : Children_Type) return Count_Type;
102 function Subtree_Node_Count
103 (Subtree : Tree_Node_Access) return Count_Type;
105 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
107 procedure Remove_Subtree (Subtree : Tree_Node_Access);
109 procedure Insert_Subtree_Node
110 (Subtree : Tree_Node_Access;
111 Parent : Tree_Node_Access;
112 Before : Tree_Node_Access);
114 procedure Insert_Subtree_List
115 (First : Tree_Node_Access;
116 Last : Tree_Node_Access;
117 Parent : Tree_Node_Access;
118 Before : Tree_Node_Access);
120 procedure Splice_Children
121 (Target_Parent : Tree_Node_Access;
122 Before : Tree_Node_Access;
123 Source_Parent : Tree_Node_Access);
129 function "=" (Left, Right : Tree) return Boolean is
131 if Left'Address = Right'Address then
135 return Equal_Children (Root_Node (Left), Root_Node (Right));
142 procedure Adjust (Container : in out Tree) is
143 Source : constant Children_Type := Container.Root.Children;
144 Source_Count : constant Count_Type := Container.Count;
145 Target_Count : Count_Type;
148 -- We first restore the target container to its default-initialized
149 -- state, before we attempt any allocation, to ensure that invariants
150 -- are preserved in the event that the allocation fails.
152 Container.Root.Children := Children_Type'(others => null);
155 Container.Count := 0;
157 -- Copy_Children returns a count of the number of nodes that it
158 -- allocates, but it works by incrementing the value that is passed
159 -- in. We must therefore initialize the count value before calling
164 -- Now we attempt the allocation of subtrees. The invariants are
165 -- satisfied even if the allocation fails.
167 Copy_Children (Source, Root_Node (Container), Target_Count);
168 pragma Assert (Target_Count = Source_Count);
170 Container.Count := Source_Count;
177 function Ancestor_Find
179 Item : Element_Type) return Cursor
181 R, N : Tree_Node_Access;
184 if Position = No_Element then
185 raise Constraint_Error with "Position cursor has no element";
188 -- Commented-out pending official ruling from ARG. ???
190 -- if Position.Container /= Container'Unrestricted_Access then
191 -- raise Program_Error with "Position cursor not in container";
194 -- AI-0136 says to raise PE if Position equals the root node. This does
195 -- not seem correct, as this value is just the limiting condition of the
196 -- search. For now we omit this check, pending a ruling from the ARG.???
198 -- if Is_Root (Position) then
199 -- raise Program_Error with "Position cursor designates root";
202 R := Root_Node (Position.Container.all);
205 if N.Element = Item then
206 return Cursor'(Position.Container, N);
219 procedure Append_Child
220 (Container : in out Tree;
222 New_Item : Element_Type;
223 Count : Count_Type := 1)
225 First, Last : Tree_Node_Access;
228 if Parent = No_Element then
229 raise Constraint_Error with "Parent cursor has no element";
232 if Parent.Container /= Container'Unrestricted_Access then
233 raise Program_Error with "Parent cursor not in container";
240 if Container.Busy > 0 then
242 with "attempt to tamper with cursors (tree is busy)";
245 First := new Tree_Node_Type'(Parent => Parent.Node,
251 for J in Count_Type'(2) .. Count loop
253 -- Reclaim other nodes if Storage_Error. ???
255 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
266 Parent => Parent.Node,
267 Before => null); -- null means "insert at end of list"
269 -- In order for operation Node_Count to complete in O(1) time, we cache
270 -- the count value. Here we increment the total count by the number of
271 -- nodes we just inserted.
273 Container.Count := Container.Count + Count;
280 procedure Assign (Target : in out Tree; Source : Tree) is
281 Source_Count : constant Count_Type := Source.Count;
282 Target_Count : Count_Type;
285 if Target'Address = Source'Address then
289 Target.Clear; -- checks busy bit
291 -- Copy_Children returns the number of nodes that it allocates, but it
292 -- does this by incrementing the count value passed in, so we must
293 -- initialize the count before calling Copy_Children.
297 -- Note that Copy_Children inserts the newly-allocated children into
298 -- their parent list only after the allocation of all the children has
299 -- succeeded. This preserves invariants even if the allocation fails.
301 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
302 pragma Assert (Target_Count = Source_Count);
304 Target.Count := Source_Count;
311 function Child_Count (Parent : Cursor) return Count_Type is
313 if Parent = No_Element then
316 return Child_Count (Parent.Node.Children);
320 function Child_Count (Children : Children_Type) return Count_Type is
322 Node : Tree_Node_Access;
326 Node := Children.First;
327 while Node /= null loop
328 Result := Result + 1;
339 function Child_Depth (Parent, Child : Cursor) return Count_Type is
341 N : Tree_Node_Access;
344 if Parent = No_Element then
345 raise Constraint_Error with "Parent cursor has no element";
348 if Child = No_Element then
349 raise Constraint_Error with "Child cursor has no element";
352 if Parent.Container /= Child.Container then
353 raise Program_Error with "Parent and Child in different containers";
358 while N /= Parent.Node loop
359 Result := Result + 1;
363 raise Program_Error with "Parent is not ancestor of Child";
374 procedure Clear (Container : in out Tree) is
375 Container_Count, Children_Count : Count_Type;
378 if Container.Busy > 0 then
380 with "attempt to tamper with cursors (tree is busy)";
383 -- We first set the container count to 0, in order to preserve
384 -- invariants in case the deallocation fails. (This works because
385 -- Deallocate_Children immediately removes the children from their
386 -- parent, and then does the actual deallocation.)
388 Container_Count := Container.Count;
389 Container.Count := 0;
391 -- Deallocate_Children returns the number of nodes that it deallocates,
392 -- but it does this by incrementing the count value that is passed in,
393 -- so we must first initialize the count return value before calling it.
397 -- See comment above. Deallocate_Children immediately removes the
398 -- children list from their parent node (here, the root of the tree),
399 -- and only after that does it attempt the actual deallocation. So even
400 -- if the deallocation fails, the representation invariants for the tree
403 Deallocate_Children (Root_Node (Container), Children_Count);
404 pragma Assert (Children_Count = Container_Count);
413 Item : Element_Type) return Boolean
416 return Find (Container, Item) /= No_Element;
423 function Copy (Source : Tree) return Tree is
425 return Target : Tree do
427 (Source => Source.Root.Children,
428 Parent => Root_Node (Target),
429 Count => Target.Count);
431 pragma Assert (Target.Count = Source.Count);
439 procedure Copy_Children
440 (Source : Children_Type;
441 Parent : Tree_Node_Access;
442 Count : in out Count_Type)
444 pragma Assert (Parent /= null);
445 pragma Assert (Parent.Children.First = null);
446 pragma Assert (Parent.Children.Last = null);
449 C : Tree_Node_Access;
452 -- We special-case the first allocation, in order to establish the
453 -- representation invariants for type Children_Type.
469 -- The representation invariants for the Children_Type list have been
470 -- established, so we can now copy the remaining children of Source.
477 Target => CC.Last.Next,
480 CC.Last.Next.Prev := CC.Last;
481 CC.Last := CC.Last.Next;
486 -- Add the newly-allocated children to their parent list only after the
487 -- allocation has succeeded, so as to preserve invariants of the parent.
489 Parent.Children := CC;
496 procedure Copy_Subtree
497 (Target : in out Tree;
502 Target_Subtree : Tree_Node_Access;
503 Target_Count : Count_Type;
506 if Parent = No_Element then
507 raise Constraint_Error with "Parent cursor has no element";
510 if Parent.Container /= Target'Unrestricted_Access then
511 raise Program_Error with "Parent cursor not in container";
514 if Before /= No_Element then
515 if Before.Container /= Target'Unrestricted_Access then
516 raise Program_Error with "Before cursor not in container";
519 if Before.Node.Parent /= Parent.Node then
520 raise Constraint_Error with "Before cursor not child of Parent";
524 if Source = No_Element then
528 if Is_Root (Source) then
529 raise Constraint_Error with "Source cursor designates root";
532 -- Copy_Subtree returns a count of the number of nodes that it
533 -- allocates, but it works by incrementing the value that is passed
534 -- in. We must therefore initialize the count value before calling
540 (Source => Source.Node,
541 Parent => Parent.Node,
542 Target => Target_Subtree,
543 Count => Target_Count);
545 pragma Assert (Target_Subtree /= null);
546 pragma Assert (Target_Subtree.Parent = Parent.Node);
547 pragma Assert (Target_Count >= 1);
550 (Subtree => Target_Subtree,
551 Parent => Parent.Node,
552 Before => Before.Node);
554 -- In order for operation Node_Count to complete in O(1) time, we cache
555 -- the count value. Here we increment the total count by the number of
556 -- nodes we just inserted.
558 Target.Count := Target.Count + Target_Count;
561 procedure Copy_Subtree
562 (Source : Tree_Node_Access;
563 Parent : Tree_Node_Access;
564 Target : out Tree_Node_Access;
565 Count : in out Count_Type)
568 Target := new Tree_Node_Type'(Element => Source.Element,
575 (Source => Source.Children,
580 -------------------------
581 -- Deallocate_Children --
582 -------------------------
584 procedure Deallocate_Children
585 (Subtree : Tree_Node_Access;
586 Count : in out Count_Type)
588 pragma Assert (Subtree /= null);
590 CC : Children_Type := Subtree.Children;
591 C : Tree_Node_Access;
594 -- We immediately remove the children from their parent, in order to
595 -- preserve invariants in case the deallocation fails.
597 Subtree.Children := Children_Type'(others => null);
599 while CC.First /= null loop
603 Deallocate_Subtree (C, Count);
605 end Deallocate_Children;
607 ------------------------
608 -- Deallocate_Subtree --
609 ------------------------
611 procedure Deallocate_Subtree
612 (Subtree : in out Tree_Node_Access;
613 Count : in out Count_Type)
616 Deallocate_Children (Subtree, Count);
617 Deallocate_Node (Subtree);
619 end Deallocate_Subtree;
621 ---------------------
622 -- Delete_Children --
623 ---------------------
625 procedure Delete_Children
626 (Container : in out Tree;
632 if Parent = No_Element then
633 raise Constraint_Error with "Parent cursor has no element";
636 if Parent.Container /= Container'Unrestricted_Access then
637 raise Program_Error with "Parent cursor not in container";
640 if Container.Busy > 0 then
642 with "attempt to tamper with cursors (tree is busy)";
645 -- Deallocate_Children returns a count of the number of nodes that it
646 -- deallocates, but it works by incrementing the value that is passed
647 -- in. We must therefore initialize the count value before calling
648 -- Deallocate_Children.
652 Deallocate_Children (Parent.Node, Count);
653 pragma Assert (Count <= Container.Count);
655 Container.Count := Container.Count - Count;
662 procedure Delete_Leaf
663 (Container : in out Tree;
664 Position : in out Cursor)
666 X : Tree_Node_Access;
669 if Position = No_Element then
670 raise Constraint_Error with "Position cursor has no element";
673 if Position.Container /= Container'Unrestricted_Access then
674 raise Program_Error with "Position cursor not in container";
677 if Is_Root (Position) then
678 raise Program_Error with "Position cursor designates root";
681 if not Is_Leaf (Position) then
682 raise Constraint_Error with "Position cursor does not designate leaf";
685 if Container.Busy > 0 then
687 with "attempt to tamper with cursors (tree is busy)";
691 Position := No_Element;
693 -- Restore represention invariants before attempting the actual
697 Container.Count := Container.Count - 1;
699 -- It is now safe to attempt the deallocation. This leaf node has been
700 -- disassociated from the tree, so even if the deallocation fails,
701 -- representation invariants will remain satisfied.
710 procedure Delete_Subtree
711 (Container : in out Tree;
712 Position : in out Cursor)
714 X : Tree_Node_Access;
718 if Position = No_Element then
719 raise Constraint_Error with "Position cursor has no element";
722 if Position.Container /= Container'Unrestricted_Access then
723 raise Program_Error with "Position cursor not in container";
726 if Is_Root (Position) then
727 raise Program_Error with "Position cursor designates root";
730 if Container.Busy > 0 then
732 with "attempt to tamper with cursors (tree is busy)";
736 Position := No_Element;
738 -- Here is one case where a deallocation failure can result in the
739 -- violation of a representation invariant. We disassociate the subtree
740 -- from the tree now, but we only decrement the total node count after
741 -- we attempt the deallocation. However, if the deallocation fails, the
742 -- total node count will not get decremented.
744 -- One way around this dilemma is to count the nodes in the subtree
745 -- before attempt to delete the subtree, but that is an O(n) operation,
746 -- so it does not seem worth it.
748 -- Perhaps this is much ado about nothing, since the only way
749 -- deallocation can fail is if Controlled Finalization fails: this
750 -- propagates Program_Error so all bets are off anyway. ???
754 -- Deallocate_Subtree returns a count of the number of nodes that it
755 -- deallocates, but it works by incrementing the value that is passed
756 -- in. We must therefore initialize the count value before calling
757 -- Deallocate_Subtree.
761 Deallocate_Subtree (X, Count);
762 pragma Assert (Count <= Container.Count);
764 -- See comments above. We would prefer to do this sooner, but there's no
765 -- way to satisfy that goal without a potentially severe execution
768 Container.Count := Container.Count - Count;
775 function Depth (Position : Cursor) return Count_Type is
777 N : Tree_Node_Access;
784 Result := Result + 1;
794 function Element (Position : Cursor) return Element_Type is
796 if Position.Container = null then
797 raise Constraint_Error with "Position cursor has no element";
800 if Position.Node = Root_Node (Position.Container.all) then
801 raise Program_Error with "Position cursor designates root";
804 return Position.Node.Element;
811 function Equal_Children
812 (Left_Subtree : Tree_Node_Access;
813 Right_Subtree : Tree_Node_Access) return Boolean
815 Left_Children : Children_Type renames Left_Subtree.Children;
816 Right_Children : Children_Type renames Right_Subtree.Children;
818 L, R : Tree_Node_Access;
821 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
825 L := Left_Children.First;
826 R := Right_Children.First;
828 if not Equal_Subtree (L, R) then
843 function Equal_Subtree
844 (Left_Position : Cursor;
845 Right_Position : Cursor) return Boolean
848 if Left_Position = No_Element then
849 raise Constraint_Error with "Left cursor has no element";
852 if Right_Position = No_Element then
853 raise Constraint_Error with "Right cursor has no element";
856 if Left_Position = Right_Position then
860 if Is_Root (Left_Position) then
861 if not Is_Root (Right_Position) then
865 return Equal_Children (Left_Position.Node, Right_Position.Node);
868 if Is_Root (Right_Position) then
872 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
875 function Equal_Subtree
876 (Left_Subtree : Tree_Node_Access;
877 Right_Subtree : Tree_Node_Access) return Boolean
880 if Left_Subtree.Element /= Right_Subtree.Element then
884 return Equal_Children (Left_Subtree, Right_Subtree);
893 Item : Element_Type) return Cursor
895 N : constant Tree_Node_Access :=
896 Find_In_Children (Root_Node (Container), Item);
903 return Cursor'(Container'Unrestricted_Access, N);
910 function First (Object : Iterator) return Cursor is
912 return Object.Position;
919 function First_Child (Parent : Cursor) return Cursor is
920 Node : Tree_Node_Access;
923 if Parent = No_Element then
924 raise Constraint_Error with "Parent cursor has no element";
927 Node := Parent.Node.Children.First;
933 return Cursor'(Parent.Container, Node);
936 -------------------------
937 -- First_Child_Element --
938 -------------------------
940 function First_Child_Element (Parent : Cursor) return Element_Type is
942 return Element (First_Child (Parent));
943 end First_Child_Element;
945 ----------------------
946 -- Find_In_Children --
947 ----------------------
949 function Find_In_Children
950 (Subtree : Tree_Node_Access;
951 Item : Element_Type) return Tree_Node_Access
953 N, Result : Tree_Node_Access;
956 N := Subtree.Children.First;
958 Result := Find_In_Subtree (N, Item);
960 if Result /= null then
968 end Find_In_Children;
970 ---------------------
971 -- Find_In_Subtree --
972 ---------------------
974 function Find_In_Subtree
976 Item : Element_Type) return Cursor
978 Result : Tree_Node_Access;
981 if Position = No_Element then
982 raise Constraint_Error with "Position cursor has no element";
985 -- Commented out pending official ruling by ARG. ???
987 -- if Position.Container /= Container'Unrestricted_Access then
988 -- raise Program_Error with "Position cursor not in container";
991 if Is_Root (Position) then
992 Result := Find_In_Children (Position.Node, Item);
995 Result := Find_In_Subtree (Position.Node, Item);
998 if Result = null then
1002 return Cursor'(Position.Container, Result);
1003 end Find_In_Subtree;
1005 function Find_In_Subtree
1006 (Subtree : Tree_Node_Access;
1007 Item : Element_Type) return Tree_Node_Access
1010 if Subtree.Element = Item then
1014 return Find_In_Children (Subtree, Item);
1015 end Find_In_Subtree;
1021 function Has_Element (Position : Cursor) return Boolean is
1023 if Position = No_Element then
1027 return Position.Node.Parent /= null;
1034 procedure Insert_Child
1035 (Container : in out Tree;
1038 New_Item : Element_Type;
1039 Count : Count_Type := 1)
1042 pragma Unreferenced (Position);
1045 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1048 procedure Insert_Child
1049 (Container : in out Tree;
1052 New_Item : Element_Type;
1053 Position : out Cursor;
1054 Count : Count_Type := 1)
1056 Last : Tree_Node_Access;
1059 if Parent = No_Element then
1060 raise Constraint_Error with "Parent cursor has no element";
1063 if Parent.Container /= Container'Unrestricted_Access then
1064 raise Program_Error with "Parent cursor not in container";
1067 if Before /= No_Element then
1068 if Before.Container /= Container'Unrestricted_Access then
1069 raise Program_Error with "Before cursor not in container";
1072 if Before.Node.Parent /= Parent.Node then
1073 raise Constraint_Error with "Parent cursor not parent of Before";
1078 Position := No_Element; -- Need ruling from ARG ???
1082 if Container.Busy > 0 then
1084 with "attempt to tamper with cursors (tree is busy)";
1087 Position.Container := Parent.Container;
1088 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1089 Element => New_Item,
1092 Last := Position.Node;
1094 for J in Count_Type'(2) .. Count loop
1096 -- Reclaim other nodes if Storage_Error. ???
1098 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1100 Element => New_Item,
1107 (First => Position.Node,
1109 Parent => Parent.Node,
1110 Before => Before.Node);
1112 -- In order for operation Node_Count to complete in O(1) time, we cache
1113 -- the count value. Here we increment the total count by the number of
1114 -- nodes we just inserted.
1116 Container.Count := Container.Count + Count;
1119 procedure Insert_Child
1120 (Container : in out Tree;
1123 Position : out Cursor;
1124 Count : Count_Type := 1)
1126 Last : Tree_Node_Access;
1129 if Parent = No_Element then
1130 raise Constraint_Error with "Parent cursor has no element";
1133 if Parent.Container /= Container'Unrestricted_Access then
1134 raise Program_Error with "Parent cursor not in container";
1137 if Before /= No_Element then
1138 if Before.Container /= Container'Unrestricted_Access then
1139 raise Program_Error with "Before cursor not in container";
1142 if Before.Node.Parent /= Parent.Node then
1143 raise Constraint_Error with "Parent cursor not parent of Before";
1148 Position := No_Element; -- Need ruling from ARG ???
1152 if Container.Busy > 0 then
1154 with "attempt to tamper with cursors (tree is busy)";
1157 Position.Container := Parent.Container;
1158 Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
1162 Last := Position.Node;
1164 for J in Count_Type'(2) .. Count loop
1166 -- Reclaim other nodes if Storage_Error. ???
1168 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1177 (First => Position.Node,
1179 Parent => Parent.Node,
1180 Before => Before.Node);
1182 -- In order for operation Node_Count to complete in O(1) time, we cache
1183 -- the count value. Here we increment the total count by the number of
1184 -- nodes we just inserted.
1186 Container.Count := Container.Count + Count;
1189 -------------------------
1190 -- Insert_Subtree_List --
1191 -------------------------
1193 procedure Insert_Subtree_List
1194 (First : Tree_Node_Access;
1195 Last : Tree_Node_Access;
1196 Parent : Tree_Node_Access;
1197 Before : Tree_Node_Access)
1199 pragma Assert (Parent /= null);
1200 C : Children_Type renames Parent.Children;
1203 -- This is a simple utility operation to insert a list of nodes (from
1204 -- First..Last) as children of Parent. The Before node specifies where
1205 -- the new children should be inserted relative to the existing
1208 if First = null then
1209 pragma Assert (Last = null);
1213 pragma Assert (Last /= null);
1214 pragma Assert (Before = null or else Before.Parent = Parent);
1216 if C.First = null then
1218 C.First.Prev := null;
1220 C.Last.Next := null;
1222 elsif Before = null then -- means "insert after existing nodes"
1223 C.Last.Next := First;
1224 First.Prev := C.Last;
1226 C.Last.Next := null;
1228 elsif Before = C.First then
1229 Last.Next := C.First;
1230 C.First.Prev := Last;
1232 C.First.Prev := null;
1235 Before.Prev.Next := First;
1236 First.Prev := Before.Prev;
1237 Last.Next := Before;
1238 Before.Prev := Last;
1240 end Insert_Subtree_List;
1242 -------------------------
1243 -- Insert_Subtree_Node --
1244 -------------------------
1246 procedure Insert_Subtree_Node
1247 (Subtree : Tree_Node_Access;
1248 Parent : Tree_Node_Access;
1249 Before : Tree_Node_Access)
1252 -- This is a simple wrapper operation to insert a single child into the
1253 -- Parent's children list.
1260 end Insert_Subtree_Node;
1266 function Is_Empty (Container : Tree) return Boolean is
1268 return Container.Root.Children.First = null;
1275 function Is_Leaf (Position : Cursor) return Boolean is
1277 if Position = No_Element then
1281 return Position.Node.Children.First = null;
1288 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1289 pragma Assert (From /= null);
1290 pragma Assert (To /= null);
1292 N : Tree_Node_Access;
1296 while N /= null loop
1311 function Is_Root (Position : Cursor) return Boolean is
1313 if Position.Container = null then
1317 return Position = Root (Position.Container.all);
1326 Process : not null access procedure (Position : Cursor))
1328 T : Tree renames Container'Unrestricted_Access.all;
1329 B : Integer renames T.Busy;
1335 (Container => Container'Unrestricted_Access,
1336 Subtree => Root_Node (Container),
1337 Process => Process);
1347 function Iterate (Container : Tree)
1348 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1350 Root_Cursor : constant Cursor :=
1351 (Container'Unrestricted_Access, Root_Node (Container));
1354 Iterator'(Container'Unrestricted_Access,
1355 First_Child (Root_Cursor), From_Root => True);
1358 function Iterate_Subtree (Position : Cursor)
1359 return Tree_Iterator_Interfaces.Forward_Iterator'Class is
1361 return Iterator'(Position.Container, Position, From_Root => False);
1362 end Iterate_Subtree;
1364 ----------------------
1365 -- Iterate_Children --
1366 ----------------------
1368 procedure Iterate_Children
1370 Process : not null access procedure (Position : Cursor))
1373 if Parent = No_Element then
1374 raise Constraint_Error with "Parent cursor has no element";
1378 B : Integer renames Parent.Container.Busy;
1379 C : Tree_Node_Access;
1384 C := Parent.Node.Children.First;
1385 while C /= null loop
1386 Process (Position => Cursor'(Parent.Container, Node => C));
1397 end Iterate_Children;
1399 procedure Iterate_Children
1400 (Container : Tree_Access;
1401 Subtree : Tree_Node_Access;
1402 Process : not null access procedure (Position : Cursor))
1404 Node : Tree_Node_Access;
1407 -- This is a helper function to recursively iterate over all the nodes
1408 -- in a subtree, in depth-first fashion. This particular helper just
1409 -- visits the children of this subtree, not the root of the subtree node
1410 -- itself. This is useful when starting from the ultimate root of the
1411 -- entire tree (see Iterate), as that root does not have an element.
1413 Node := Subtree.Children.First;
1414 while Node /= null loop
1415 Iterate_Subtree (Container, Node, Process);
1418 end Iterate_Children;
1420 ---------------------
1421 -- Iterate_Subtree --
1422 ---------------------
1424 procedure Iterate_Subtree
1426 Process : not null access procedure (Position : Cursor))
1429 if Position = No_Element then
1430 raise Constraint_Error with "Position cursor has no element";
1434 B : Integer renames Position.Container.Busy;
1439 if Is_Root (Position) then
1440 Iterate_Children (Position.Container, Position.Node, Process);
1443 Iterate_Subtree (Position.Container, Position.Node, Process);
1453 end Iterate_Subtree;
1455 procedure Iterate_Subtree
1456 (Container : Tree_Access;
1457 Subtree : Tree_Node_Access;
1458 Process : not null access procedure (Position : Cursor))
1461 -- This is a helper function to recursively iterate over all the nodes
1462 -- in a subtree, in depth-first fashion. It first visits the root of the
1463 -- subtree, then visits its children.
1465 Process (Cursor'(Container, Subtree));
1466 Iterate_Children (Container, Subtree, Process);
1467 end Iterate_Subtree;
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);
1590 -- If an internal node, return its first child.
1592 return (Object.Container, N.Children.First);
1600 function Next_Sibling (Position : Cursor) return Cursor is
1602 if Position = No_Element then
1606 if Position.Node.Next = null then
1610 return Cursor'(Position.Container, Position.Node.Next);
1613 procedure Next_Sibling (Position : in out Cursor) is
1615 Position := Next_Sibling (Position);
1622 function Node_Count (Container : Tree) return Count_Type is
1624 -- Container.Count is the number of nodes we have actually allocated. We
1625 -- cache the value specifically so this Node_Count operation can execute
1626 -- in O(1) time, which makes it behave similarly to how the Length
1627 -- selector function behaves for other containers.
1629 -- The cached node count value only describes the nodes we have
1630 -- allocated; the root node itself is not included in that count. The
1631 -- Node_Count operation returns a value that includes the root node
1632 -- (because the RM says so), so we must add 1 to our cached value.
1634 return 1 + Container.Count;
1641 function Parent (Position : Cursor) return Cursor is
1643 if Position = No_Element then
1647 if Position.Node.Parent = null then
1651 return Cursor'(Position.Container, Position.Node.Parent);
1658 procedure Prepend_Child
1659 (Container : in out Tree;
1661 New_Item : Element_Type;
1662 Count : Count_Type := 1)
1664 First, Last : Tree_Node_Access;
1667 if Parent = No_Element then
1668 raise Constraint_Error with "Parent cursor has no element";
1671 if Parent.Container /= Container'Unrestricted_Access then
1672 raise Program_Error with "Parent cursor not in container";
1679 if Container.Busy > 0 then
1681 with "attempt to tamper with cursors (tree is busy)";
1684 First := new Tree_Node_Type'(Parent => Parent.Node,
1685 Element => New_Item,
1690 for J in Count_Type'(2) .. Count loop
1692 -- Reclaim other nodes if Storage_Error. ???
1694 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1696 Element => New_Item,
1705 Parent => Parent.Node,
1706 Before => Parent.Node.Children.First);
1708 -- In order for operation Node_Count to complete in O(1) time, we cache
1709 -- the count value. Here we increment the total count by the number of
1710 -- nodes we just inserted.
1712 Container.Count := Container.Count + Count;
1715 ----------------------
1716 -- Previous_Sibling --
1717 ----------------------
1719 function Previous_Sibling (Position : Cursor) return Cursor is
1721 if Position = No_Element then
1725 if Position.Node.Prev = null then
1729 return Cursor'(Position.Container, Position.Node.Prev);
1730 end Previous_Sibling;
1732 procedure Previous_Sibling (Position : in out Cursor) is
1734 Position := Previous_Sibling (Position);
1735 end Previous_Sibling;
1741 procedure Query_Element
1743 Process : not null access procedure (Element : Element_Type))
1746 if Position = No_Element then
1747 raise Constraint_Error with "Position cursor has no element";
1750 if Is_Root (Position) then
1751 raise Program_Error with "Position cursor designates root";
1755 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1756 B : Integer renames T.Busy;
1757 L : Integer renames T.Lock;
1763 Process (Position.Node.Element);
1781 (Stream : not null access Root_Stream_Type'Class;
1782 Container : out Tree)
1784 procedure Read_Children (Subtree : Tree_Node_Access);
1786 function Read_Subtree
1787 (Parent : Tree_Node_Access) return Tree_Node_Access;
1789 Total_Count : Count_Type'Base;
1790 -- Value read from the stream that says how many elements follow
1792 Read_Count : Count_Type'Base;
1793 -- Actual number of elements read from the stream
1799 procedure Read_Children (Subtree : Tree_Node_Access) is
1800 pragma Assert (Subtree /= null);
1801 pragma Assert (Subtree.Children.First = null);
1802 pragma Assert (Subtree.Children.Last = null);
1804 Count : Count_Type'Base;
1805 -- Number of child subtrees
1810 Count_Type'Read (Stream, Count);
1813 raise Program_Error with "attempt to read from corrupt stream";
1820 C.First := Read_Subtree (Parent => Subtree);
1823 for J in Count_Type'(2) .. Count loop
1824 C.Last.Next := Read_Subtree (Parent => Subtree);
1825 C.Last.Next.Prev := C.Last;
1826 C.Last := C.Last.Next;
1829 -- Now that the allocation and reads have completed successfully, it
1830 -- is safe to link the children to their parent.
1832 Subtree.Children := C;
1839 function Read_Subtree
1840 (Parent : Tree_Node_Access) return Tree_Node_Access
1842 Subtree : constant Tree_Node_Access :=
1845 Element => Element_Type'Input (Stream),
1849 Read_Count := Read_Count + 1;
1851 Read_Children (Subtree);
1856 -- Start of processing for Read
1859 Container.Clear; -- checks busy bit
1861 Count_Type'Read (Stream, Total_Count);
1863 if Total_Count < 0 then
1864 raise Program_Error with "attempt to read from corrupt stream";
1867 if Total_Count = 0 then
1873 Read_Children (Root_Node (Container));
1875 if Read_Count /= Total_Count then
1876 raise Program_Error with "attempt to read from corrupt stream";
1879 Container.Count := Total_Count;
1883 (Stream : not null access Root_Stream_Type'Class;
1884 Position : out Cursor)
1887 raise Program_Error with "attempt to read tree cursor from stream";
1891 (Stream : not null access Root_Stream_Type'Class;
1892 Item : out Reference_Type)
1895 raise Program_Error with "attempt to stream reference";
1899 (Stream : not null access Root_Stream_Type'Class;
1900 Item : out Constant_Reference_Type)
1903 raise Program_Error with "attempt to stream reference";
1910 function Constant_Reference
1911 (Container : aliased Tree;
1912 Position : Cursor) return Constant_Reference_Type
1915 pragma Unreferenced (Container);
1917 return (Element => Position.Node.Element'Unrestricted_Access);
1918 end Constant_Reference;
1921 (Container : aliased Tree;
1922 Position : Cursor) return Reference_Type
1925 pragma Unreferenced (Container);
1927 return (Element => Position.Node.Element'Unrestricted_Access);
1930 --------------------
1931 -- Remove_Subtree --
1932 --------------------
1934 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
1935 C : Children_Type renames Subtree.Parent.Children;
1938 -- This is a utility operation to remove a subtree
1939 -- node from its parent's list of children.
1941 if C.First = Subtree then
1942 pragma Assert (Subtree.Prev = null);
1944 if C.Last = Subtree then
1945 pragma Assert (Subtree.Next = null);
1950 C.First := Subtree.Next;
1951 C.First.Prev := null;
1954 elsif C.Last = Subtree then
1955 pragma Assert (Subtree.Next = null);
1956 C.Last := Subtree.Prev;
1957 C.Last.Next := null;
1960 Subtree.Prev.Next := Subtree.Next;
1961 Subtree.Next.Prev := Subtree.Prev;
1965 ----------------------
1966 -- Replace_Element --
1967 ----------------------
1969 procedure Replace_Element
1970 (Container : in out Tree;
1972 New_Item : Element_Type)
1975 if Position = No_Element then
1976 raise Constraint_Error with "Position cursor has no element";
1979 if Position.Container /= Container'Unrestricted_Access then
1980 raise Program_Error with "Position cursor not in container";
1983 if Is_Root (Position) then
1984 raise Program_Error with "Position cursor designates root";
1987 if Container.Lock > 0 then
1989 with "attempt to tamper with elements (tree is locked)";
1992 Position.Node.Element := New_Item;
1993 end Replace_Element;
1995 ------------------------------
1996 -- Reverse_Iterate_Children --
1997 ------------------------------
1999 procedure Reverse_Iterate_Children
2001 Process : not null access procedure (Position : Cursor))
2004 if Parent = No_Element then
2005 raise Constraint_Error with "Parent cursor has no element";
2009 B : Integer renames Parent.Container.Busy;
2010 C : Tree_Node_Access;
2015 C := Parent.Node.Children.Last;
2016 while C /= null loop
2017 Process (Position => Cursor'(Parent.Container, Node => C));
2028 end Reverse_Iterate_Children;
2034 function Root (Container : Tree) return Cursor is
2036 return (Container'Unrestricted_Access, Root_Node (Container));
2043 function Root_Node (Container : Tree) return Tree_Node_Access is
2044 type Root_Node_Access is access all Root_Node_Type;
2045 for Root_Node_Access'Storage_Size use 0;
2046 pragma Convention (C, Root_Node_Access);
2048 function To_Tree_Node_Access is
2049 new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access);
2051 -- Start of processing for Root_Node
2054 -- This is a utility function for converting from an access type that
2055 -- designates the distinguished root node to an access type designating
2056 -- a non-root node. The representation of a root node does not have an
2057 -- element, but is otherwise identical to a non-root node, so the
2058 -- conversion itself is safe.
2060 return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
2063 ---------------------
2064 -- Splice_Children --
2065 ---------------------
2067 procedure Splice_Children
2068 (Target : in out Tree;
2069 Target_Parent : Cursor;
2071 Source : in out Tree;
2072 Source_Parent : Cursor)
2077 if Target_Parent = No_Element then
2078 raise Constraint_Error with "Target_Parent cursor has no element";
2081 if Target_Parent.Container /= Target'Unrestricted_Access then
2083 with "Target_Parent cursor not in Target container";
2086 if Before /= No_Element then
2087 if Before.Container /= Target'Unrestricted_Access then
2089 with "Before cursor not in Target container";
2092 if Before.Node.Parent /= Target_Parent.Node then
2093 raise Constraint_Error
2094 with "Before cursor not child of Target_Parent";
2098 if Source_Parent = No_Element then
2099 raise Constraint_Error with "Source_Parent cursor has no element";
2102 if Source_Parent.Container /= Source'Unrestricted_Access then
2104 with "Source_Parent cursor not in Source container";
2107 if Target'Address = Source'Address then
2108 if Target_Parent = Source_Parent then
2112 if Target.Busy > 0 then
2114 with "attempt to tamper with cursors (Target tree is busy)";
2117 if Is_Reachable (From => Target_Parent.Node,
2118 To => Source_Parent.Node)
2120 raise Constraint_Error
2121 with "Source_Parent is ancestor of Target_Parent";
2125 (Target_Parent => Target_Parent.Node,
2126 Before => Before.Node,
2127 Source_Parent => Source_Parent.Node);
2132 if Target.Busy > 0 then
2134 with "attempt to tamper with cursors (Target tree is busy)";
2137 if Source.Busy > 0 then
2139 with "attempt to tamper with cursors (Source tree is busy)";
2142 -- We cache the count of the nodes we have allocated, so that operation
2143 -- Node_Count can execute in O(1) time. But that means we must count the
2144 -- nodes in the subtree we remove from Source and insert into Target, in
2145 -- order to keep the count accurate.
2147 Count := Subtree_Node_Count (Source_Parent.Node);
2148 pragma Assert (Count >= 1);
2150 Count := Count - 1; -- because Source_Parent node does not move
2153 (Target_Parent => Target_Parent.Node,
2154 Before => Before.Node,
2155 Source_Parent => Source_Parent.Node);
2157 Source.Count := Source.Count - Count;
2158 Target.Count := Target.Count + Count;
2159 end Splice_Children;
2161 procedure Splice_Children
2162 (Container : in out Tree;
2163 Target_Parent : Cursor;
2165 Source_Parent : Cursor)
2168 if Target_Parent = No_Element then
2169 raise Constraint_Error with "Target_Parent cursor has no element";
2172 if Target_Parent.Container /= Container'Unrestricted_Access then
2174 with "Target_Parent cursor not in container";
2177 if Before /= No_Element then
2178 if Before.Container /= Container'Unrestricted_Access then
2180 with "Before cursor not in container";
2183 if Before.Node.Parent /= Target_Parent.Node then
2184 raise Constraint_Error
2185 with "Before cursor not child of Target_Parent";
2189 if Source_Parent = No_Element then
2190 raise Constraint_Error with "Source_Parent cursor has no element";
2193 if Source_Parent.Container /= Container'Unrestricted_Access then
2195 with "Source_Parent cursor not in container";
2198 if Target_Parent = Source_Parent then
2202 if Container.Busy > 0 then
2204 with "attempt to tamper with cursors (tree is busy)";
2207 if Is_Reachable (From => Target_Parent.Node,
2208 To => Source_Parent.Node)
2210 raise Constraint_Error
2211 with "Source_Parent is ancestor of Target_Parent";
2215 (Target_Parent => Target_Parent.Node,
2216 Before => Before.Node,
2217 Source_Parent => Source_Parent.Node);
2218 end Splice_Children;
2220 procedure Splice_Children
2221 (Target_Parent : Tree_Node_Access;
2222 Before : Tree_Node_Access;
2223 Source_Parent : Tree_Node_Access)
2225 CC : constant Children_Type := Source_Parent.Children;
2226 C : Tree_Node_Access;
2229 -- This is a utility operation to remove the children from
2230 -- Source parent and insert them into Target parent.
2232 Source_Parent.Children := Children_Type'(others => null);
2234 -- Fix up the Parent pointers of each child to designate
2235 -- its new Target parent.
2238 while C /= null loop
2239 C.Parent := Target_Parent;
2246 Parent => Target_Parent,
2248 end Splice_Children;
2250 --------------------
2251 -- Splice_Subtree --
2252 --------------------
2254 procedure Splice_Subtree
2255 (Target : in out Tree;
2258 Source : in out Tree;
2259 Position : in out Cursor)
2261 Subtree_Count : Count_Type;
2264 if Parent = No_Element then
2265 raise Constraint_Error with "Parent cursor has no element";
2268 if Parent.Container /= Target'Unrestricted_Access then
2269 raise Program_Error with "Parent cursor not in Target container";
2272 if Before /= No_Element then
2273 if Before.Container /= Target'Unrestricted_Access then
2274 raise Program_Error with "Before cursor not in Target container";
2277 if Before.Node.Parent /= Parent.Node then
2278 raise Constraint_Error with "Before cursor not child of Parent";
2282 if Position = No_Element then
2283 raise Constraint_Error with "Position cursor has no element";
2286 if Position.Container /= Source'Unrestricted_Access then
2287 raise Program_Error with "Position cursor not in Source container";
2290 if Is_Root (Position) then
2291 raise Program_Error with "Position cursor designates root";
2294 if Target'Address = Source'Address then
2295 if Position.Node.Parent = Parent.Node then
2296 if Position.Node = Before.Node then
2300 if Position.Node.Next = Before.Node then
2305 if Target.Busy > 0 then
2307 with "attempt to tamper with cursors (Target tree is busy)";
2310 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2311 raise Constraint_Error with "Position is ancestor of Parent";
2314 Remove_Subtree (Position.Node);
2316 Position.Node.Parent := Parent.Node;
2317 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2322 if Target.Busy > 0 then
2324 with "attempt to tamper with cursors (Target tree is busy)";
2327 if Source.Busy > 0 then
2329 with "attempt to tamper with cursors (Source tree is busy)";
2332 -- This is an unfortunate feature of this API: we must count the nodes
2333 -- in the subtree that we remove from the source tree, which is an O(n)
2334 -- operation. It would have been better if the Tree container did not
2335 -- have a Node_Count selector; a user that wants the number of nodes in
2336 -- the tree could simply call Subtree_Node_Count, with the understanding
2337 -- that such an operation is O(n).
2339 -- Of course, we could choose to implement the Node_Count selector as an
2340 -- O(n) operation, which would turn this splice operation into an O(1)
2343 Subtree_Count := Subtree_Node_Count (Position.Node);
2344 pragma Assert (Subtree_Count <= Source.Count);
2346 Remove_Subtree (Position.Node);
2347 Source.Count := Source.Count - Subtree_Count;
2349 Position.Node.Parent := Parent.Node;
2350 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2352 Target.Count := Target.Count + Subtree_Count;
2354 Position.Container := Target'Unrestricted_Access;
2357 procedure Splice_Subtree
2358 (Container : in out Tree;
2364 if Parent = No_Element then
2365 raise Constraint_Error with "Parent cursor has no element";
2368 if Parent.Container /= Container'Unrestricted_Access then
2369 raise Program_Error with "Parent cursor not in container";
2372 if Before /= No_Element then
2373 if Before.Container /= Container'Unrestricted_Access then
2374 raise Program_Error with "Before cursor not in container";
2377 if Before.Node.Parent /= Parent.Node then
2378 raise Constraint_Error with "Before cursor not child of Parent";
2382 if Position = No_Element then
2383 raise Constraint_Error with "Position cursor has no element";
2386 if Position.Container /= Container'Unrestricted_Access then
2387 raise Program_Error with "Position cursor not in container";
2390 if Is_Root (Position) then
2392 -- Should this be PE instead? Need ARG confirmation. ???
2394 raise Constraint_Error with "Position cursor designates root";
2397 if Position.Node.Parent = Parent.Node then
2398 if Position.Node = Before.Node then
2402 if Position.Node.Next = Before.Node then
2407 if Container.Busy > 0 then
2409 with "attempt to tamper with cursors (tree is busy)";
2412 if Is_Reachable (From => Parent.Node, To => Position.Node) then
2413 raise Constraint_Error with "Position is ancestor of Parent";
2416 Remove_Subtree (Position.Node);
2418 Position.Node.Parent := Parent.Node;
2419 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2422 ------------------------
2423 -- Subtree_Node_Count --
2424 ------------------------
2426 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2428 if Position = No_Element then
2432 return Subtree_Node_Count (Position.Node);
2433 end Subtree_Node_Count;
2435 function Subtree_Node_Count
2436 (Subtree : Tree_Node_Access) return Count_Type
2438 Result : Count_Type;
2439 Node : Tree_Node_Access;
2443 Node := Subtree.Children.First;
2444 while Node /= null loop
2445 Result := Result + Subtree_Node_Count (Node);
2450 end Subtree_Node_Count;
2457 (Container : in out Tree;
2461 if I = No_Element then
2462 raise Constraint_Error with "I cursor has no element";
2465 if I.Container /= Container'Unrestricted_Access then
2466 raise Program_Error with "I cursor not in container";
2470 raise Program_Error with "I cursor designates root";
2473 if I = J then -- make this test sooner???
2477 if J = No_Element then
2478 raise Constraint_Error with "J cursor has no element";
2481 if J.Container /= Container'Unrestricted_Access then
2482 raise Program_Error with "J cursor not in container";
2486 raise Program_Error with "J cursor designates root";
2489 if Container.Lock > 0 then
2491 with "attempt to tamper with elements (tree is locked)";
2495 EI : constant Element_Type := I.Node.Element;
2498 I.Node.Element := J.Node.Element;
2499 J.Node.Element := EI;
2503 --------------------
2504 -- Update_Element --
2505 --------------------
2507 procedure Update_Element
2508 (Container : in out Tree;
2510 Process : not null access procedure (Element : in out Element_Type))
2513 if Position = No_Element then
2514 raise Constraint_Error with "Position cursor has no element";
2517 if Position.Container /= Container'Unrestricted_Access then
2518 raise Program_Error with "Position cursor not in container";
2521 if Is_Root (Position) then
2522 raise Program_Error with "Position cursor designates root";
2526 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2527 B : Integer renames T.Busy;
2528 L : Integer renames T.Lock;
2534 Process (Position.Node.Element);
2552 (Stream : not null access Root_Stream_Type'Class;
2555 procedure Write_Children (Subtree : Tree_Node_Access);
2556 procedure Write_Subtree (Subtree : Tree_Node_Access);
2558 --------------------
2559 -- Write_Children --
2560 --------------------
2562 procedure Write_Children (Subtree : Tree_Node_Access) is
2563 CC : Children_Type renames Subtree.Children;
2564 C : Tree_Node_Access;
2567 Count_Type'Write (Stream, Child_Count (CC));
2570 while C /= null loop
2580 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2582 Element_Type'Output (Stream, Subtree.Element);
2583 Write_Children (Subtree);
2586 -- Start of processing for Write
2589 Count_Type'Write (Stream, Container.Count);
2591 if Container.Count = 0 then
2595 Write_Children (Root_Node (Container));
2599 (Stream : not null access Root_Stream_Type'Class;
2603 raise Program_Error with "attempt to write tree cursor to stream";
2607 (Stream : not null access Root_Stream_Type'Class;
2608 Item : Reference_Type)
2611 raise Program_Error with "attempt to stream reference";
2615 (Stream : not null access Root_Stream_Type'Class;
2616 Item : Constant_Reference_Type)
2619 raise Program_Error with "attempt to stream reference";
2622 end Ada.Containers.Multiway_Trees;