File : a-cimutr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 with Ada.Unchecked_Deallocation;
31
32 with System; use type System.Address;
33
34 package body Ada.Containers.Indefinite_Multiway_Trees is
35
36 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
37 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
38 -- See comment in Ada.Containers.Helpers
39
40 --------------------
41 -- Root_Iterator --
42 --------------------
43
44 type Root_Iterator is abstract new Limited_Controlled and
45 Tree_Iterator_Interfaces.Forward_Iterator with
46 record
47 Container : Tree_Access;
48 Subtree : Tree_Node_Access;
49 end record;
50
51 overriding procedure Finalize (Object : in out Root_Iterator);
52
53 -----------------------
54 -- Subtree_Iterator --
55 -----------------------
56
57 type Subtree_Iterator is new Root_Iterator with null record;
58
59 overriding function First (Object : Subtree_Iterator) return Cursor;
60
61 overriding function Next
62 (Object : Subtree_Iterator;
63 Position : Cursor) return Cursor;
64
65 ---------------------
66 -- Child_Iterator --
67 ---------------------
68
69 type Child_Iterator is new Root_Iterator and
70 Tree_Iterator_Interfaces.Reversible_Iterator with null record;
71
72 overriding function First (Object : Child_Iterator) return Cursor;
73
74 overriding function Next
75 (Object : Child_Iterator;
76 Position : Cursor) return Cursor;
77
78 overriding function Last (Object : Child_Iterator) return Cursor;
79
80 overriding function Previous
81 (Object : Child_Iterator;
82 Position : Cursor) return Cursor;
83
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
87
88 function Root_Node (Container : Tree) return Tree_Node_Access;
89
90 procedure Free_Element is
91 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
92
93 procedure Deallocate_Node (X : in out Tree_Node_Access);
94
95 procedure Deallocate_Children
96 (Subtree : Tree_Node_Access;
97 Count : in out Count_Type);
98
99 procedure Deallocate_Subtree
100 (Subtree : in out Tree_Node_Access;
101 Count : in out Count_Type);
102
103 function Equal_Children
104 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
105
106 function Equal_Subtree
107 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
108
109 procedure Iterate_Children
110 (Container : Tree_Access;
111 Subtree : Tree_Node_Access;
112 Process : not null access procedure (Position : Cursor));
113
114 procedure Iterate_Subtree
115 (Container : Tree_Access;
116 Subtree : Tree_Node_Access;
117 Process : not null access procedure (Position : Cursor));
118
119 procedure Copy_Children
120 (Source : Children_Type;
121 Parent : Tree_Node_Access;
122 Count : in out Count_Type);
123
124 procedure Copy_Subtree
125 (Source : Tree_Node_Access;
126 Parent : Tree_Node_Access;
127 Target : out Tree_Node_Access;
128 Count : in out Count_Type);
129
130 function Find_In_Children
131 (Subtree : Tree_Node_Access;
132 Item : Element_Type) return Tree_Node_Access;
133
134 function Find_In_Subtree
135 (Subtree : Tree_Node_Access;
136 Item : Element_Type) return Tree_Node_Access;
137
138 function Child_Count (Children : Children_Type) return Count_Type;
139
140 function Subtree_Node_Count
141 (Subtree : Tree_Node_Access) return Count_Type;
142
143 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
144
145 procedure Remove_Subtree (Subtree : Tree_Node_Access);
146
147 procedure Insert_Subtree_Node
148 (Subtree : Tree_Node_Access;
149 Parent : Tree_Node_Access;
150 Before : Tree_Node_Access);
151
152 procedure Insert_Subtree_List
153 (First : Tree_Node_Access;
154 Last : Tree_Node_Access;
155 Parent : Tree_Node_Access;
156 Before : Tree_Node_Access);
157
158 procedure Splice_Children
159 (Target_Parent : Tree_Node_Access;
160 Before : Tree_Node_Access;
161 Source_Parent : Tree_Node_Access);
162
163 ---------
164 -- "=" --
165 ---------
166
167 function "=" (Left, Right : Tree) return Boolean is
168 begin
169 return Equal_Children (Root_Node (Left), Root_Node (Right));
170 end "=";
171
172 ------------
173 -- Adjust --
174 ------------
175
176 procedure Adjust (Container : in out Tree) is
177 Source : constant Children_Type := Container.Root.Children;
178 Source_Count : constant Count_Type := Container.Count;
179 Target_Count : Count_Type;
180
181 begin
182 -- We first restore the target container to its default-initialized
183 -- state, before we attempt any allocation, to ensure that invariants
184 -- are preserved in the event that the allocation fails.
185
186 Container.Root.Children := Children_Type'(others => null);
187 Zero_Counts (Container.TC);
188 Container.Count := 0;
189
190 -- Copy_Children returns a count of the number of nodes that it
191 -- allocates, but it works by incrementing the value that is passed in.
192 -- We must therefore initialize the count value before calling
193 -- Copy_Children.
194
195 Target_Count := 0;
196
197 -- Now we attempt the allocation of subtrees. The invariants are
198 -- satisfied even if the allocation fails.
199
200 Copy_Children (Source, Root_Node (Container), Target_Count);
201 pragma Assert (Target_Count = Source_Count);
202
203 Container.Count := Source_Count;
204 end Adjust;
205
206 -------------------
207 -- Ancestor_Find --
208 -------------------
209
210 function Ancestor_Find
211 (Position : Cursor;
212 Item : Element_Type) return Cursor
213 is
214 R, N : Tree_Node_Access;
215
216 begin
217 if Checks and then Position = No_Element then
218 raise Constraint_Error with "Position cursor has no element";
219 end if;
220
221 -- Commented-out pending ARG ruling. ???
222
223 -- if Checks and then
224 -- Position.Container /= Container'Unrestricted_Access
225 -- then
226 -- raise Program_Error with "Position cursor not in container";
227 -- end if;
228
229 -- AI-0136 says to raise PE if Position equals the root node. This does
230 -- not seem correct, as this value is just the limiting condition of the
231 -- search. For now we omit this check pending a ruling from the ARG.???
232
233 -- if Checks and then Is_Root (Position) then
234 -- raise Program_Error with "Position cursor designates root";
235 -- end if;
236
237 R := Root_Node (Position.Container.all);
238 N := Position.Node;
239 while N /= R loop
240 if N.Element.all = Item then
241 return Cursor'(Position.Container, N);
242 end if;
243
244 N := N.Parent;
245 end loop;
246
247 return No_Element;
248 end Ancestor_Find;
249
250 ------------------
251 -- Append_Child --
252 ------------------
253
254 procedure Append_Child
255 (Container : in out Tree;
256 Parent : Cursor;
257 New_Item : Element_Type;
258 Count : Count_Type := 1)
259 is
260 First, Last : Tree_Node_Access;
261 Element : Element_Access;
262
263 begin
264 if Checks and then Parent = No_Element then
265 raise Constraint_Error with "Parent cursor has no element";
266 end if;
267
268 if Checks and then Parent.Container /= Container'Unrestricted_Access then
269 raise Program_Error with "Parent cursor not in container";
270 end if;
271
272 if Count = 0 then
273 return;
274 end if;
275
276 TC_Check (Container.TC);
277
278 declare
279 -- The element allocator may need an accessibility check in the case
280 -- the actual type is class-wide or has access discriminants (see
281 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
282 -- allocator in the loop below, because the one in this block would
283 -- have failed already.
284
285 pragma Unsuppress (Accessibility_Check);
286
287 begin
288 Element := new Element_Type'(New_Item);
289 end;
290
291 First := new Tree_Node_Type'(Parent => Parent.Node,
292 Element => Element,
293 others => <>);
294
295 Last := First;
296
297 for J in Count_Type'(2) .. Count loop
298
299 -- Reclaim other nodes if Storage_Error. ???
300
301 Element := new Element_Type'(New_Item);
302 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
303 Prev => Last,
304 Element => Element,
305 others => <>);
306
307 Last := Last.Next;
308 end loop;
309
310 Insert_Subtree_List
311 (First => First,
312 Last => Last,
313 Parent => Parent.Node,
314 Before => null); -- null means "insert at end of list"
315
316 -- In order for operation Node_Count to complete in O(1) time, we cache
317 -- the count value. Here we increment the total count by the number of
318 -- nodes we just inserted.
319
320 Container.Count := Container.Count + Count;
321 end Append_Child;
322
323 ------------
324 -- Assign --
325 ------------
326
327 procedure Assign (Target : in out Tree; Source : Tree) is
328 Source_Count : constant Count_Type := Source.Count;
329 Target_Count : Count_Type;
330
331 begin
332 if Target'Address = Source'Address then
333 return;
334 end if;
335
336 Target.Clear; -- checks busy bit
337
338 -- Copy_Children returns the number of nodes that it allocates, but it
339 -- does this by incrementing the count value passed in, so we must
340 -- initialize the count before calling Copy_Children.
341
342 Target_Count := 0;
343
344 -- Note that Copy_Children inserts the newly-allocated children into
345 -- their parent list only after the allocation of all the children has
346 -- succeeded. This preserves invariants even if the allocation fails.
347
348 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
349 pragma Assert (Target_Count = Source_Count);
350
351 Target.Count := Source_Count;
352 end Assign;
353
354 -----------------
355 -- Child_Count --
356 -----------------
357
358 function Child_Count (Parent : Cursor) return Count_Type is
359 begin
360 if Parent = No_Element then
361 return 0;
362 else
363 return Child_Count (Parent.Node.Children);
364 end if;
365 end Child_Count;
366
367 function Child_Count (Children : Children_Type) return Count_Type is
368 Result : Count_Type;
369 Node : Tree_Node_Access;
370
371 begin
372 Result := 0;
373 Node := Children.First;
374 while Node /= null loop
375 Result := Result + 1;
376 Node := Node.Next;
377 end loop;
378
379 return Result;
380 end Child_Count;
381
382 -----------------
383 -- Child_Depth --
384 -----------------
385
386 function Child_Depth (Parent, Child : Cursor) return Count_Type is
387 Result : Count_Type;
388 N : Tree_Node_Access;
389
390 begin
391 if Checks and then Parent = No_Element then
392 raise Constraint_Error with "Parent cursor has no element";
393 end if;
394
395 if Checks and then Child = No_Element then
396 raise Constraint_Error with "Child cursor has no element";
397 end if;
398
399 if Checks and then Parent.Container /= Child.Container then
400 raise Program_Error with "Parent and Child in different containers";
401 end if;
402
403 Result := 0;
404 N := Child.Node;
405 while N /= Parent.Node loop
406 Result := Result + 1;
407 N := N.Parent;
408
409 if Checks and then N = null then
410 raise Program_Error with "Parent is not ancestor of Child";
411 end if;
412 end loop;
413
414 return Result;
415 end Child_Depth;
416
417 -----------
418 -- Clear --
419 -----------
420
421 procedure Clear (Container : in out Tree) is
422 Container_Count : Count_Type;
423 Children_Count : Count_Type;
424
425 begin
426 TC_Check (Container.TC);
427
428 -- We first set the container count to 0, in order to preserve
429 -- invariants in case the deallocation fails. (This works because
430 -- Deallocate_Children immediately removes the children from their
431 -- parent, and then does the actual deallocation.)
432
433 Container_Count := Container.Count;
434 Container.Count := 0;
435
436 -- Deallocate_Children returns the number of nodes that it deallocates,
437 -- but it does this by incrementing the count value that is passed in,
438 -- so we must first initialize the count return value before calling it.
439
440 Children_Count := 0;
441
442 -- See comment above. Deallocate_Children immediately removes the
443 -- children list from their parent node (here, the root of the tree),
444 -- and only after that does it attempt the actual deallocation. So even
445 -- if the deallocation fails, the representation invariants
446
447 Deallocate_Children (Root_Node (Container), Children_Count);
448 pragma Assert (Children_Count = Container_Count);
449 end Clear;
450
451 ------------------------
452 -- Constant_Reference --
453 ------------------------
454
455 function Constant_Reference
456 (Container : aliased Tree;
457 Position : Cursor) return Constant_Reference_Type
458 is
459 begin
460 if Checks and then Position.Container = null then
461 raise Constraint_Error with
462 "Position cursor has no element";
463 end if;
464
465 if Checks and then Position.Container /= Container'Unrestricted_Access
466 then
467 raise Program_Error with
468 "Position cursor designates wrong container";
469 end if;
470
471 if Checks and then Position.Node = Root_Node (Container) then
472 raise Program_Error with "Position cursor designates root";
473 end if;
474
475 if Checks and then Position.Node.Element = null then
476 raise Program_Error with "Node has no element";
477 end if;
478
479 -- Implement Vet for multiway tree???
480 -- pragma Assert (Vet (Position),
481 -- "Position cursor in Constant_Reference is bad");
482
483 declare
484 TC : constant Tamper_Counts_Access :=
485 Container.TC'Unrestricted_Access;
486 begin
487 return R : constant Constant_Reference_Type :=
488 (Element => Position.Node.Element.all'Access,
489 Control => (Controlled with TC))
490 do
491 Lock (TC.all);
492 end return;
493 end;
494 end Constant_Reference;
495
496 --------------
497 -- Contains --
498 --------------
499
500 function Contains
501 (Container : Tree;
502 Item : Element_Type) return Boolean
503 is
504 begin
505 return Find (Container, Item) /= No_Element;
506 end Contains;
507
508 ----------
509 -- Copy --
510 ----------
511
512 function Copy (Source : Tree) return Tree is
513 begin
514 return Target : Tree do
515 Copy_Children
516 (Source => Source.Root.Children,
517 Parent => Root_Node (Target),
518 Count => Target.Count);
519
520 pragma Assert (Target.Count = Source.Count);
521 end return;
522 end Copy;
523
524 -------------------
525 -- Copy_Children --
526 -------------------
527
528 procedure Copy_Children
529 (Source : Children_Type;
530 Parent : Tree_Node_Access;
531 Count : in out Count_Type)
532 is
533 pragma Assert (Parent /= null);
534 pragma Assert (Parent.Children.First = null);
535 pragma Assert (Parent.Children.Last = null);
536
537 CC : Children_Type;
538 C : Tree_Node_Access;
539
540 begin
541 -- We special-case the first allocation, in order to establish the
542 -- representation invariants for type Children_Type.
543
544 C := Source.First;
545
546 if C = null then
547 return;
548 end if;
549
550 Copy_Subtree
551 (Source => C,
552 Parent => Parent,
553 Target => CC.First,
554 Count => Count);
555
556 CC.Last := CC.First;
557
558 -- The representation invariants for the Children_Type list have been
559 -- established, so we can now copy the remaining children of Source.
560
561 C := C.Next;
562 while C /= null loop
563 Copy_Subtree
564 (Source => C,
565 Parent => Parent,
566 Target => CC.Last.Next,
567 Count => Count);
568
569 CC.Last.Next.Prev := CC.Last;
570 CC.Last := CC.Last.Next;
571
572 C := C.Next;
573 end loop;
574
575 -- We add the newly-allocated children to their parent list only after
576 -- the allocation has succeeded, in order to preserve invariants of the
577 -- parent.
578
579 Parent.Children := CC;
580 end Copy_Children;
581
582 ------------------
583 -- Copy_Subtree --
584 ------------------
585
586 procedure Copy_Subtree
587 (Target : in out Tree;
588 Parent : Cursor;
589 Before : Cursor;
590 Source : Cursor)
591 is
592 Target_Subtree : Tree_Node_Access;
593 Target_Count : Count_Type;
594
595 begin
596 if Checks and then Parent = No_Element then
597 raise Constraint_Error with "Parent cursor has no element";
598 end if;
599
600 if Checks and then Parent.Container /= Target'Unrestricted_Access then
601 raise Program_Error with "Parent cursor not in container";
602 end if;
603
604 if Before /= No_Element then
605 if Checks and then Before.Container /= Target'Unrestricted_Access then
606 raise Program_Error with "Before cursor not in container";
607 end if;
608
609 if Checks and then Before.Node.Parent /= Parent.Node then
610 raise Constraint_Error with "Before cursor not child of Parent";
611 end if;
612 end if;
613
614 if Source = No_Element then
615 return;
616 end if;
617
618 if Checks and then Is_Root (Source) then
619 raise Constraint_Error with "Source cursor designates root";
620 end if;
621
622 -- Copy_Subtree returns a count of the number of nodes that it
623 -- allocates, but it works by incrementing the value that is passed in.
624 -- We must therefore initialize the count value before calling
625 -- Copy_Subtree.
626
627 Target_Count := 0;
628
629 Copy_Subtree
630 (Source => Source.Node,
631 Parent => Parent.Node,
632 Target => Target_Subtree,
633 Count => Target_Count);
634
635 pragma Assert (Target_Subtree /= null);
636 pragma Assert (Target_Subtree.Parent = Parent.Node);
637 pragma Assert (Target_Count >= 1);
638
639 Insert_Subtree_Node
640 (Subtree => Target_Subtree,
641 Parent => Parent.Node,
642 Before => Before.Node);
643
644 -- In order for operation Node_Count to complete in O(1) time, we cache
645 -- the count value. Here we increment the total count by the number of
646 -- nodes we just inserted.
647
648 Target.Count := Target.Count + Target_Count;
649 end Copy_Subtree;
650
651 procedure Copy_Subtree
652 (Source : Tree_Node_Access;
653 Parent : Tree_Node_Access;
654 Target : out Tree_Node_Access;
655 Count : in out Count_Type)
656 is
657 E : constant Element_Access := new Element_Type'(Source.Element.all);
658
659 begin
660 Target := new Tree_Node_Type'(Element => E,
661 Parent => Parent,
662 others => <>);
663
664 Count := Count + 1;
665
666 Copy_Children
667 (Source => Source.Children,
668 Parent => Target,
669 Count => Count);
670 end Copy_Subtree;
671
672 -------------------------
673 -- Deallocate_Children --
674 -------------------------
675
676 procedure Deallocate_Children
677 (Subtree : Tree_Node_Access;
678 Count : in out Count_Type)
679 is
680 pragma Assert (Subtree /= null);
681
682 CC : Children_Type := Subtree.Children;
683 C : Tree_Node_Access;
684
685 begin
686 -- We immediately remove the children from their parent, in order to
687 -- preserve invariants in case the deallocation fails.
688
689 Subtree.Children := Children_Type'(others => null);
690
691 while CC.First /= null loop
692 C := CC.First;
693 CC.First := C.Next;
694
695 Deallocate_Subtree (C, Count);
696 end loop;
697 end Deallocate_Children;
698
699 ---------------------
700 -- Deallocate_Node --
701 ---------------------
702
703 procedure Deallocate_Node (X : in out Tree_Node_Access) is
704 procedure Free_Node is
705 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
706
707 -- Start of processing for Deallocate_Node
708
709 begin
710 if X /= null then
711 Free_Element (X.Element);
712 Free_Node (X);
713 end if;
714 end Deallocate_Node;
715
716 ------------------------
717 -- Deallocate_Subtree --
718 ------------------------
719
720 procedure Deallocate_Subtree
721 (Subtree : in out Tree_Node_Access;
722 Count : in out Count_Type)
723 is
724 begin
725 Deallocate_Children (Subtree, Count);
726 Deallocate_Node (Subtree);
727 Count := Count + 1;
728 end Deallocate_Subtree;
729
730 ---------------------
731 -- Delete_Children --
732 ---------------------
733
734 procedure Delete_Children
735 (Container : in out Tree;
736 Parent : Cursor)
737 is
738 Count : Count_Type;
739
740 begin
741 if Checks and then Parent = No_Element then
742 raise Constraint_Error with "Parent cursor has no element";
743 end if;
744
745 if Checks and then Parent.Container /= Container'Unrestricted_Access then
746 raise Program_Error with "Parent cursor not in container";
747 end if;
748
749 TC_Check (Container.TC);
750
751 -- Deallocate_Children returns a count of the number of nodes
752 -- that it deallocates, but it works by incrementing the
753 -- value that is passed in. We must therefore initialize
754 -- the count value before calling Deallocate_Children.
755
756 Count := 0;
757
758 Deallocate_Children (Parent.Node, Count);
759 pragma Assert (Count <= Container.Count);
760
761 Container.Count := Container.Count - Count;
762 end Delete_Children;
763
764 -----------------
765 -- Delete_Leaf --
766 -----------------
767
768 procedure Delete_Leaf
769 (Container : in out Tree;
770 Position : in out Cursor)
771 is
772 X : Tree_Node_Access;
773
774 begin
775 if Checks and then Position = No_Element then
776 raise Constraint_Error with "Position cursor has no element";
777 end if;
778
779 if Checks and then Position.Container /= Container'Unrestricted_Access
780 then
781 raise Program_Error with "Position cursor not in container";
782 end if;
783
784 if Checks and then Is_Root (Position) then
785 raise Program_Error with "Position cursor designates root";
786 end if;
787
788 if Checks and then not Is_Leaf (Position) then
789 raise Constraint_Error with "Position cursor does not designate leaf";
790 end if;
791
792 TC_Check (Container.TC);
793
794 X := Position.Node;
795 Position := No_Element;
796
797 -- Restore represention invariants before attempting the actual
798 -- deallocation.
799
800 Remove_Subtree (X);
801 Container.Count := Container.Count - 1;
802
803 -- It is now safe to attempt the deallocation. This leaf node has been
804 -- disassociated from the tree, so even if the deallocation fails,
805 -- representation invariants will remain satisfied.
806
807 Deallocate_Node (X);
808 end Delete_Leaf;
809
810 --------------------
811 -- Delete_Subtree --
812 --------------------
813
814 procedure Delete_Subtree
815 (Container : in out Tree;
816 Position : in out Cursor)
817 is
818 X : Tree_Node_Access;
819 Count : Count_Type;
820
821 begin
822 if Checks and then Position = No_Element then
823 raise Constraint_Error with "Position cursor has no element";
824 end if;
825
826 if Checks and then Position.Container /= Container'Unrestricted_Access
827 then
828 raise Program_Error with "Position cursor not in container";
829 end if;
830
831 if Checks and then Is_Root (Position) then
832 raise Program_Error with "Position cursor designates root";
833 end if;
834
835 TC_Check (Container.TC);
836
837 X := Position.Node;
838 Position := No_Element;
839
840 -- Here is one case where a deallocation failure can result in the
841 -- violation of a representation invariant. We disassociate the subtree
842 -- from the tree now, but we only decrement the total node count after
843 -- we attempt the deallocation. However, if the deallocation fails, the
844 -- total node count will not get decremented.
845
846 -- One way around this dilemma is to count the nodes in the subtree
847 -- before attempt to delete the subtree, but that is an O(n) operation,
848 -- so it does not seem worth it.
849
850 -- Perhaps this is much ado about nothing, since the only way
851 -- deallocation can fail is if Controlled Finalization fails: this
852 -- propagates Program_Error so all bets are off anyway. ???
853
854 Remove_Subtree (X);
855
856 -- Deallocate_Subtree returns a count of the number of nodes that it
857 -- deallocates, but it works by incrementing the value that is passed
858 -- in. We must therefore initialize the count value before calling
859 -- Deallocate_Subtree.
860
861 Count := 0;
862
863 Deallocate_Subtree (X, Count);
864 pragma Assert (Count <= Container.Count);
865
866 -- See comments above. We would prefer to do this sooner, but there's no
867 -- way to satisfy that goal without an potentially severe execution
868 -- penalty.
869
870 Container.Count := Container.Count - Count;
871 end Delete_Subtree;
872
873 -----------
874 -- Depth --
875 -----------
876
877 function Depth (Position : Cursor) return Count_Type is
878 Result : Count_Type;
879 N : Tree_Node_Access;
880
881 begin
882 Result := 0;
883 N := Position.Node;
884 while N /= null loop
885 N := N.Parent;
886 Result := Result + 1;
887 end loop;
888
889 return Result;
890 end Depth;
891
892 -------------
893 -- Element --
894 -------------
895
896 function Element (Position : Cursor) return Element_Type is
897 begin
898 if Checks and then Position.Container = null then
899 raise Constraint_Error with "Position cursor has no element";
900 end if;
901
902 if Checks and then Position.Node = Root_Node (Position.Container.all)
903 then
904 raise Program_Error with "Position cursor designates root";
905 end if;
906
907 return Position.Node.Element.all;
908 end Element;
909
910 --------------------
911 -- Equal_Children --
912 --------------------
913
914 function Equal_Children
915 (Left_Subtree : Tree_Node_Access;
916 Right_Subtree : Tree_Node_Access) return Boolean
917 is
918 Left_Children : Children_Type renames Left_Subtree.Children;
919 Right_Children : Children_Type renames Right_Subtree.Children;
920
921 L, R : Tree_Node_Access;
922
923 begin
924 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
925 return False;
926 end if;
927
928 L := Left_Children.First;
929 R := Right_Children.First;
930 while L /= null loop
931 if not Equal_Subtree (L, R) then
932 return False;
933 end if;
934
935 L := L.Next;
936 R := R.Next;
937 end loop;
938
939 return True;
940 end Equal_Children;
941
942 -------------------
943 -- Equal_Subtree --
944 -------------------
945
946 function Equal_Subtree
947 (Left_Position : Cursor;
948 Right_Position : Cursor) return Boolean
949 is
950 begin
951 if Checks and then Left_Position = No_Element then
952 raise Constraint_Error with "Left cursor has no element";
953 end if;
954
955 if Checks and then Right_Position = No_Element then
956 raise Constraint_Error with "Right cursor has no element";
957 end if;
958
959 if Left_Position = Right_Position then
960 return True;
961 end if;
962
963 if Is_Root (Left_Position) then
964 if not Is_Root (Right_Position) then
965 return False;
966 end if;
967
968 return Equal_Children (Left_Position.Node, Right_Position.Node);
969 end if;
970
971 if Is_Root (Right_Position) then
972 return False;
973 end if;
974
975 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
976 end Equal_Subtree;
977
978 function Equal_Subtree
979 (Left_Subtree : Tree_Node_Access;
980 Right_Subtree : Tree_Node_Access) return Boolean
981 is
982 begin
983 if Left_Subtree.Element.all /= Right_Subtree.Element.all then
984 return False;
985 end if;
986
987 return Equal_Children (Left_Subtree, Right_Subtree);
988 end Equal_Subtree;
989
990 --------------
991 -- Finalize --
992 --------------
993
994 procedure Finalize (Object : in out Root_Iterator) is
995 begin
996 Unbusy (Object.Container.TC);
997 end Finalize;
998
999 ----------
1000 -- Find --
1001 ----------
1002
1003 function Find
1004 (Container : Tree;
1005 Item : Element_Type) return Cursor
1006 is
1007 N : constant Tree_Node_Access :=
1008 Find_In_Children (Root_Node (Container), Item);
1009
1010 begin
1011 if N = null then
1012 return No_Element;
1013 end if;
1014
1015 return Cursor'(Container'Unrestricted_Access, N);
1016 end Find;
1017
1018 -----------
1019 -- First --
1020 -----------
1021
1022 overriding function First (Object : Subtree_Iterator) return Cursor is
1023 begin
1024 if Object.Subtree = Root_Node (Object.Container.all) then
1025 return First_Child (Root (Object.Container.all));
1026 else
1027 return Cursor'(Object.Container, Object.Subtree);
1028 end if;
1029 end First;
1030
1031 overriding function First (Object : Child_Iterator) return Cursor is
1032 begin
1033 return First_Child (Cursor'(Object.Container, Object.Subtree));
1034 end First;
1035
1036 -----------------
1037 -- First_Child --
1038 -----------------
1039
1040 function First_Child (Parent : Cursor) return Cursor is
1041 Node : Tree_Node_Access;
1042
1043 begin
1044 if Checks and then Parent = No_Element then
1045 raise Constraint_Error with "Parent cursor has no element";
1046 end if;
1047
1048 Node := Parent.Node.Children.First;
1049
1050 if Node = null then
1051 return No_Element;
1052 end if;
1053
1054 return Cursor'(Parent.Container, Node);
1055 end First_Child;
1056
1057 -------------------------
1058 -- First_Child_Element --
1059 -------------------------
1060
1061 function First_Child_Element (Parent : Cursor) return Element_Type is
1062 begin
1063 return Element (First_Child (Parent));
1064 end First_Child_Element;
1065
1066 ----------------------
1067 -- Find_In_Children --
1068 ----------------------
1069
1070 function Find_In_Children
1071 (Subtree : Tree_Node_Access;
1072 Item : Element_Type) return Tree_Node_Access
1073 is
1074 N, Result : Tree_Node_Access;
1075
1076 begin
1077 N := Subtree.Children.First;
1078 while N /= null loop
1079 Result := Find_In_Subtree (N, Item);
1080
1081 if Result /= null then
1082 return Result;
1083 end if;
1084
1085 N := N.Next;
1086 end loop;
1087
1088 return null;
1089 end Find_In_Children;
1090
1091 ---------------------
1092 -- Find_In_Subtree --
1093 ---------------------
1094
1095 function Find_In_Subtree
1096 (Position : Cursor;
1097 Item : Element_Type) return Cursor
1098 is
1099 Result : Tree_Node_Access;
1100
1101 begin
1102 if Checks and then Position = No_Element then
1103 raise Constraint_Error with "Position cursor has no element";
1104 end if;
1105
1106 -- Commented-out pending ruling from ARG. ???
1107
1108 -- if Checks and then
1109 -- Position.Container /= Container'Unrestricted_Access
1110 -- then
1111 -- raise Program_Error with "Position cursor not in container";
1112 -- end if;
1113
1114 if Is_Root (Position) then
1115 Result := Find_In_Children (Position.Node, Item);
1116
1117 else
1118 Result := Find_In_Subtree (Position.Node, Item);
1119 end if;
1120
1121 if Result = null then
1122 return No_Element;
1123 end if;
1124
1125 return Cursor'(Position.Container, Result);
1126 end Find_In_Subtree;
1127
1128 function Find_In_Subtree
1129 (Subtree : Tree_Node_Access;
1130 Item : Element_Type) return Tree_Node_Access
1131 is
1132 begin
1133 if Subtree.Element.all = Item then
1134 return Subtree;
1135 end if;
1136
1137 return Find_In_Children (Subtree, Item);
1138 end Find_In_Subtree;
1139
1140 ------------------------
1141 -- Get_Element_Access --
1142 ------------------------
1143
1144 function Get_Element_Access
1145 (Position : Cursor) return not null Element_Access is
1146 begin
1147 return Position.Node.Element;
1148 end Get_Element_Access;
1149
1150 -----------------
1151 -- Has_Element --
1152 -----------------
1153
1154 function Has_Element (Position : Cursor) return Boolean is
1155 begin
1156 if Position = No_Element then
1157 return False;
1158 end if;
1159
1160 return Position.Node.Parent /= null;
1161 end Has_Element;
1162
1163 ------------------
1164 -- Insert_Child --
1165 ------------------
1166
1167 procedure Insert_Child
1168 (Container : in out Tree;
1169 Parent : Cursor;
1170 Before : Cursor;
1171 New_Item : Element_Type;
1172 Count : Count_Type := 1)
1173 is
1174 Position : Cursor;
1175 pragma Unreferenced (Position);
1176
1177 begin
1178 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1179 end Insert_Child;
1180
1181 procedure Insert_Child
1182 (Container : in out Tree;
1183 Parent : Cursor;
1184 Before : Cursor;
1185 New_Item : Element_Type;
1186 Position : out Cursor;
1187 Count : Count_Type := 1)
1188 is
1189 First : Tree_Node_Access;
1190 Last : Tree_Node_Access;
1191 Element : Element_Access;
1192
1193 begin
1194 if Checks and then Parent = No_Element then
1195 raise Constraint_Error with "Parent cursor has no element";
1196 end if;
1197
1198 if Checks and then Parent.Container /= Container'Unrestricted_Access then
1199 raise Program_Error with "Parent cursor not in container";
1200 end if;
1201
1202 if Before /= No_Element then
1203 if Checks and then Before.Container /= Container'Unrestricted_Access
1204 then
1205 raise Program_Error with "Before cursor not in container";
1206 end if;
1207
1208 if Checks and then Before.Node.Parent /= Parent.Node then
1209 raise Constraint_Error with "Parent cursor not parent of Before";
1210 end if;
1211 end if;
1212
1213 if Count = 0 then
1214 Position := No_Element; -- Need ruling from ARG ???
1215 return;
1216 end if;
1217
1218 TC_Check (Container.TC);
1219
1220 declare
1221 -- The element allocator may need an accessibility check in the case
1222 -- the actual type is class-wide or has access discriminants (see
1223 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1224 -- allocator in the loop below, because the one in this block would
1225 -- have failed already.
1226
1227 pragma Unsuppress (Accessibility_Check);
1228
1229 begin
1230 Element := new Element_Type'(New_Item);
1231 end;
1232
1233 First := new Tree_Node_Type'(Parent => Parent.Node,
1234 Element => Element,
1235 others => <>);
1236
1237 Last := First;
1238 for J in Count_Type'(2) .. Count loop
1239
1240 -- Reclaim other nodes if Storage_Error. ???
1241
1242 Element := new Element_Type'(New_Item);
1243 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1244 Prev => Last,
1245 Element => Element,
1246 others => <>);
1247
1248 Last := Last.Next;
1249 end loop;
1250
1251 Insert_Subtree_List
1252 (First => First,
1253 Last => Last,
1254 Parent => Parent.Node,
1255 Before => Before.Node);
1256
1257 -- In order for operation Node_Count to complete in O(1) time, we cache
1258 -- the count value. Here we increment the total count by the number of
1259 -- nodes we just inserted.
1260
1261 Container.Count := Container.Count + Count;
1262
1263 Position := Cursor'(Parent.Container, First);
1264 end Insert_Child;
1265
1266 -------------------------
1267 -- Insert_Subtree_List --
1268 -------------------------
1269
1270 procedure Insert_Subtree_List
1271 (First : Tree_Node_Access;
1272 Last : Tree_Node_Access;
1273 Parent : Tree_Node_Access;
1274 Before : Tree_Node_Access)
1275 is
1276 pragma Assert (Parent /= null);
1277 C : Children_Type renames Parent.Children;
1278
1279 begin
1280 -- This is a simple utility operation to insert a list of nodes (from
1281 -- First..Last) as children of Parent. The Before node specifies where
1282 -- the new children should be inserted relative to the existing
1283 -- children.
1284
1285 if First = null then
1286 pragma Assert (Last = null);
1287 return;
1288 end if;
1289
1290 pragma Assert (Last /= null);
1291 pragma Assert (Before = null or else Before.Parent = Parent);
1292
1293 if C.First = null then
1294 C.First := First;
1295 C.First.Prev := null;
1296 C.Last := Last;
1297 C.Last.Next := null;
1298
1299 elsif Before = null then -- means "insert after existing nodes"
1300 C.Last.Next := First;
1301 First.Prev := C.Last;
1302 C.Last := Last;
1303 C.Last.Next := null;
1304
1305 elsif Before = C.First then
1306 Last.Next := C.First;
1307 C.First.Prev := Last;
1308 C.First := First;
1309 C.First.Prev := null;
1310
1311 else
1312 Before.Prev.Next := First;
1313 First.Prev := Before.Prev;
1314 Last.Next := Before;
1315 Before.Prev := Last;
1316 end if;
1317 end Insert_Subtree_List;
1318
1319 -------------------------
1320 -- Insert_Subtree_Node --
1321 -------------------------
1322
1323 procedure Insert_Subtree_Node
1324 (Subtree : Tree_Node_Access;
1325 Parent : Tree_Node_Access;
1326 Before : Tree_Node_Access)
1327 is
1328 begin
1329 -- This is a simple wrapper operation to insert a single child into the
1330 -- Parent's children list.
1331
1332 Insert_Subtree_List
1333 (First => Subtree,
1334 Last => Subtree,
1335 Parent => Parent,
1336 Before => Before);
1337 end Insert_Subtree_Node;
1338
1339 --------------
1340 -- Is_Empty --
1341 --------------
1342
1343 function Is_Empty (Container : Tree) return Boolean is
1344 begin
1345 return Container.Root.Children.First = null;
1346 end Is_Empty;
1347
1348 -------------
1349 -- Is_Leaf --
1350 -------------
1351
1352 function Is_Leaf (Position : Cursor) return Boolean is
1353 begin
1354 if Position = No_Element then
1355 return False;
1356 end if;
1357
1358 return Position.Node.Children.First = null;
1359 end Is_Leaf;
1360
1361 ------------------
1362 -- Is_Reachable --
1363 ------------------
1364
1365 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
1366 pragma Assert (From /= null);
1367 pragma Assert (To /= null);
1368
1369 N : Tree_Node_Access;
1370
1371 begin
1372 N := From;
1373 while N /= null loop
1374 if N = To then
1375 return True;
1376 end if;
1377
1378 N := N.Parent;
1379 end loop;
1380
1381 return False;
1382 end Is_Reachable;
1383
1384 -------------
1385 -- Is_Root --
1386 -------------
1387
1388 function Is_Root (Position : Cursor) return Boolean is
1389 begin
1390 if Position.Container = null then
1391 return False;
1392 end if;
1393
1394 return Position = Root (Position.Container.all);
1395 end Is_Root;
1396
1397 -------------
1398 -- Iterate --
1399 -------------
1400
1401 procedure Iterate
1402 (Container : Tree;
1403 Process : not null access procedure (Position : Cursor))
1404 is
1405 Busy : With_Busy (Container.TC'Unrestricted_Access);
1406 begin
1407 Iterate_Children
1408 (Container => Container'Unrestricted_Access,
1409 Subtree => Root_Node (Container),
1410 Process => Process);
1411 end Iterate;
1412
1413 function Iterate (Container : Tree)
1414 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1415 is
1416 begin
1417 return Iterate_Subtree (Root (Container));
1418 end Iterate;
1419
1420 ----------------------
1421 -- Iterate_Children --
1422 ----------------------
1423
1424 procedure Iterate_Children
1425 (Parent : Cursor;
1426 Process : not null access procedure (Position : Cursor))
1427 is
1428 C : Tree_Node_Access;
1429 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
1430 begin
1431 if Checks and then Parent = No_Element then
1432 raise Constraint_Error with "Parent cursor has no element";
1433 end if;
1434
1435 C := Parent.Node.Children.First;
1436 while C /= null loop
1437 Process (Position => Cursor'(Parent.Container, Node => C));
1438 C := C.Next;
1439 end loop;
1440 end Iterate_Children;
1441
1442 procedure Iterate_Children
1443 (Container : Tree_Access;
1444 Subtree : Tree_Node_Access;
1445 Process : not null access procedure (Position : Cursor))
1446 is
1447 Node : Tree_Node_Access;
1448
1449 begin
1450 -- This is a helper function to recursively iterate over all the nodes
1451 -- in a subtree, in depth-first fashion. This particular helper just
1452 -- visits the children of this subtree, not the root of the subtree node
1453 -- itself. This is useful when starting from the ultimate root of the
1454 -- entire tree (see Iterate), as that root does not have an element.
1455
1456 Node := Subtree.Children.First;
1457 while Node /= null loop
1458 Iterate_Subtree (Container, Node, Process);
1459 Node := Node.Next;
1460 end loop;
1461 end Iterate_Children;
1462
1463 function Iterate_Children
1464 (Container : Tree;
1465 Parent : Cursor)
1466 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1467 is
1468 C : constant Tree_Access := Container'Unrestricted_Access;
1469 begin
1470 if Checks and then Parent = No_Element then
1471 raise Constraint_Error with "Parent cursor has no element";
1472 end if;
1473
1474 if Checks and then Parent.Container /= C then
1475 raise Program_Error with "Parent cursor not in container";
1476 end if;
1477
1478 return It : constant Child_Iterator :=
1479 Child_Iterator'(Limited_Controlled with
1480 Container => C,
1481 Subtree => Parent.Node)
1482 do
1483 Busy (C.TC);
1484 end return;
1485 end Iterate_Children;
1486
1487 ---------------------
1488 -- Iterate_Subtree --
1489 ---------------------
1490
1491 function Iterate_Subtree
1492 (Position : Cursor)
1493 return Tree_Iterator_Interfaces.Forward_Iterator'Class
1494 is
1495 C : constant Tree_Access := Position.Container;
1496 begin
1497 if Checks and then Position = No_Element then
1498 raise Constraint_Error with "Position cursor has no element";
1499 end if;
1500
1501 -- Implement Vet for multiway trees???
1502 -- pragma Assert (Vet (Position), "bad subtree cursor");
1503
1504 return It : constant Subtree_Iterator :=
1505 (Limited_Controlled with
1506 Container => Position.Container,
1507 Subtree => Position.Node)
1508 do
1509 Busy (C.TC);
1510 end return;
1511 end Iterate_Subtree;
1512
1513 procedure Iterate_Subtree
1514 (Position : Cursor;
1515 Process : not null access procedure (Position : Cursor))
1516 is
1517 Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
1518 begin
1519 if Checks and then Position = No_Element then
1520 raise Constraint_Error with "Position cursor has no element";
1521 end if;
1522
1523 if Is_Root (Position) then
1524 Iterate_Children (Position.Container, Position.Node, Process);
1525 else
1526 Iterate_Subtree (Position.Container, Position.Node, Process);
1527 end if;
1528 end Iterate_Subtree;
1529
1530 procedure Iterate_Subtree
1531 (Container : Tree_Access;
1532 Subtree : Tree_Node_Access;
1533 Process : not null access procedure (Position : Cursor))
1534 is
1535 begin
1536 -- This is a helper function to recursively iterate over all the nodes
1537 -- in a subtree, in depth-first fashion. It first visits the root of the
1538 -- subtree, then visits its children.
1539
1540 Process (Cursor'(Container, Subtree));
1541 Iterate_Children (Container, Subtree, Process);
1542 end Iterate_Subtree;
1543
1544 ----------
1545 -- Last --
1546 ----------
1547
1548 overriding function Last (Object : Child_Iterator) return Cursor is
1549 begin
1550 return Last_Child (Cursor'(Object.Container, Object.Subtree));
1551 end Last;
1552
1553 ----------------
1554 -- Last_Child --
1555 ----------------
1556
1557 function Last_Child (Parent : Cursor) return Cursor is
1558 Node : Tree_Node_Access;
1559
1560 begin
1561 if Checks and then Parent = No_Element then
1562 raise Constraint_Error with "Parent cursor has no element";
1563 end if;
1564
1565 Node := Parent.Node.Children.Last;
1566
1567 if Node = null then
1568 return No_Element;
1569 end if;
1570
1571 return (Parent.Container, Node);
1572 end Last_Child;
1573
1574 ------------------------
1575 -- Last_Child_Element --
1576 ------------------------
1577
1578 function Last_Child_Element (Parent : Cursor) return Element_Type is
1579 begin
1580 return Element (Last_Child (Parent));
1581 end Last_Child_Element;
1582
1583 ----------
1584 -- Move --
1585 ----------
1586
1587 procedure Move (Target : in out Tree; Source : in out Tree) is
1588 Node : Tree_Node_Access;
1589
1590 begin
1591 if Target'Address = Source'Address then
1592 return;
1593 end if;
1594
1595 TC_Check (Source.TC);
1596
1597 Target.Clear; -- checks busy bit
1598
1599 Target.Root.Children := Source.Root.Children;
1600 Source.Root.Children := Children_Type'(others => null);
1601
1602 Node := Target.Root.Children.First;
1603 while Node /= null loop
1604 Node.Parent := Root_Node (Target);
1605 Node := Node.Next;
1606 end loop;
1607
1608 Target.Count := Source.Count;
1609 Source.Count := 0;
1610 end Move;
1611
1612 ----------
1613 -- Next --
1614 ----------
1615
1616 function Next
1617 (Object : Subtree_Iterator;
1618 Position : Cursor) return Cursor
1619 is
1620 Node : Tree_Node_Access;
1621
1622 begin
1623 if Position.Container = null then
1624 return No_Element;
1625 end if;
1626
1627 if Checks and then Position.Container /= Object.Container then
1628 raise Program_Error with
1629 "Position cursor of Next designates wrong tree";
1630 end if;
1631
1632 Node := Position.Node;
1633
1634 if Node.Children.First /= null then
1635 return Cursor'(Object.Container, Node.Children.First);
1636 end if;
1637
1638 while Node /= Object.Subtree loop
1639 if Node.Next /= null then
1640 return Cursor'(Object.Container, Node.Next);
1641 end if;
1642
1643 Node := Node.Parent;
1644 end loop;
1645
1646 return No_Element;
1647 end Next;
1648
1649 function Next
1650 (Object : Child_Iterator;
1651 Position : Cursor) return Cursor
1652 is
1653 begin
1654 if Position.Container = null then
1655 return No_Element;
1656 end if;
1657
1658 if Checks and then Position.Container /= Object.Container then
1659 raise Program_Error with
1660 "Position cursor of Next designates wrong tree";
1661 end if;
1662
1663 return Next_Sibling (Position);
1664 end Next;
1665
1666 ------------------
1667 -- Next_Sibling --
1668 ------------------
1669
1670 function Next_Sibling (Position : Cursor) return Cursor is
1671 begin
1672 if Position = No_Element then
1673 return No_Element;
1674 end if;
1675
1676 if Position.Node.Next = null then
1677 return No_Element;
1678 end if;
1679
1680 return Cursor'(Position.Container, Position.Node.Next);
1681 end Next_Sibling;
1682
1683 procedure Next_Sibling (Position : in out Cursor) is
1684 begin
1685 Position := Next_Sibling (Position);
1686 end Next_Sibling;
1687
1688 ----------------
1689 -- Node_Count --
1690 ----------------
1691
1692 function Node_Count (Container : Tree) return Count_Type is
1693 begin
1694 -- Container.Count is the number of nodes we have actually allocated. We
1695 -- cache the value specifically so this Node_Count operation can execute
1696 -- in O(1) time, which makes it behave similarly to how the Length
1697 -- selector function behaves for other containers.
1698 --
1699 -- The cached node count value only describes the nodes we have
1700 -- allocated; the root node itself is not included in that count. The
1701 -- Node_Count operation returns a value that includes the root node
1702 -- (because the RM says so), so we must add 1 to our cached value.
1703
1704 return 1 + Container.Count;
1705 end Node_Count;
1706
1707 ------------
1708 -- Parent --
1709 ------------
1710
1711 function Parent (Position : Cursor) return Cursor is
1712 begin
1713 if Position = No_Element then
1714 return No_Element;
1715 end if;
1716
1717 if Position.Node.Parent = null then
1718 return No_Element;
1719 end if;
1720
1721 return Cursor'(Position.Container, Position.Node.Parent);
1722 end Parent;
1723
1724 -------------------
1725 -- Prepent_Child --
1726 -------------------
1727
1728 procedure Prepend_Child
1729 (Container : in out Tree;
1730 Parent : Cursor;
1731 New_Item : Element_Type;
1732 Count : Count_Type := 1)
1733 is
1734 First, Last : Tree_Node_Access;
1735 Element : Element_Access;
1736
1737 begin
1738 if Checks and then Parent = No_Element then
1739 raise Constraint_Error with "Parent cursor has no element";
1740 end if;
1741
1742 if Checks and then Parent.Container /= Container'Unrestricted_Access then
1743 raise Program_Error with "Parent cursor not in container";
1744 end if;
1745
1746 if Count = 0 then
1747 return;
1748 end if;
1749
1750 TC_Check (Container.TC);
1751
1752 declare
1753 -- The element allocator may need an accessibility check in the case
1754 -- the actual type is class-wide or has access discriminants (see
1755 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1756 -- allocator in the loop below, because the one in this block would
1757 -- have failed already.
1758
1759 pragma Unsuppress (Accessibility_Check);
1760
1761 begin
1762 Element := new Element_Type'(New_Item);
1763 end;
1764
1765 First := new Tree_Node_Type'(Parent => Parent.Node,
1766 Element => Element,
1767 others => <>);
1768
1769 Last := First;
1770
1771 for J in Count_Type'(2) .. Count loop
1772
1773 -- Reclaim other nodes if Storage_Error. ???
1774
1775 Element := new Element_Type'(New_Item);
1776 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
1777 Prev => Last,
1778 Element => Element,
1779 others => <>);
1780
1781 Last := Last.Next;
1782 end loop;
1783
1784 Insert_Subtree_List
1785 (First => First,
1786 Last => Last,
1787 Parent => Parent.Node,
1788 Before => Parent.Node.Children.First);
1789
1790 -- In order for operation Node_Count to complete in O(1) time, we cache
1791 -- the count value. Here we increment the total count by the number of
1792 -- nodes we just inserted.
1793
1794 Container.Count := Container.Count + Count;
1795 end Prepend_Child;
1796
1797 --------------
1798 -- Previous --
1799 --------------
1800
1801 overriding function Previous
1802 (Object : Child_Iterator;
1803 Position : Cursor) return Cursor
1804 is
1805 begin
1806 if Position.Container = null then
1807 return No_Element;
1808 end if;
1809
1810 if Checks and then Position.Container /= Object.Container then
1811 raise Program_Error with
1812 "Position cursor of Previous designates wrong tree";
1813 end if;
1814
1815 return Previous_Sibling (Position);
1816 end Previous;
1817
1818 ----------------------
1819 -- Previous_Sibling --
1820 ----------------------
1821
1822 function Previous_Sibling (Position : Cursor) return Cursor is
1823 begin
1824 if Position = No_Element then
1825 return No_Element;
1826 end if;
1827
1828 if Position.Node.Prev = null then
1829 return No_Element;
1830 end if;
1831
1832 return Cursor'(Position.Container, Position.Node.Prev);
1833 end Previous_Sibling;
1834
1835 procedure Previous_Sibling (Position : in out Cursor) is
1836 begin
1837 Position := Previous_Sibling (Position);
1838 end Previous_Sibling;
1839
1840 ----------------------
1841 -- Pseudo_Reference --
1842 ----------------------
1843
1844 function Pseudo_Reference
1845 (Container : aliased Tree'Class) return Reference_Control_Type
1846 is
1847 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
1848 begin
1849 return R : constant Reference_Control_Type := (Controlled with TC) do
1850 Lock (TC.all);
1851 end return;
1852 end Pseudo_Reference;
1853
1854 -------------------
1855 -- Query_Element --
1856 -------------------
1857
1858 procedure Query_Element
1859 (Position : Cursor;
1860 Process : not null access procedure (Element : Element_Type))
1861 is
1862 T : Tree renames Position.Container.all'Unrestricted_Access.all;
1863 Lock : With_Lock (T.TC'Unrestricted_Access);
1864 begin
1865 if Checks and then Position = No_Element then
1866 raise Constraint_Error with "Position cursor has no element";
1867 end if;
1868
1869 if Checks and then Is_Root (Position) then
1870 raise Program_Error with "Position cursor designates root";
1871 end if;
1872
1873 Process (Position.Node.Element.all);
1874 end Query_Element;
1875
1876 ----------
1877 -- Read --
1878 ----------
1879
1880 procedure Read
1881 (Stream : not null access Root_Stream_Type'Class;
1882 Container : out Tree)
1883 is
1884 procedure Read_Children (Subtree : Tree_Node_Access);
1885
1886 function Read_Subtree
1887 (Parent : Tree_Node_Access) return Tree_Node_Access;
1888
1889 Total_Count : Count_Type'Base;
1890 -- Value read from the stream that says how many elements follow
1891
1892 Read_Count : Count_Type'Base;
1893 -- Actual number of elements read from the stream
1894
1895 -------------------
1896 -- Read_Children --
1897 -------------------
1898
1899 procedure Read_Children (Subtree : Tree_Node_Access) is
1900 pragma Assert (Subtree /= null);
1901 pragma Assert (Subtree.Children.First = null);
1902 pragma Assert (Subtree.Children.Last = null);
1903
1904 Count : Count_Type'Base;
1905 -- Number of child subtrees
1906
1907 C : Children_Type;
1908
1909 begin
1910 Count_Type'Read (Stream, Count);
1911
1912 if Checks and then Count < 0 then
1913 raise Program_Error with "attempt to read from corrupt stream";
1914 end if;
1915
1916 if Count = 0 then
1917 return;
1918 end if;
1919
1920 C.First := Read_Subtree (Parent => Subtree);
1921 C.Last := C.First;
1922
1923 for J in Count_Type'(2) .. Count loop
1924 C.Last.Next := Read_Subtree (Parent => Subtree);
1925 C.Last.Next.Prev := C.Last;
1926 C.Last := C.Last.Next;
1927 end loop;
1928
1929 -- Now that the allocation and reads have completed successfully, it
1930 -- is safe to link the children to their parent.
1931
1932 Subtree.Children := C;
1933 end Read_Children;
1934
1935 ------------------
1936 -- Read_Subtree --
1937 ------------------
1938
1939 function Read_Subtree
1940 (Parent : Tree_Node_Access) return Tree_Node_Access
1941 is
1942 Element : constant Element_Access :=
1943 new Element_Type'(Element_Type'Input (Stream));
1944
1945 Subtree : constant Tree_Node_Access :=
1946 new Tree_Node_Type'
1947 (Parent => Parent, Element => Element, others => <>);
1948
1949 begin
1950 Read_Count := Read_Count + 1;
1951
1952 Read_Children (Subtree);
1953
1954 return Subtree;
1955 end Read_Subtree;
1956
1957 -- Start of processing for Read
1958
1959 begin
1960 Container.Clear; -- checks busy bit
1961
1962 Count_Type'Read (Stream, Total_Count);
1963
1964 if Checks and then Total_Count < 0 then
1965 raise Program_Error with "attempt to read from corrupt stream";
1966 end if;
1967
1968 if Total_Count = 0 then
1969 return;
1970 end if;
1971
1972 Read_Count := 0;
1973
1974 Read_Children (Root_Node (Container));
1975
1976 if Checks and then Read_Count /= Total_Count then
1977 raise Program_Error with "attempt to read from corrupt stream";
1978 end if;
1979
1980 Container.Count := Total_Count;
1981 end Read;
1982
1983 procedure Read
1984 (Stream : not null access Root_Stream_Type'Class;
1985 Position : out Cursor)
1986 is
1987 begin
1988 raise Program_Error with "attempt to read tree cursor from stream";
1989 end Read;
1990
1991 procedure Read
1992 (Stream : not null access Root_Stream_Type'Class;
1993 Item : out Reference_Type)
1994 is
1995 begin
1996 raise Program_Error with "attempt to stream reference";
1997 end Read;
1998
1999 procedure Read
2000 (Stream : not null access Root_Stream_Type'Class;
2001 Item : out Constant_Reference_Type)
2002 is
2003 begin
2004 raise Program_Error with "attempt to stream reference";
2005 end Read;
2006
2007 ---------------
2008 -- Reference --
2009 ---------------
2010
2011 function Reference
2012 (Container : aliased in out Tree;
2013 Position : Cursor) return Reference_Type
2014 is
2015 begin
2016 if Checks and then Position.Container = null then
2017 raise Constraint_Error with
2018 "Position cursor has no element";
2019 end if;
2020
2021 if Checks and then Position.Container /= Container'Unrestricted_Access
2022 then
2023 raise Program_Error with
2024 "Position cursor designates wrong container";
2025 end if;
2026
2027 if Checks and then Position.Node = Root_Node (Container) then
2028 raise Program_Error with "Position cursor designates root";
2029 end if;
2030
2031 if Checks and then Position.Node.Element = null then
2032 raise Program_Error with "Node has no element";
2033 end if;
2034
2035 -- Implement Vet for multiway tree???
2036 -- pragma Assert (Vet (Position),
2037 -- "Position cursor in Constant_Reference is bad");
2038
2039 declare
2040 TC : constant Tamper_Counts_Access :=
2041 Container.TC'Unrestricted_Access;
2042 begin
2043 return R : constant Reference_Type :=
2044 (Element => Position.Node.Element.all'Access,
2045 Control => (Controlled with TC))
2046 do
2047 Lock (TC.all);
2048 end return;
2049 end;
2050 end Reference;
2051
2052 --------------------
2053 -- Remove_Subtree --
2054 --------------------
2055
2056 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
2057 C : Children_Type renames Subtree.Parent.Children;
2058
2059 begin
2060 -- This is a utility operation to remove a subtree node from its
2061 -- parent's list of children.
2062
2063 if C.First = Subtree then
2064 pragma Assert (Subtree.Prev = null);
2065
2066 if C.Last = Subtree then
2067 pragma Assert (Subtree.Next = null);
2068 C.First := null;
2069 C.Last := null;
2070
2071 else
2072 C.First := Subtree.Next;
2073 C.First.Prev := null;
2074 end if;
2075
2076 elsif C.Last = Subtree then
2077 pragma Assert (Subtree.Next = null);
2078 C.Last := Subtree.Prev;
2079 C.Last.Next := null;
2080
2081 else
2082 Subtree.Prev.Next := Subtree.Next;
2083 Subtree.Next.Prev := Subtree.Prev;
2084 end if;
2085 end Remove_Subtree;
2086
2087 ----------------------
2088 -- Replace_Element --
2089 ----------------------
2090
2091 procedure Replace_Element
2092 (Container : in out Tree;
2093 Position : Cursor;
2094 New_Item : Element_Type)
2095 is
2096 E, X : Element_Access;
2097
2098 begin
2099 if Checks and then Position = No_Element then
2100 raise Constraint_Error with "Position cursor has no element";
2101 end if;
2102
2103 if Checks and then Position.Container /= Container'Unrestricted_Access
2104 then
2105 raise Program_Error with "Position cursor not in container";
2106 end if;
2107
2108 if Checks and then Is_Root (Position) then
2109 raise Program_Error with "Position cursor designates root";
2110 end if;
2111
2112 TE_Check (Container.TC);
2113
2114 declare
2115 -- The element allocator may need an accessibility check in the case
2116 -- the actual type is class-wide or has access discriminants (see
2117 -- RM 4.8(10.1) and AI12-0035).
2118
2119 pragma Unsuppress (Accessibility_Check);
2120
2121 begin
2122 E := new Element_Type'(New_Item);
2123 end;
2124
2125 X := Position.Node.Element;
2126 Position.Node.Element := E;
2127
2128 Free_Element (X);
2129 end Replace_Element;
2130
2131 ------------------------------
2132 -- Reverse_Iterate_Children --
2133 ------------------------------
2134
2135 procedure Reverse_Iterate_Children
2136 (Parent : Cursor;
2137 Process : not null access procedure (Position : Cursor))
2138 is
2139 C : Tree_Node_Access;
2140 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
2141 begin
2142 if Checks and then Parent = No_Element then
2143 raise Constraint_Error with "Parent cursor has no element";
2144 end if;
2145
2146 C := Parent.Node.Children.Last;
2147 while C /= null loop
2148 Process (Position => Cursor'(Parent.Container, Node => C));
2149 C := C.Prev;
2150 end loop;
2151 end Reverse_Iterate_Children;
2152
2153 ----------
2154 -- Root --
2155 ----------
2156
2157 function Root (Container : Tree) return Cursor is
2158 begin
2159 return (Container'Unrestricted_Access, Root_Node (Container));
2160 end Root;
2161
2162 ---------------
2163 -- Root_Node --
2164 ---------------
2165
2166 function Root_Node (Container : Tree) return Tree_Node_Access is
2167 begin
2168 return Container.Root'Unrestricted_Access;
2169 end Root_Node;
2170
2171 ---------------------
2172 -- Splice_Children --
2173 ---------------------
2174
2175 procedure Splice_Children
2176 (Target : in out Tree;
2177 Target_Parent : Cursor;
2178 Before : Cursor;
2179 Source : in out Tree;
2180 Source_Parent : Cursor)
2181 is
2182 Count : Count_Type;
2183
2184 begin
2185 if Checks and then Target_Parent = No_Element then
2186 raise Constraint_Error with "Target_Parent cursor has no element";
2187 end if;
2188
2189 if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
2190 then
2191 raise Program_Error
2192 with "Target_Parent cursor not in Target container";
2193 end if;
2194
2195 if Before /= No_Element then
2196 if Checks and then Before.Container /= Target'Unrestricted_Access then
2197 raise Program_Error
2198 with "Before cursor not in Target container";
2199 end if;
2200
2201 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2202 raise Constraint_Error
2203 with "Before cursor not child of Target_Parent";
2204 end if;
2205 end if;
2206
2207 if Checks and then Source_Parent = No_Element then
2208 raise Constraint_Error with "Source_Parent cursor has no element";
2209 end if;
2210
2211 if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
2212 then
2213 raise Program_Error
2214 with "Source_Parent cursor not in Source container";
2215 end if;
2216
2217 if Target'Address = Source'Address then
2218 if Target_Parent = Source_Parent then
2219 return;
2220 end if;
2221
2222 TC_Check (Target.TC);
2223
2224 if Checks and then Is_Reachable (From => Target_Parent.Node,
2225 To => Source_Parent.Node)
2226 then
2227 raise Constraint_Error
2228 with "Source_Parent is ancestor of Target_Parent";
2229 end if;
2230
2231 Splice_Children
2232 (Target_Parent => Target_Parent.Node,
2233 Before => Before.Node,
2234 Source_Parent => Source_Parent.Node);
2235
2236 return;
2237 end if;
2238
2239 TC_Check (Target.TC);
2240 TC_Check (Source.TC);
2241
2242 -- We cache the count of the nodes we have allocated, so that operation
2243 -- Node_Count can execute in O(1) time. But that means we must count the
2244 -- nodes in the subtree we remove from Source and insert into Target, in
2245 -- order to keep the count accurate.
2246
2247 Count := Subtree_Node_Count (Source_Parent.Node);
2248 pragma Assert (Count >= 1);
2249
2250 Count := Count - 1; -- because Source_Parent node does not move
2251
2252 Splice_Children
2253 (Target_Parent => Target_Parent.Node,
2254 Before => Before.Node,
2255 Source_Parent => Source_Parent.Node);
2256
2257 Source.Count := Source.Count - Count;
2258 Target.Count := Target.Count + Count;
2259 end Splice_Children;
2260
2261 procedure Splice_Children
2262 (Container : in out Tree;
2263 Target_Parent : Cursor;
2264 Before : Cursor;
2265 Source_Parent : Cursor)
2266 is
2267 begin
2268 if Checks and then Target_Parent = No_Element then
2269 raise Constraint_Error with "Target_Parent cursor has no element";
2270 end if;
2271
2272 if Checks and then
2273 Target_Parent.Container /= Container'Unrestricted_Access
2274 then
2275 raise Program_Error
2276 with "Target_Parent cursor not in container";
2277 end if;
2278
2279 if Before /= No_Element then
2280 if Checks and then Before.Container /= Container'Unrestricted_Access
2281 then
2282 raise Program_Error
2283 with "Before cursor not in container";
2284 end if;
2285
2286 if Checks and then Before.Node.Parent /= Target_Parent.Node then
2287 raise Constraint_Error
2288 with "Before cursor not child of Target_Parent";
2289 end if;
2290 end if;
2291
2292 if Checks and then Source_Parent = No_Element then
2293 raise Constraint_Error with "Source_Parent cursor has no element";
2294 end if;
2295
2296 if Checks and then
2297 Source_Parent.Container /= Container'Unrestricted_Access
2298 then
2299 raise Program_Error
2300 with "Source_Parent cursor not in container";
2301 end if;
2302
2303 if Target_Parent = Source_Parent then
2304 return;
2305 end if;
2306
2307 TC_Check (Container.TC);
2308
2309 if Checks and then Is_Reachable (From => Target_Parent.Node,
2310 To => Source_Parent.Node)
2311 then
2312 raise Constraint_Error
2313 with "Source_Parent is ancestor of Target_Parent";
2314 end if;
2315
2316 Splice_Children
2317 (Target_Parent => Target_Parent.Node,
2318 Before => Before.Node,
2319 Source_Parent => Source_Parent.Node);
2320 end Splice_Children;
2321
2322 procedure Splice_Children
2323 (Target_Parent : Tree_Node_Access;
2324 Before : Tree_Node_Access;
2325 Source_Parent : Tree_Node_Access)
2326 is
2327 CC : constant Children_Type := Source_Parent.Children;
2328 C : Tree_Node_Access;
2329
2330 begin
2331 -- This is a utility operation to remove the children from Source parent
2332 -- and insert them into Target parent.
2333
2334 Source_Parent.Children := Children_Type'(others => null);
2335
2336 -- Fix up the Parent pointers of each child to designate its new Target
2337 -- parent.
2338
2339 C := CC.First;
2340 while C /= null loop
2341 C.Parent := Target_Parent;
2342 C := C.Next;
2343 end loop;
2344
2345 Insert_Subtree_List
2346 (First => CC.First,
2347 Last => CC.Last,
2348 Parent => Target_Parent,
2349 Before => Before);
2350 end Splice_Children;
2351
2352 --------------------
2353 -- Splice_Subtree --
2354 --------------------
2355
2356 procedure Splice_Subtree
2357 (Target : in out Tree;
2358 Parent : Cursor;
2359 Before : Cursor;
2360 Source : in out Tree;
2361 Position : in out Cursor)
2362 is
2363 Subtree_Count : Count_Type;
2364
2365 begin
2366 if Checks and then Parent = No_Element then
2367 raise Constraint_Error with "Parent cursor has no element";
2368 end if;
2369
2370 if Checks and then Parent.Container /= Target'Unrestricted_Access then
2371 raise Program_Error with "Parent cursor not in Target container";
2372 end if;
2373
2374 if Before /= No_Element then
2375 if Checks and then Before.Container /= Target'Unrestricted_Access then
2376 raise Program_Error with "Before cursor not in Target container";
2377 end if;
2378
2379 if Checks and then Before.Node.Parent /= Parent.Node then
2380 raise Constraint_Error with "Before cursor not child of Parent";
2381 end if;
2382 end if;
2383
2384 if Checks and then Position = No_Element then
2385 raise Constraint_Error with "Position cursor has no element";
2386 end if;
2387
2388 if Checks and then Position.Container /= Source'Unrestricted_Access then
2389 raise Program_Error with "Position cursor not in Source container";
2390 end if;
2391
2392 if Checks and then Is_Root (Position) then
2393 raise Program_Error with "Position cursor designates root";
2394 end if;
2395
2396 if Target'Address = Source'Address then
2397 if Position.Node.Parent = Parent.Node then
2398 if Position.Node = Before.Node then
2399 return;
2400 end if;
2401
2402 if Position.Node.Next = Before.Node then
2403 return;
2404 end if;
2405 end if;
2406
2407 TC_Check (Target.TC);
2408
2409 if Checks and then
2410 Is_Reachable (From => Parent.Node, To => Position.Node)
2411 then
2412 raise Constraint_Error with "Position is ancestor of Parent";
2413 end if;
2414
2415 Remove_Subtree (Position.Node);
2416
2417 Position.Node.Parent := Parent.Node;
2418 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2419
2420 return;
2421 end if;
2422
2423 TC_Check (Target.TC);
2424 TC_Check (Source.TC);
2425
2426 -- This is an unfortunate feature of this API: we must count the nodes
2427 -- in the subtree that we remove from the source tree, which is an O(n)
2428 -- operation. It would have been better if the Tree container did not
2429 -- have a Node_Count selector; a user that wants the number of nodes in
2430 -- the tree could simply call Subtree_Node_Count, with the understanding
2431 -- that such an operation is O(n).
2432 --
2433 -- Of course, we could choose to implement the Node_Count selector as an
2434 -- O(n) operation, which would turn this splice operation into an O(1)
2435 -- operation. ???
2436
2437 Subtree_Count := Subtree_Node_Count (Position.Node);
2438 pragma Assert (Subtree_Count <= Source.Count);
2439
2440 Remove_Subtree (Position.Node);
2441 Source.Count := Source.Count - Subtree_Count;
2442
2443 Position.Node.Parent := Parent.Node;
2444 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2445
2446 Target.Count := Target.Count + Subtree_Count;
2447
2448 Position.Container := Target'Unrestricted_Access;
2449 end Splice_Subtree;
2450
2451 procedure Splice_Subtree
2452 (Container : in out Tree;
2453 Parent : Cursor;
2454 Before : Cursor;
2455 Position : Cursor)
2456 is
2457 begin
2458 if Checks and then Parent = No_Element then
2459 raise Constraint_Error with "Parent cursor has no element";
2460 end if;
2461
2462 if Checks and then Parent.Container /= Container'Unrestricted_Access then
2463 raise Program_Error with "Parent cursor not in container";
2464 end if;
2465
2466 if Before /= No_Element then
2467 if Checks and then Before.Container /= Container'Unrestricted_Access
2468 then
2469 raise Program_Error with "Before cursor not in container";
2470 end if;
2471
2472 if Checks and then Before.Node.Parent /= Parent.Node then
2473 raise Constraint_Error with "Before cursor not child of Parent";
2474 end if;
2475 end if;
2476
2477 if Checks and then Position = No_Element then
2478 raise Constraint_Error with "Position cursor has no element";
2479 end if;
2480
2481 if Checks and then Position.Container /= Container'Unrestricted_Access
2482 then
2483 raise Program_Error with "Position cursor not in container";
2484 end if;
2485
2486 if Checks and then Is_Root (Position) then
2487
2488 -- Should this be PE instead? Need ARG confirmation. ???
2489
2490 raise Constraint_Error with "Position cursor designates root";
2491 end if;
2492
2493 if Position.Node.Parent = Parent.Node then
2494 if Position.Node = Before.Node then
2495 return;
2496 end if;
2497
2498 if Position.Node.Next = Before.Node then
2499 return;
2500 end if;
2501 end if;
2502
2503 TC_Check (Container.TC);
2504
2505 if Checks and then
2506 Is_Reachable (From => Parent.Node, To => Position.Node)
2507 then
2508 raise Constraint_Error with "Position is ancestor of Parent";
2509 end if;
2510
2511 Remove_Subtree (Position.Node);
2512
2513 Position.Node.Parent := Parent.Node;
2514 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
2515 end Splice_Subtree;
2516
2517 ------------------------
2518 -- Subtree_Node_Count --
2519 ------------------------
2520
2521 function Subtree_Node_Count (Position : Cursor) return Count_Type is
2522 begin
2523 if Position = No_Element then
2524 return 0;
2525 end if;
2526
2527 return Subtree_Node_Count (Position.Node);
2528 end Subtree_Node_Count;
2529
2530 function Subtree_Node_Count
2531 (Subtree : Tree_Node_Access) return Count_Type
2532 is
2533 Result : Count_Type;
2534 Node : Tree_Node_Access;
2535
2536 begin
2537 Result := 1;
2538 Node := Subtree.Children.First;
2539 while Node /= null loop
2540 Result := Result + Subtree_Node_Count (Node);
2541 Node := Node.Next;
2542 end loop;
2543
2544 return Result;
2545 end Subtree_Node_Count;
2546
2547 ----------
2548 -- Swap --
2549 ----------
2550
2551 procedure Swap
2552 (Container : in out Tree;
2553 I, J : Cursor)
2554 is
2555 begin
2556 if Checks and then I = No_Element then
2557 raise Constraint_Error with "I cursor has no element";
2558 end if;
2559
2560 if Checks and then I.Container /= Container'Unrestricted_Access then
2561 raise Program_Error with "I cursor not in container";
2562 end if;
2563
2564 if Checks and then Is_Root (I) then
2565 raise Program_Error with "I cursor designates root";
2566 end if;
2567
2568 if I = J then -- make this test sooner???
2569 return;
2570 end if;
2571
2572 if Checks and then J = No_Element then
2573 raise Constraint_Error with "J cursor has no element";
2574 end if;
2575
2576 if Checks and then J.Container /= Container'Unrestricted_Access then
2577 raise Program_Error with "J cursor not in container";
2578 end if;
2579
2580 if Checks and then Is_Root (J) then
2581 raise Program_Error with "J cursor designates root";
2582 end if;
2583
2584 TE_Check (Container.TC);
2585
2586 declare
2587 EI : constant Element_Access := I.Node.Element;
2588
2589 begin
2590 I.Node.Element := J.Node.Element;
2591 J.Node.Element := EI;
2592 end;
2593 end Swap;
2594
2595 --------------------
2596 -- Update_Element --
2597 --------------------
2598
2599 procedure Update_Element
2600 (Container : in out Tree;
2601 Position : Cursor;
2602 Process : not null access procedure (Element : in out Element_Type))
2603 is
2604 T : Tree renames Position.Container.all'Unrestricted_Access.all;
2605 Lock : With_Lock (T.TC'Unrestricted_Access);
2606 begin
2607 if Checks and then Position = No_Element then
2608 raise Constraint_Error with "Position cursor has no element";
2609 end if;
2610
2611 if Checks and then Position.Container /= Container'Unrestricted_Access
2612 then
2613 raise Program_Error with "Position cursor not in container";
2614 end if;
2615
2616 if Checks and then Is_Root (Position) then
2617 raise Program_Error with "Position cursor designates root";
2618 end if;
2619
2620 Process (Position.Node.Element.all);
2621 end Update_Element;
2622
2623 -----------
2624 -- Write --
2625 -----------
2626
2627 procedure Write
2628 (Stream : not null access Root_Stream_Type'Class;
2629 Container : Tree)
2630 is
2631 procedure Write_Children (Subtree : Tree_Node_Access);
2632 procedure Write_Subtree (Subtree : Tree_Node_Access);
2633
2634 --------------------
2635 -- Write_Children --
2636 --------------------
2637
2638 procedure Write_Children (Subtree : Tree_Node_Access) is
2639 CC : Children_Type renames Subtree.Children;
2640 C : Tree_Node_Access;
2641
2642 begin
2643 Count_Type'Write (Stream, Child_Count (CC));
2644
2645 C := CC.First;
2646 while C /= null loop
2647 Write_Subtree (C);
2648 C := C.Next;
2649 end loop;
2650 end Write_Children;
2651
2652 -------------------
2653 -- Write_Subtree --
2654 -------------------
2655
2656 procedure Write_Subtree (Subtree : Tree_Node_Access) is
2657 begin
2658 Element_Type'Output (Stream, Subtree.Element.all);
2659 Write_Children (Subtree);
2660 end Write_Subtree;
2661
2662 -- Start of processing for Write
2663
2664 begin
2665 Count_Type'Write (Stream, Container.Count);
2666
2667 if Container.Count = 0 then
2668 return;
2669 end if;
2670
2671 Write_Children (Root_Node (Container));
2672 end Write;
2673
2674 procedure Write
2675 (Stream : not null access Root_Stream_Type'Class;
2676 Position : Cursor)
2677 is
2678 begin
2679 raise Program_Error with "attempt to write tree cursor to stream";
2680 end Write;
2681
2682 procedure Write
2683 (Stream : not null access Root_Stream_Type'Class;
2684 Item : Reference_Type)
2685 is
2686 begin
2687 raise Program_Error with "attempt to stream reference";
2688 end Write;
2689
2690 procedure Write
2691 (Stream : not null access Root_Stream_Type'Class;
2692 Item : Constant_Reference_Type)
2693 is
2694 begin
2695 raise Program_Error with "attempt to stream reference";
2696 end Write;
2697
2698 end Ada.Containers.Indefinite_Multiway_Trees;