1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--                   ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--             Copyright (C) 2011-2019, 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-- 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.               --
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
30with Ada.Finalization;
31with System; use type System.Address;
32
33package body Ada.Containers.Bounded_Multiway_Trees is
34
35   pragma Warnings (Off, "variable ""Busy*"" is not referenced");
36   pragma Warnings (Off, "variable ""Lock*"" is not referenced");
37   --  See comment in Ada.Containers.Helpers
38
39   use Finalization;
40
41   --------------------
42   --  Root_Iterator --
43   --------------------
44
45   type Root_Iterator is abstract new Limited_Controlled and
46     Tree_Iterator_Interfaces.Forward_Iterator with
47   record
48      Container : Tree_Access;
49      Subtree   : Count_Type;
50   end record;
51
52   overriding procedure Finalize (Object : in out Root_Iterator);
53
54   -----------------------
55   --  Subtree_Iterator --
56   -----------------------
57
58   type Subtree_Iterator is new Root_Iterator with null record;
59
60   overriding function First (Object : Subtree_Iterator) return Cursor;
61
62   overriding function Next
63     (Object   : Subtree_Iterator;
64      Position : Cursor) return Cursor;
65
66   ---------------------
67   --  Child_Iterator --
68   ---------------------
69
70   type Child_Iterator is new Root_Iterator and
71     Tree_Iterator_Interfaces.Reversible_Iterator with null record;
72
73   overriding function First (Object : Child_Iterator) return Cursor;
74
75   overriding function Next
76     (Object   : Child_Iterator;
77      Position : Cursor) return Cursor;
78
79   overriding function Last (Object : Child_Iterator) return Cursor;
80
81   overriding function Previous
82     (Object   : Child_Iterator;
83      Position : Cursor) return Cursor;
84
85   -----------------------
86   -- Local Subprograms --
87   -----------------------
88
89   procedure Initialize_Node (Container : in out Tree; Index : Count_Type);
90   procedure Initialize_Root (Container : in out Tree);
91
92   procedure Allocate_Node
93     (Container          : in out Tree;
94      Initialize_Element : not null access procedure (Index : Count_Type);
95      New_Node           : out Count_Type);
96
97   procedure Allocate_Node
98     (Container : in out Tree;
99      New_Item  : Element_Type;
100      New_Node  : out Count_Type);
101
102   procedure Allocate_Node
103     (Container : in out Tree;
104      Stream    : not null access Root_Stream_Type'Class;
105      New_Node  : out Count_Type);
106
107   procedure Deallocate_Node
108     (Container : in out Tree;
109      X         : Count_Type);
110
111   procedure Deallocate_Children
112     (Container : in out Tree;
113      Subtree   : Count_Type;
114      Count     : in out Count_Type);
115
116   procedure Deallocate_Subtree
117     (Container : in out Tree;
118      Subtree   : Count_Type;
119      Count     : in out Count_Type);
120
121   function Equal_Children
122     (Left_Tree     : Tree;
123      Left_Subtree  : Count_Type;
124      Right_Tree    : Tree;
125      Right_Subtree : Count_Type) return Boolean;
126
127   function Equal_Subtree
128     (Left_Tree     : Tree;
129      Left_Subtree  : Count_Type;
130      Right_Tree    : Tree;
131      Right_Subtree : Count_Type) return Boolean;
132
133   procedure Iterate_Children
134     (Container : Tree;
135      Subtree   : Count_Type;
136      Process   : not null access procedure (Position : Cursor));
137
138   procedure Iterate_Subtree
139     (Container : Tree;
140      Subtree   : Count_Type;
141      Process   : not null access procedure (Position : Cursor));
142
143   procedure Copy_Children
144     (Source        : Tree;
145      Source_Parent : Count_Type;
146      Target        : in out Tree;
147      Target_Parent : Count_Type;
148      Count         : in out Count_Type);
149
150   procedure Copy_Subtree
151     (Source         : Tree;
152      Source_Subtree : Count_Type;
153      Target         : in out Tree;
154      Target_Parent  : Count_Type;
155      Target_Subtree : out Count_Type;
156      Count          : in out Count_Type);
157
158   function Find_In_Children
159     (Container : Tree;
160      Subtree   : Count_Type;
161      Item      : Element_Type) return Count_Type;
162
163   function Find_In_Subtree
164     (Container : Tree;
165      Subtree   : Count_Type;
166      Item      : Element_Type) return Count_Type;
167
168   function Child_Count
169     (Container : Tree;
170      Parent    : Count_Type) return Count_Type;
171
172   function Subtree_Node_Count
173     (Container : Tree;
174      Subtree   : Count_Type) return Count_Type;
175
176   function Is_Reachable
177     (Container : Tree;
178      From, To  : Count_Type) return Boolean;
179
180   function Root_Node (Container : Tree) return Count_Type;
181
182   procedure Remove_Subtree
183     (Container : in out Tree;
184      Subtree   : Count_Type);
185
186   procedure Insert_Subtree_Node
187     (Container : in out Tree;
188      Subtree   : Count_Type'Base;
189      Parent    : Count_Type;
190      Before    : Count_Type'Base);
191
192   procedure Insert_Subtree_List
193     (Container : in out Tree;
194      First     : Count_Type'Base;
195      Last      : Count_Type'Base;
196      Parent    : Count_Type;
197      Before    : Count_Type'Base);
198
199   procedure Splice_Children
200     (Container     : in out Tree;
201      Target_Parent : Count_Type;
202      Before        : Count_Type'Base;
203      Source_Parent : Count_Type);
204
205   procedure Splice_Children
206     (Target        : in out Tree;
207      Target_Parent : Count_Type;
208      Before        : Count_Type'Base;
209      Source        : in out Tree;
210      Source_Parent : Count_Type);
211
212   procedure Splice_Subtree
213     (Target   : in out Tree;
214      Parent   : Count_Type;
215      Before   : Count_Type'Base;
216      Source   : in out Tree;
217      Position : in out Count_Type);  -- source on input, target on output
218
219   ---------
220   -- "=" --
221   ---------
222
223   function "=" (Left, Right : Tree) return Boolean is
224   begin
225      if Left.Count /= Right.Count then
226         return False;
227      end if;
228
229      if Left.Count = 0 then
230         return True;
231      end if;
232
233      return Equal_Children
234               (Left_Tree     => Left,
235                Left_Subtree  => Root_Node (Left),
236                Right_Tree    => Right,
237                Right_Subtree => Root_Node (Right));
238   end "=";
239
240   -------------------
241   -- Allocate_Node --
242   -------------------
243
244   procedure Allocate_Node
245     (Container          : in out Tree;
246      Initialize_Element : not null access procedure (Index : Count_Type);
247      New_Node           : out Count_Type)
248   is
249   begin
250      if Container.Free >= 0 then
251         New_Node := Container.Free;
252         pragma Assert (New_Node in Container.Elements'Range);
253
254         --  We always perform the assignment first, before we change container
255         --  state, in order to defend against exceptions duration assignment.
256
257         Initialize_Element (New_Node);
258
259         Container.Free := Container.Nodes (New_Node).Next;
260
261      else
262         --  A negative free store value means that the links of the nodes in
263         --  the free store have not been initialized. In this case, the nodes
264         --  are physically contiguous in the array, starting at the index that
265         --  is the absolute value of the Container.Free, and continuing until
266         --  the end of the array (Nodes'Last).
267
268         New_Node := abs Container.Free;
269         pragma Assert (New_Node in Container.Elements'Range);
270
271         --  As above, we perform this assignment first, before modifying any
272         --  container state.
273
274         Initialize_Element (New_Node);
275
276         Container.Free := Container.Free - 1;
277
278         if abs Container.Free > Container.Capacity then
279            Container.Free := 0;
280         end if;
281      end if;
282
283      Initialize_Node (Container, New_Node);
284   end Allocate_Node;
285
286   procedure Allocate_Node
287     (Container : in out Tree;
288      New_Item  : Element_Type;
289      New_Node  : out Count_Type)
290   is
291      procedure Initialize_Element (Index : Count_Type);
292
293      procedure Initialize_Element (Index : Count_Type) is
294      begin
295         Container.Elements (Index) := New_Item;
296      end Initialize_Element;
297
298   begin
299      Allocate_Node (Container, Initialize_Element'Access, New_Node);
300   end Allocate_Node;
301
302   procedure Allocate_Node
303     (Container : in out Tree;
304      Stream    : not null access Root_Stream_Type'Class;
305      New_Node  : out Count_Type)
306   is
307      procedure Initialize_Element (Index : Count_Type);
308
309      procedure Initialize_Element (Index : Count_Type) is
310      begin
311         Element_Type'Read (Stream, Container.Elements (Index));
312      end Initialize_Element;
313
314   begin
315      Allocate_Node (Container, Initialize_Element'Access, New_Node);
316   end Allocate_Node;
317
318   -------------------
319   -- Ancestor_Find --
320   -------------------
321
322   function Ancestor_Find
323     (Position : Cursor;
324      Item     : Element_Type) return Cursor
325   is
326      R, N : Count_Type;
327
328   begin
329      if Checks and then Position = No_Element then
330         raise Constraint_Error with "Position cursor has no element";
331      end if;
332
333      --  AI-0136 says to raise PE if Position equals the root node. This does
334      --  not seem correct, as this value is just the limiting condition of the
335      --  search. For now we omit this check, pending a ruling from the ARG.
336      --  ???
337      --
338      --  if Checks and then Is_Root (Position) then
339      --     raise Program_Error with "Position cursor designates root";
340      --  end if;
341
342      R := Root_Node (Position.Container.all);
343      N := Position.Node;
344      while N /= R loop
345         if Position.Container.Elements (N) = Item then
346            return Cursor'(Position.Container, N);
347         end if;
348
349         N := Position.Container.Nodes (N).Parent;
350      end loop;
351
352      return No_Element;
353   end Ancestor_Find;
354
355   ------------------
356   -- Append_Child --
357   ------------------
358
359   procedure Append_Child
360     (Container : in out Tree;
361      Parent    : Cursor;
362      New_Item  : Element_Type;
363      Count     : Count_Type := 1)
364   is
365      Nodes       : Tree_Node_Array renames Container.Nodes;
366      First, Last : Count_Type;
367
368   begin
369      if Checks and then Parent = No_Element then
370         raise Constraint_Error with "Parent cursor has no element";
371      end if;
372
373      if Checks and then Parent.Container /= Container'Unrestricted_Access then
374         raise Program_Error with "Parent cursor not in container";
375      end if;
376
377      if Count = 0 then
378         return;
379      end if;
380
381      if Checks and then Container.Count > Container.Capacity - Count then
382         raise Capacity_Error
383           with "requested count exceeds available storage";
384      end if;
385
386      TC_Check (Container.TC);
387
388      if Container.Count = 0 then
389         Initialize_Root (Container);
390      end if;
391
392      Allocate_Node (Container, New_Item, First);
393      Nodes (First).Parent := Parent.Node;
394
395      Last := First;
396      for J in Count_Type'(2) .. Count loop
397         Allocate_Node (Container, New_Item, Nodes (Last).Next);
398         Nodes (Nodes (Last).Next).Parent := Parent.Node;
399         Nodes (Nodes (Last).Next).Prev := Last;
400
401         Last := Nodes (Last).Next;
402      end loop;
403
404      Insert_Subtree_List
405        (Container => Container,
406         First     => First,
407         Last      => Last,
408         Parent    => Parent.Node,
409         Before    => No_Node);  -- means "insert at end of list"
410
411      Container.Count := Container.Count + Count;
412   end Append_Child;
413
414   ------------
415   -- Assign --
416   ------------
417
418   procedure Assign (Target : in out Tree; Source : Tree) is
419      Target_Count : Count_Type;
420
421   begin
422      if Target'Address = Source'Address then
423         return;
424      end if;
425
426      if Checks and then Target.Capacity < Source.Count then
427         raise Capacity_Error  -- ???
428           with "Target capacity is less than Source count";
429      end if;
430
431      Target.Clear;  -- Checks busy bit
432
433      if Source.Count = 0 then
434         return;
435      end if;
436
437      Initialize_Root (Target);
438
439      --  Copy_Children returns the number of nodes that it allocates, but it
440      --  does this by incrementing the count value passed in, so we must
441      --  initialize the count before calling Copy_Children.
442
443      Target_Count := 0;
444
445      Copy_Children
446        (Source        => Source,
447         Source_Parent => Root_Node (Source),
448         Target        => Target,
449         Target_Parent => Root_Node (Target),
450         Count         => Target_Count);
451
452      pragma Assert (Target_Count = Source.Count);
453      Target.Count := Source.Count;
454   end Assign;
455
456   -----------------
457   -- Child_Count --
458   -----------------
459
460   function Child_Count (Parent : Cursor) return Count_Type is
461   begin
462      if Parent = No_Element then
463         return 0;
464
465      elsif Parent.Container.Count = 0 then
466         pragma Assert (Is_Root (Parent));
467         return 0;
468
469      else
470         return Child_Count (Parent.Container.all, Parent.Node);
471      end if;
472   end Child_Count;
473
474   function Child_Count
475     (Container : Tree;
476      Parent    : Count_Type) return Count_Type
477   is
478      NN : Tree_Node_Array renames Container.Nodes;
479      CC : Children_Type renames NN (Parent).Children;
480
481      Result : Count_Type;
482      Node   : Count_Type'Base;
483
484   begin
485      Result := 0;
486      Node := CC.First;
487      while Node > 0 loop
488         Result := Result + 1;
489         Node := NN (Node).Next;
490      end loop;
491
492      return Result;
493   end Child_Count;
494
495   -----------------
496   -- Child_Depth --
497   -----------------
498
499   function Child_Depth (Parent, Child : Cursor) return Count_Type is
500      Result : Count_Type;
501      N      : Count_Type'Base;
502
503   begin
504      if Checks and then Parent = No_Element then
505         raise Constraint_Error with "Parent cursor has no element";
506      end if;
507
508      if Checks and then Child = No_Element then
509         raise Constraint_Error with "Child cursor has no element";
510      end if;
511
512      if Checks and then Parent.Container /= Child.Container then
513         raise Program_Error with "Parent and Child in different containers";
514      end if;
515
516      if Parent.Container.Count = 0 then
517         pragma Assert (Is_Root (Parent));
518         pragma Assert (Child = Parent);
519         return 0;
520      end if;
521
522      Result := 0;
523      N := Child.Node;
524      while N /= Parent.Node loop
525         Result := Result + 1;
526         N := Parent.Container.Nodes (N).Parent;
527
528         if Checks and then N < 0 then
529            raise Program_Error with "Parent is not ancestor of Child";
530         end if;
531      end loop;
532
533      return Result;
534   end Child_Depth;
535
536   -----------
537   -- Clear --
538   -----------
539
540   procedure Clear (Container : in out Tree) is
541      Container_Count : constant Count_Type := Container.Count;
542      Count           : Count_Type;
543
544   begin
545      TC_Check (Container.TC);
546
547      if Container_Count = 0 then
548         return;
549      end if;
550
551      Container.Count := 0;
552
553      --  Deallocate_Children returns the number of nodes that it deallocates,
554      --  but it does this by incrementing the count value that is passed in,
555      --  so we must first initialize the count return value before calling it.
556
557      Count := 0;
558
559      Deallocate_Children
560        (Container => Container,
561         Subtree   => Root_Node (Container),
562         Count     => Count);
563
564      pragma Assert (Count = Container_Count);
565   end Clear;
566
567   ------------------------
568   -- Constant_Reference --
569   ------------------------
570
571   function Constant_Reference
572     (Container : aliased Tree;
573      Position  : Cursor) return Constant_Reference_Type
574   is
575   begin
576      if Checks and then Position.Container = null then
577         raise Constraint_Error with
578           "Position cursor has no element";
579      end if;
580
581      if Checks and then Position.Container /= Container'Unrestricted_Access
582      then
583         raise Program_Error with
584           "Position cursor designates wrong container";
585      end if;
586
587      if Checks and then Position.Node = Root_Node (Container) then
588         raise Program_Error with "Position cursor designates root";
589      end if;
590
591      --  Implement Vet for multiway tree???
592      --  pragma Assert (Vet (Position),
593      --                 "Position cursor in Constant_Reference is bad");
594
595      declare
596         TC : constant Tamper_Counts_Access :=
597           Container.TC'Unrestricted_Access;
598      begin
599         return R : constant Constant_Reference_Type :=
600           (Element => Container.Elements (Position.Node)'Access,
601            Control => (Controlled with TC))
602         do
603            Lock (TC.all);
604         end return;
605      end;
606   end Constant_Reference;
607
608   --------------
609   -- Contains --
610   --------------
611
612   function Contains
613     (Container : Tree;
614      Item      : Element_Type) return Boolean
615   is
616   begin
617      return Find (Container, Item) /= No_Element;
618   end Contains;
619
620   ----------
621   -- Copy --
622   ----------
623
624   function Copy
625     (Source   : Tree;
626      Capacity : Count_Type := 0) return Tree
627   is
628      C : Count_Type;
629
630   begin
631      if Capacity = 0 then
632         C := Source.Count;
633      elsif Capacity >= Source.Count then
634         C := Capacity;
635      elsif Checks then
636         raise Capacity_Error with "Capacity value too small";
637      end if;
638
639      return Target : Tree (Capacity => C) do
640         Initialize_Root (Target);
641
642         if Source.Count = 0 then
643            return;
644         end if;
645
646         Copy_Children
647           (Source        => Source,
648            Source_Parent => Root_Node (Source),
649            Target        => Target,
650            Target_Parent => Root_Node (Target),
651            Count         => Target.Count);
652
653         pragma Assert (Target.Count = Source.Count);
654      end return;
655   end Copy;
656
657   -------------------
658   -- Copy_Children --
659   -------------------
660
661   procedure Copy_Children
662     (Source        : Tree;
663      Source_Parent : Count_Type;
664      Target        : in out Tree;
665      Target_Parent : Count_Type;
666      Count         : in out Count_Type)
667   is
668      S_Nodes : Tree_Node_Array renames Source.Nodes;
669      S_Node  : Tree_Node_Type renames S_Nodes (Source_Parent);
670
671      T_Nodes : Tree_Node_Array renames Target.Nodes;
672      T_Node  : Tree_Node_Type renames T_Nodes (Target_Parent);
673
674      pragma Assert (T_Node.Children.First <= 0);
675      pragma Assert (T_Node.Children.Last <= 0);
676
677      T_CC : Children_Type;
678      C    : Count_Type'Base;
679
680   begin
681      --  We special-case the first allocation, in order to establish the
682      --  representation invariants for type Children_Type.
683
684      C := S_Node.Children.First;
685
686      if C <= 0 then  -- source parent has no children
687         return;
688      end if;
689
690      Copy_Subtree
691        (Source         => Source,
692         Source_Subtree => C,
693         Target         => Target,
694         Target_Parent  => Target_Parent,
695         Target_Subtree => T_CC.First,
696         Count          => Count);
697
698      T_CC.Last := T_CC.First;
699
700      --  The representation invariants for the Children_Type list have been
701      --  established, so we can now copy the remaining children of Source.
702
703      C := S_Nodes (C).Next;
704      while C > 0 loop
705         Copy_Subtree
706           (Source         => Source,
707            Source_Subtree => C,
708            Target         => Target,
709            Target_Parent  => Target_Parent,
710            Target_Subtree => T_Nodes (T_CC.Last).Next,
711            Count          => Count);
712
713         T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last;
714         T_CC.Last := T_Nodes (T_CC.Last).Next;
715
716         C := S_Nodes (C).Next;
717      end loop;
718
719      --  We add the newly-allocated children to their parent list only after
720      --  the allocation has succeeded, in order to preserve invariants of the
721      --  parent.
722
723      T_Node.Children := T_CC;
724   end Copy_Children;
725
726   ------------------
727   -- Copy_Subtree --
728   ------------------
729
730   procedure Copy_Subtree
731     (Target   : in out Tree;
732      Parent   : Cursor;
733      Before   : Cursor;
734      Source   : Cursor)
735   is
736      Target_Subtree : Count_Type;
737      Target_Count   : Count_Type;
738
739   begin
740      if Checks and then Parent = No_Element then
741         raise Constraint_Error with "Parent cursor has no element";
742      end if;
743
744      if Checks and then Parent.Container /= Target'Unrestricted_Access then
745         raise Program_Error with "Parent cursor not in container";
746      end if;
747
748      if Before /= No_Element then
749         if Checks and then Before.Container /= Target'Unrestricted_Access then
750            raise Program_Error with "Before cursor not in container";
751         end if;
752
753         if Checks and then
754           Before.Container.Nodes (Before.Node).Parent /= Parent.Node
755         then
756            raise Constraint_Error with "Before cursor not child of Parent";
757         end if;
758      end if;
759
760      if Source = No_Element then
761         return;
762      end if;
763
764      if Checks and then Is_Root (Source) then
765         raise Constraint_Error with "Source cursor designates root";
766      end if;
767
768      if Target.Count = 0 then
769         Initialize_Root (Target);
770      end if;
771
772      --  Copy_Subtree returns a count of the number of nodes that it
773      --  allocates, but it works by incrementing the value that is passed
774      --  in. We must therefore initialize the count value before calling
775      --  Copy_Subtree.
776
777      Target_Count := 0;
778
779      Copy_Subtree
780        (Source         => Source.Container.all,
781         Source_Subtree => Source.Node,
782         Target         => Target,
783         Target_Parent  => Parent.Node,
784         Target_Subtree => Target_Subtree,
785         Count          => Target_Count);
786
787      Insert_Subtree_Node
788        (Container => Target,
789         Subtree   => Target_Subtree,
790         Parent    => Parent.Node,
791         Before    => Before.Node);
792
793      Target.Count := Target.Count + Target_Count;
794   end Copy_Subtree;
795
796   procedure Copy_Subtree
797     (Source         : Tree;
798      Source_Subtree : Count_Type;
799      Target         : in out Tree;
800      Target_Parent  : Count_Type;
801      Target_Subtree : out Count_Type;
802      Count          : in out Count_Type)
803   is
804      T_Nodes : Tree_Node_Array renames Target.Nodes;
805
806   begin
807      --  First we allocate the root of the target subtree.
808
809      Allocate_Node
810        (Container => Target,
811         New_Item  => Source.Elements (Source_Subtree),
812         New_Node  => Target_Subtree);
813
814      T_Nodes (Target_Subtree).Parent := Target_Parent;
815      Count := Count + 1;
816
817      --  We now have a new subtree (for the Target tree), containing only a
818      --  copy of the corresponding element in the Source subtree. Next we copy
819      --  the children of the Source subtree as children of the new Target
820      --  subtree.
821
822      Copy_Children
823        (Source        => Source,
824         Source_Parent => Source_Subtree,
825         Target        => Target,
826         Target_Parent => Target_Subtree,
827         Count         => Count);
828   end Copy_Subtree;
829
830   -------------------------
831   -- Deallocate_Children --
832   -------------------------
833
834   procedure Deallocate_Children
835     (Container : in out Tree;
836      Subtree   : Count_Type;
837      Count     : in out Count_Type)
838   is
839      Nodes : Tree_Node_Array renames Container.Nodes;
840      Node  : Tree_Node_Type renames Nodes (Subtree);  -- parent
841      CC    : Children_Type renames Node.Children;
842      C     : Count_Type'Base;
843
844   begin
845      while CC.First > 0 loop
846         C := CC.First;
847         CC.First := Nodes (C).Next;
848
849         Deallocate_Subtree (Container, C, Count);
850      end loop;
851
852      CC.Last := 0;
853   end Deallocate_Children;
854
855   ---------------------
856   -- Deallocate_Node --
857   ---------------------
858
859   procedure Deallocate_Node
860     (Container : in out Tree;
861      X         : Count_Type)
862   is
863      NN : Tree_Node_Array renames Container.Nodes;
864      pragma Assert (X > 0);
865      pragma Assert (X <= NN'Last);
866
867      N : Tree_Node_Type renames NN (X);
868      pragma Assert (N.Parent /= X);  -- node is active
869
870   begin
871      --  The tree container actually contains two lists: one for the "active"
872      --  nodes that contain elements that have been inserted onto the tree,
873      --  and another for the "inactive" nodes of the free store, from which
874      --  nodes are allocated when a new child is inserted in the tree.
875
876      --  We desire that merely declaring a tree object should have only
877      --  minimal cost; specially, we want to avoid having to initialize the
878      --  free store (to fill in the links), especially if the capacity of the
879      --  tree object is large.
880
881      --  The head of the free list is indicated by Container.Free. If its
882      --  value is non-negative, then the free store has been initialized in
883      --  the "normal" way: Container.Free points to the head of the list of
884      --  free (inactive) nodes, and the value 0 means the free list is
885      --  empty. Each node on the free list has been initialized to point to
886      --  the next free node (via its Next component), and the value 0 means
887      --  that this is the last node of the free list.
888
889      --  If Container.Free is negative, then the links on the free store have
890      --  not been initialized. In this case the link values are implied: the
891      --  free store comprises the components of the node array started with
892      --  the absolute value of Container.Free, and continuing until the end of
893      --  the array (Nodes'Last).
894
895      --  We prefer to lazy-init the free store (in fact, we would prefer to
896      --  not initialize it at all, because such initialization is an O(n)
897      --  operation). The time when we need to actually initialize the nodes in
898      --  the free store is when the node that becomes inactive is not at the
899      --  end of the active list. The free store would then be discontigous and
900      --  so its nodes would need to be linked in the traditional way.
901
902      --  It might be possible to perform an optimization here. Suppose that
903      --  the free store can be represented as having two parts: one comprising
904      --  the non-contiguous inactive nodes linked together in the normal way,
905      --  and the other comprising the contiguous inactive nodes (that are not
906      --  linked together, at the end of the nodes array). This would allow us
907      --  to never have to initialize the free store, except in a lazy way as
908      --  nodes become inactive. ???
909
910      --  When an element is deleted from the list container, its node becomes
911      --  inactive, and so we set its Parent and Prev components to an
912      --  impossible value (the index of the node itself), to indicate that it
913      --  is now inactive. This provides a useful way to detect a dangling
914      --  cursor reference.
915
916      N.Parent := X;  -- Node is deallocated (not on active list)
917      N.Prev := X;
918
919      if Container.Free >= 0 then
920         --  The free store has previously been initialized. All we need to do
921         --  here is link the newly-free'd node onto the free list.
922
923         N.Next := Container.Free;
924         Container.Free := X;
925
926      elsif X + 1 = abs Container.Free then
927         --  The free store has not been initialized, and the node becoming
928         --  inactive immediately precedes the start of the free store. All
929         --  we need to do is move the start of the free store back by one.
930
931         N.Next := X;  -- Not strictly necessary, but marginally safer
932         Container.Free := Container.Free + 1;
933
934      else
935         --  The free store has not been initialized, and the node becoming
936         --  inactive does not immediately precede the free store. Here we
937         --  first initialize the free store (meaning the links are given
938         --  values in the traditional way), and then link the newly-free'd
939         --  node onto the head of the free store.
940
941         --  See the comments above for an optimization opportunity. If the
942         --  next link for a node on the free store is negative, then this
943         --  means the remaining nodes on the free store are physically
944         --  contiguous, starting at the absolute value of that index value.
945         --  ???
946
947         Container.Free := abs Container.Free;
948
949         if Container.Free > Container.Capacity then
950            Container.Free := 0;
951
952         else
953            for J in Container.Free .. Container.Capacity - 1 loop
954               NN (J).Next := J + 1;
955            end loop;
956
957            NN (Container.Capacity).Next := 0;
958         end if;
959
960         NN (X).Next := Container.Free;
961         Container.Free := X;
962      end if;
963   end Deallocate_Node;
964
965   ------------------------
966   -- Deallocate_Subtree --
967   ------------------------
968
969   procedure Deallocate_Subtree
970     (Container : in out Tree;
971      Subtree   : Count_Type;
972      Count     : in out Count_Type)
973   is
974   begin
975      Deallocate_Children (Container, Subtree, Count);
976      Deallocate_Node (Container, Subtree);
977      Count := Count + 1;
978   end Deallocate_Subtree;
979
980   ---------------------
981   -- Delete_Children --
982   ---------------------
983
984   procedure Delete_Children
985     (Container : in out Tree;
986      Parent    : Cursor)
987   is
988      Count : Count_Type;
989
990   begin
991      if Checks and then Parent = No_Element then
992         raise Constraint_Error with "Parent cursor has no element";
993      end if;
994
995      if Checks and then Parent.Container /= Container'Unrestricted_Access then
996         raise Program_Error with "Parent cursor not in container";
997      end if;
998
999      TC_Check (Container.TC);
1000
1001      if Container.Count = 0 then
1002         pragma Assert (Is_Root (Parent));
1003         return;
1004      end if;
1005
1006      --  Deallocate_Children returns a count of the number of nodes that it
1007      --  deallocates, but it works by incrementing the value that is passed
1008      --  in. We must therefore initialize the count value before calling
1009      --  Deallocate_Children.
1010
1011      Count := 0;
1012
1013      Deallocate_Children (Container, Parent.Node, Count);
1014      pragma Assert (Count <= Container.Count);
1015
1016      Container.Count := Container.Count - Count;
1017   end Delete_Children;
1018
1019   -----------------
1020   -- Delete_Leaf --
1021   -----------------
1022
1023   procedure Delete_Leaf
1024     (Container : in out Tree;
1025      Position  : in out Cursor)
1026   is
1027      X : Count_Type;
1028
1029   begin
1030      if Checks and then Position = No_Element then
1031         raise Constraint_Error with "Position cursor has no element";
1032      end if;
1033
1034      if Checks and then Position.Container /= Container'Unrestricted_Access
1035      then
1036         raise Program_Error with "Position cursor not in container";
1037      end if;
1038
1039      if Checks and then Is_Root (Position) then
1040         raise Program_Error with "Position cursor designates root";
1041      end if;
1042
1043      if Checks and then not Is_Leaf (Position) then
1044         raise Constraint_Error with "Position cursor does not designate leaf";
1045      end if;
1046
1047      TC_Check (Container.TC);
1048
1049      X := Position.Node;
1050      Position := No_Element;
1051
1052      Remove_Subtree (Container, X);
1053      Container.Count := Container.Count - 1;
1054
1055      Deallocate_Node (Container, X);
1056   end Delete_Leaf;
1057
1058   --------------------
1059   -- Delete_Subtree --
1060   --------------------
1061
1062   procedure Delete_Subtree
1063     (Container : in out Tree;
1064      Position  : in out Cursor)
1065   is
1066      X     : Count_Type;
1067      Count : Count_Type;
1068
1069   begin
1070      if Checks and then Position = No_Element then
1071         raise Constraint_Error with "Position cursor has no element";
1072      end if;
1073
1074      if Checks and then Position.Container /= Container'Unrestricted_Access
1075      then
1076         raise Program_Error with "Position cursor not in container";
1077      end if;
1078
1079      if Checks and then Is_Root (Position) then
1080         raise Program_Error with "Position cursor designates root";
1081      end if;
1082
1083      TC_Check (Container.TC);
1084
1085      X := Position.Node;
1086      Position := No_Element;
1087
1088      Remove_Subtree (Container, X);
1089
1090      --  Deallocate_Subtree returns a count of the number of nodes that it
1091      --  deallocates, but it works by incrementing the value that is passed
1092      --  in. We must therefore initialize the count value before calling
1093      --  Deallocate_Subtree.
1094
1095      Count := 0;
1096
1097      Deallocate_Subtree (Container, X, Count);
1098      pragma Assert (Count <= Container.Count);
1099
1100      Container.Count := Container.Count - Count;
1101   end Delete_Subtree;
1102
1103   -----------
1104   -- Depth --
1105   -----------
1106
1107   function Depth (Position : Cursor) return Count_Type is
1108      Result : Count_Type;
1109      N      : Count_Type'Base;
1110
1111   begin
1112      if Position = No_Element then
1113         return 0;
1114      end if;
1115
1116      if Is_Root (Position) then
1117         return 1;
1118      end if;
1119
1120      Result := 0;
1121      N := Position.Node;
1122      while N >= 0 loop
1123         N := Position.Container.Nodes (N).Parent;
1124         Result := Result + 1;
1125      end loop;
1126
1127      return Result;
1128   end Depth;
1129
1130   -------------
1131   -- Element --
1132   -------------
1133
1134   function Element (Position : Cursor) return Element_Type is
1135   begin
1136      if Checks and then Position.Container = null then
1137         raise Constraint_Error with "Position cursor has no element";
1138      end if;
1139
1140      if Checks and then Position.Node = Root_Node (Position.Container.all)
1141      then
1142         raise Program_Error with "Position cursor designates root";
1143      end if;
1144
1145      return Position.Container.Elements (Position.Node);
1146   end Element;
1147
1148   --------------------
1149   -- Equal_Children --
1150   --------------------
1151
1152   function Equal_Children
1153     (Left_Tree     : Tree;
1154      Left_Subtree  : Count_Type;
1155      Right_Tree    : Tree;
1156      Right_Subtree : Count_Type) return Boolean
1157   is
1158      L_NN : Tree_Node_Array renames Left_Tree.Nodes;
1159      R_NN : Tree_Node_Array renames Right_Tree.Nodes;
1160
1161      Left_Children  : Children_Type renames L_NN (Left_Subtree).Children;
1162      Right_Children : Children_Type renames R_NN (Right_Subtree).Children;
1163
1164      L, R : Count_Type'Base;
1165
1166   begin
1167      if Child_Count (Left_Tree, Left_Subtree)
1168        /= Child_Count (Right_Tree, Right_Subtree)
1169      then
1170         return False;
1171      end if;
1172
1173      L := Left_Children.First;
1174      R := Right_Children.First;
1175      while L > 0 loop
1176         if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then
1177            return False;
1178         end if;
1179
1180         L := L_NN (L).Next;
1181         R := R_NN (R).Next;
1182      end loop;
1183
1184      return True;
1185   end Equal_Children;
1186
1187   -------------------
1188   -- Equal_Subtree --
1189   -------------------
1190
1191   function Equal_Subtree
1192     (Left_Position  : Cursor;
1193      Right_Position : Cursor) return Boolean
1194   is
1195   begin
1196      if Checks and then Left_Position = No_Element then
1197         raise Constraint_Error with "Left cursor has no element";
1198      end if;
1199
1200      if Checks and then Right_Position = No_Element then
1201         raise Constraint_Error with "Right cursor has no element";
1202      end if;
1203
1204      if Left_Position = Right_Position then
1205         return True;
1206      end if;
1207
1208      if Is_Root (Left_Position) then
1209         if not Is_Root (Right_Position) then
1210            return False;
1211         end if;
1212
1213         if Left_Position.Container.Count = 0 then
1214            return Right_Position.Container.Count = 0;
1215         end if;
1216
1217         if Right_Position.Container.Count = 0 then
1218            return False;
1219         end if;
1220
1221         return Equal_Children
1222                  (Left_Tree     => Left_Position.Container.all,
1223                   Left_Subtree  => Left_Position.Node,
1224                   Right_Tree    => Right_Position.Container.all,
1225                   Right_Subtree => Right_Position.Node);
1226      end if;
1227
1228      if Is_Root (Right_Position) then
1229         return False;
1230      end if;
1231
1232      return Equal_Subtree
1233               (Left_Tree     => Left_Position.Container.all,
1234                Left_Subtree  => Left_Position.Node,
1235                Right_Tree    => Right_Position.Container.all,
1236                Right_Subtree => Right_Position.Node);
1237   end Equal_Subtree;
1238
1239   function Equal_Subtree
1240     (Left_Tree     : Tree;
1241      Left_Subtree  : Count_Type;
1242      Right_Tree    : Tree;
1243      Right_Subtree : Count_Type) return Boolean
1244   is
1245   begin
1246      if Left_Tree.Elements  (Left_Subtree) /=
1247         Right_Tree.Elements (Right_Subtree)
1248      then
1249         return False;
1250      end if;
1251
1252      return Equal_Children
1253               (Left_Tree     => Left_Tree,
1254                Left_Subtree  => Left_Subtree,
1255                Right_Tree    => Right_Tree,
1256                Right_Subtree => Right_Subtree);
1257   end Equal_Subtree;
1258
1259   --------------
1260   -- Finalize --
1261   --------------
1262
1263   procedure Finalize (Object : in out Root_Iterator) is
1264   begin
1265      Unbusy (Object.Container.TC);
1266   end Finalize;
1267
1268   ----------
1269   -- Find --
1270   ----------
1271
1272   function Find
1273     (Container : Tree;
1274      Item      : Element_Type) return Cursor
1275   is
1276      Node : Count_Type;
1277
1278   begin
1279      if Container.Count = 0 then
1280         return No_Element;
1281      end if;
1282
1283      Node := Find_In_Children (Container, Root_Node (Container), Item);
1284
1285      if Node = 0 then
1286         return No_Element;
1287      end if;
1288
1289      return Cursor'(Container'Unrestricted_Access, Node);
1290   end Find;
1291
1292   -----------
1293   -- First --
1294   -----------
1295
1296   overriding function First (Object : Subtree_Iterator) return Cursor is
1297   begin
1298      if Object.Subtree = Root_Node (Object.Container.all) then
1299         return First_Child (Root (Object.Container.all));
1300      else
1301         return Cursor'(Object.Container, Object.Subtree);
1302      end if;
1303   end First;
1304
1305   overriding function First (Object : Child_Iterator) return Cursor is
1306   begin
1307      return First_Child (Cursor'(Object.Container, Object.Subtree));
1308   end First;
1309
1310   -----------------
1311   -- First_Child --
1312   -----------------
1313
1314   function First_Child (Parent : Cursor) return Cursor is
1315      Node : Count_Type'Base;
1316
1317   begin
1318      if Checks and then Parent = No_Element then
1319         raise Constraint_Error with "Parent cursor has no element";
1320      end if;
1321
1322      if Parent.Container.Count = 0 then
1323         pragma Assert (Is_Root (Parent));
1324         return No_Element;
1325      end if;
1326
1327      Node := Parent.Container.Nodes (Parent.Node).Children.First;
1328
1329      if Node <= 0 then
1330         return No_Element;
1331      end if;
1332
1333      return Cursor'(Parent.Container, Node);
1334   end First_Child;
1335
1336   -------------------------
1337   -- First_Child_Element --
1338   -------------------------
1339
1340   function First_Child_Element (Parent : Cursor) return Element_Type is
1341   begin
1342      return Element (First_Child (Parent));
1343   end First_Child_Element;
1344
1345   ----------------------
1346   -- Find_In_Children --
1347   ----------------------
1348
1349   function Find_In_Children
1350     (Container : Tree;
1351      Subtree   : Count_Type;
1352      Item      : Element_Type) return Count_Type
1353   is
1354      N      : Count_Type'Base;
1355      Result : Count_Type;
1356
1357   begin
1358      N := Container.Nodes (Subtree).Children.First;
1359      while N > 0 loop
1360         Result := Find_In_Subtree (Container, N, Item);
1361
1362         if Result > 0 then
1363            return Result;
1364         end if;
1365
1366         N := Container.Nodes (N).Next;
1367      end loop;
1368
1369      return 0;
1370   end Find_In_Children;
1371
1372   ---------------------
1373   -- Find_In_Subtree --
1374   ---------------------
1375
1376   function Find_In_Subtree
1377     (Position : Cursor;
1378      Item     : Element_Type) return Cursor
1379   is
1380      Result : Count_Type;
1381
1382   begin
1383      if Checks and then Position = No_Element then
1384         raise Constraint_Error with "Position cursor has no element";
1385      end if;
1386
1387      --  Commented-out pending ruling by ARG.  ???
1388
1389      --  if Checks and then
1390      --    Position.Container /= Container'Unrestricted_Access
1391      --  then
1392      --     raise Program_Error with "Position cursor not in container";
1393      --  end if;
1394
1395      if Position.Container.Count = 0 then
1396         pragma Assert (Is_Root (Position));
1397         return No_Element;
1398      end if;
1399
1400      if Is_Root (Position) then
1401         Result := Find_In_Children
1402                     (Container => Position.Container.all,
1403                      Subtree   => Position.Node,
1404                      Item      => Item);
1405
1406      else
1407         Result := Find_In_Subtree
1408                     (Container => Position.Container.all,
1409                      Subtree   => Position.Node,
1410                      Item      => Item);
1411      end if;
1412
1413      if Result = 0 then
1414         return No_Element;
1415      end if;
1416
1417      return Cursor'(Position.Container, Result);
1418   end Find_In_Subtree;
1419
1420   function Find_In_Subtree
1421     (Container : Tree;
1422      Subtree   : Count_Type;
1423      Item      : Element_Type) return Count_Type
1424   is
1425   begin
1426      if Container.Elements (Subtree) = Item then
1427         return Subtree;
1428      end if;
1429
1430      return Find_In_Children (Container, Subtree, Item);
1431   end Find_In_Subtree;
1432
1433   ------------------------
1434   -- Get_Element_Access --
1435   ------------------------
1436
1437   function Get_Element_Access
1438     (Position : Cursor) return not null Element_Access is
1439   begin
1440      return Position.Container.Elements (Position.Node)'Access;
1441   end Get_Element_Access;
1442
1443   -----------------
1444   -- Has_Element --
1445   -----------------
1446
1447   function Has_Element (Position : Cursor) return Boolean is
1448   begin
1449      if Position = No_Element then
1450         return False;
1451      end if;
1452
1453      return Position.Node /= Root_Node (Position.Container.all);
1454   end Has_Element;
1455
1456   ---------------------
1457   -- Initialize_Node --
1458   ---------------------
1459
1460   procedure Initialize_Node
1461     (Container : in out Tree;
1462      Index     : Count_Type)
1463   is
1464   begin
1465      Container.Nodes (Index) :=
1466        (Parent   => No_Node,
1467         Prev     => 0,
1468         Next     => 0,
1469         Children => (others => 0));
1470   end Initialize_Node;
1471
1472   ---------------------
1473   -- Initialize_Root --
1474   ---------------------
1475
1476   procedure Initialize_Root (Container : in out Tree) is
1477   begin
1478      Initialize_Node (Container, Root_Node (Container));
1479   end Initialize_Root;
1480
1481   ------------------
1482   -- Insert_Child --
1483   ------------------
1484
1485   procedure Insert_Child
1486     (Container : in out Tree;
1487      Parent    : Cursor;
1488      Before    : Cursor;
1489      New_Item  : Element_Type;
1490      Count     : Count_Type := 1)
1491   is
1492      Position : Cursor;
1493      pragma Unreferenced (Position);
1494
1495   begin
1496      Insert_Child (Container, Parent, Before, New_Item, Position, Count);
1497   end Insert_Child;
1498
1499   procedure Insert_Child
1500     (Container : in out Tree;
1501      Parent    : Cursor;
1502      Before    : Cursor;
1503      New_Item  : Element_Type;
1504      Position  : out Cursor;
1505      Count     : Count_Type := 1)
1506   is
1507      Nodes : Tree_Node_Array renames Container.Nodes;
1508      First : Count_Type;
1509      Last  : Count_Type;
1510
1511   begin
1512      if Checks and then Parent = No_Element then
1513         raise Constraint_Error with "Parent cursor has no element";
1514      end if;
1515
1516      if Checks and then Parent.Container /= Container'Unrestricted_Access then
1517         raise Program_Error with "Parent cursor not in container";
1518      end if;
1519
1520      if Before /= No_Element then
1521         if Checks and then Before.Container /= Container'Unrestricted_Access
1522         then
1523            raise Program_Error with "Before cursor not in container";
1524         end if;
1525
1526         if Checks and then
1527           Before.Container.Nodes (Before.Node).Parent /= Parent.Node
1528         then
1529            raise Constraint_Error with "Parent cursor not parent of Before";
1530         end if;
1531      end if;
1532
1533      if Count = 0 then
1534         Position := No_Element;  -- Need ruling from ARG ???
1535         return;
1536      end if;
1537
1538      if Checks and then Container.Count > Container.Capacity - Count then
1539         raise Capacity_Error
1540           with "requested count exceeds available storage";
1541      end if;
1542
1543      TC_Check (Container.TC);
1544
1545      if Container.Count = 0 then
1546         Initialize_Root (Container);
1547      end if;
1548
1549      Allocate_Node (Container, New_Item, First);
1550      Nodes (First).Parent := Parent.Node;
1551
1552      Last := First;
1553      for J in Count_Type'(2) .. Count loop
1554         Allocate_Node (Container, New_Item, Nodes (Last).Next);
1555         Nodes (Nodes (Last).Next).Parent := Parent.Node;
1556         Nodes (Nodes (Last).Next).Prev := Last;
1557
1558         Last := Nodes (Last).Next;
1559      end loop;
1560
1561      Insert_Subtree_List
1562        (Container => Container,
1563         First     => First,
1564         Last      => Last,
1565         Parent    => Parent.Node,
1566         Before    => Before.Node);
1567
1568      Container.Count := Container.Count + Count;
1569
1570      Position := Cursor'(Parent.Container, First);
1571   end Insert_Child;
1572
1573   procedure Insert_Child
1574     (Container : in out Tree;
1575      Parent    : Cursor;
1576      Before    : Cursor;
1577      Position  : out Cursor;
1578      Count     : Count_Type := 1)
1579   is
1580      Nodes : Tree_Node_Array renames Container.Nodes;
1581      First : Count_Type;
1582      Last  : Count_Type;
1583
1584      pragma Warnings (Off);
1585      Default_Initialized_Item : Element_Type;
1586      pragma Unmodified (Default_Initialized_Item);
1587      --  OK to reference, see below
1588
1589   begin
1590      if Checks and then Parent = No_Element then
1591         raise Constraint_Error with "Parent cursor has no element";
1592      end if;
1593
1594      if Checks and then Parent.Container /= Container'Unrestricted_Access then
1595         raise Program_Error with "Parent cursor not in container";
1596      end if;
1597
1598      if Before /= No_Element then
1599         if Checks and then Before.Container /= Container'Unrestricted_Access
1600         then
1601            raise Program_Error with "Before cursor not in container";
1602         end if;
1603
1604         if Checks and then
1605           Before.Container.Nodes (Before.Node).Parent /= Parent.Node
1606         then
1607            raise Constraint_Error with "Parent cursor not parent of Before";
1608         end if;
1609      end if;
1610
1611      if Count = 0 then
1612         Position := No_Element;  -- Need ruling from ARG  ???
1613         return;
1614      end if;
1615
1616      if Checks and then Container.Count > Container.Capacity - Count then
1617         raise Capacity_Error
1618           with "requested count exceeds available storage";
1619      end if;
1620
1621      TC_Check (Container.TC);
1622
1623      if Container.Count = 0 then
1624         Initialize_Root (Container);
1625      end if;
1626
1627      --  There is no explicit element provided, but in an instance the element
1628      --  type may be a scalar with a Default_Value aspect, or a composite
1629      --  type with such a scalar component, or components with default
1630      --  initialization, so insert the specified number of possibly
1631      --  initialized elements at the given position.
1632
1633      Allocate_Node (Container, Default_Initialized_Item, First);
1634      Nodes (First).Parent := Parent.Node;
1635
1636      Last := First;
1637      for J in Count_Type'(2) .. Count loop
1638         Allocate_Node
1639           (Container, Default_Initialized_Item, Nodes (Last).Next);
1640         Nodes (Nodes (Last).Next).Parent := Parent.Node;
1641         Nodes (Nodes (Last).Next).Prev := Last;
1642
1643         Last := Nodes (Last).Next;
1644      end loop;
1645
1646      Insert_Subtree_List
1647        (Container => Container,
1648         First     => First,
1649         Last      => Last,
1650         Parent    => Parent.Node,
1651         Before    => Before.Node);
1652
1653      Container.Count := Container.Count + Count;
1654
1655      Position := Cursor'(Parent.Container, First);
1656      pragma Warnings (On);
1657   end Insert_Child;
1658
1659   -------------------------
1660   -- Insert_Subtree_List --
1661   -------------------------
1662
1663   procedure Insert_Subtree_List
1664     (Container : in out Tree;
1665      First     : Count_Type'Base;
1666      Last      : Count_Type'Base;
1667      Parent    : Count_Type;
1668      Before    : Count_Type'Base)
1669   is
1670      NN : Tree_Node_Array renames Container.Nodes;
1671      N  : Tree_Node_Type renames NN (Parent);
1672      CC : Children_Type renames N.Children;
1673
1674   begin
1675      --  This is a simple utility operation to insert a list of nodes
1676      --  (First..Last) as children of Parent. The Before node specifies where
1677      --  the new children should be inserted relative to existing children.
1678
1679      if First <= 0 then
1680         pragma Assert (Last <= 0);
1681         return;
1682      end if;
1683
1684      pragma Assert (Last > 0);
1685      pragma Assert (Before <= 0 or else NN (Before).Parent = Parent);
1686
1687      if CC.First <= 0 then  -- no existing children
1688         CC.First := First;
1689         NN (CC.First).Prev := 0;
1690         CC.Last := Last;
1691         NN (CC.Last).Next := 0;
1692
1693      elsif Before <= 0 then  -- means "insert after existing nodes"
1694         NN (CC.Last).Next := First;
1695         NN (First).Prev := CC.Last;
1696         CC.Last := Last;
1697         NN (CC.Last).Next := 0;
1698
1699      elsif Before = CC.First then
1700         NN (Last).Next := CC.First;
1701         NN (CC.First).Prev := Last;
1702         CC.First := First;
1703         NN (CC.First).Prev := 0;
1704
1705      else
1706         NN (NN (Before).Prev).Next := First;
1707         NN (First).Prev := NN (Before).Prev;
1708         NN (Last).Next := Before;
1709         NN (Before).Prev := Last;
1710      end if;
1711   end Insert_Subtree_List;
1712
1713   -------------------------
1714   -- Insert_Subtree_Node --
1715   -------------------------
1716
1717   procedure Insert_Subtree_Node
1718     (Container : in out Tree;
1719      Subtree   : Count_Type'Base;
1720      Parent    : Count_Type;
1721      Before    : Count_Type'Base)
1722   is
1723   begin
1724      --  This is a simple wrapper operation to insert a single child into the
1725      --  Parent's children list.
1726
1727      Insert_Subtree_List
1728        (Container => Container,
1729         First     => Subtree,
1730         Last      => Subtree,
1731         Parent    => Parent,
1732         Before    => Before);
1733   end Insert_Subtree_Node;
1734
1735   --------------
1736   -- Is_Empty --
1737   --------------
1738
1739   function Is_Empty (Container : Tree) return Boolean is
1740   begin
1741      return Container.Count = 0;
1742   end Is_Empty;
1743
1744   -------------
1745   -- Is_Leaf --
1746   -------------
1747
1748   function Is_Leaf (Position : Cursor) return Boolean is
1749   begin
1750      if Position = No_Element then
1751         return False;
1752      end if;
1753
1754      if Position.Container.Count = 0 then
1755         pragma Assert (Is_Root (Position));
1756         return True;
1757      end if;
1758
1759      return Position.Container.Nodes (Position.Node).Children.First <= 0;
1760   end Is_Leaf;
1761
1762   ------------------
1763   -- Is_Reachable --
1764   ------------------
1765
1766   function Is_Reachable
1767     (Container : Tree;
1768      From, To  : Count_Type) return Boolean
1769   is
1770      Idx : Count_Type;
1771
1772   begin
1773      Idx := From;
1774      while Idx >= 0 loop
1775         if Idx = To then
1776            return True;
1777         end if;
1778
1779         Idx := Container.Nodes (Idx).Parent;
1780      end loop;
1781
1782      return False;
1783   end Is_Reachable;
1784
1785   -------------
1786   -- Is_Root --
1787   -------------
1788
1789   function Is_Root (Position : Cursor) return Boolean is
1790   begin
1791      return
1792        (if Position.Container = null then False
1793         else Position.Node = Root_Node (Position.Container.all));
1794   end Is_Root;
1795
1796   -------------
1797   -- Iterate --
1798   -------------
1799
1800   procedure Iterate
1801     (Container : Tree;
1802      Process   : not null access procedure (Position : Cursor))
1803   is
1804      Busy : With_Busy (Container.TC'Unrestricted_Access);
1805   begin
1806      if Container.Count = 0 then
1807         return;
1808      end if;
1809
1810      Iterate_Children
1811        (Container => Container,
1812         Subtree   => Root_Node (Container),
1813         Process   => Process);
1814   end Iterate;
1815
1816   function Iterate (Container : Tree)
1817     return Tree_Iterator_Interfaces.Forward_Iterator'Class
1818   is
1819   begin
1820      return Iterate_Subtree (Root (Container));
1821   end Iterate;
1822
1823   ----------------------
1824   -- Iterate_Children --
1825   ----------------------
1826
1827   procedure Iterate_Children
1828     (Parent  : Cursor;
1829      Process : not null access procedure (Position : Cursor))
1830   is
1831   begin
1832      if Checks and then Parent = No_Element then
1833         raise Constraint_Error with "Parent cursor has no element";
1834      end if;
1835
1836      if Parent.Container.Count = 0 then
1837         pragma Assert (Is_Root (Parent));
1838         return;
1839      end if;
1840
1841      declare
1842         C  : Count_Type;
1843         NN : Tree_Node_Array renames Parent.Container.Nodes;
1844         Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
1845
1846      begin
1847         C := NN (Parent.Node).Children.First;
1848         while C > 0 loop
1849            Process (Cursor'(Parent.Container, Node => C));
1850            C := NN (C).Next;
1851         end loop;
1852      end;
1853   end Iterate_Children;
1854
1855   procedure Iterate_Children
1856     (Container : Tree;
1857      Subtree   : Count_Type;
1858      Process   : not null access procedure (Position : Cursor))
1859   is
1860      NN : Tree_Node_Array renames Container.Nodes;
1861      N  : Tree_Node_Type renames NN (Subtree);
1862      C  : Count_Type;
1863
1864   begin
1865      --  This is a helper function to recursively iterate over all the nodes
1866      --  in a subtree, in depth-first fashion. This particular helper just
1867      --  visits the children of this subtree, not the root of the subtree
1868      --  itself. This is useful when starting from the ultimate root of the
1869      --  entire tree (see Iterate), as that root does not have an element.
1870
1871      C := N.Children.First;
1872      while C > 0 loop
1873         Iterate_Subtree (Container, C, Process);
1874         C := NN (C).Next;
1875      end loop;
1876   end Iterate_Children;
1877
1878   function Iterate_Children
1879     (Container : Tree;
1880      Parent    : Cursor)
1881      return Tree_Iterator_Interfaces.Reversible_Iterator'Class
1882   is
1883      C : constant Tree_Access := Container'Unrestricted_Access;
1884   begin
1885      if Checks and then Parent = No_Element then
1886         raise Constraint_Error with "Parent cursor has no element";
1887      end if;
1888
1889      if Checks and then Parent.Container /= C then
1890         raise Program_Error with "Parent cursor not in container";
1891      end if;
1892
1893      return It : constant Child_Iterator :=
1894        Child_Iterator'(Limited_Controlled with
1895                          Container => C,
1896                          Subtree   => Parent.Node)
1897      do
1898         Busy (C.TC);
1899      end return;
1900   end Iterate_Children;
1901
1902   ---------------------
1903   -- Iterate_Subtree --
1904   ---------------------
1905
1906   function Iterate_Subtree
1907     (Position : Cursor)
1908      return Tree_Iterator_Interfaces.Forward_Iterator'Class
1909   is
1910      C : constant Tree_Access := Position.Container;
1911   begin
1912      if Checks and then Position = No_Element then
1913         raise Constraint_Error with "Position cursor has no element";
1914      end if;
1915
1916      --  Implement Vet for multiway trees???
1917      --  pragma Assert (Vet (Position), "bad subtree cursor");
1918
1919      return It : constant Subtree_Iterator :=
1920        (Limited_Controlled with
1921           Container => C,
1922           Subtree   => Position.Node)
1923      do
1924         Busy (C.TC);
1925      end return;
1926   end Iterate_Subtree;
1927
1928   procedure Iterate_Subtree
1929     (Position  : Cursor;
1930      Process   : not null access procedure (Position : Cursor))
1931   is
1932   begin
1933      if Checks and then Position = No_Element then
1934         raise Constraint_Error with "Position cursor has no element";
1935      end if;
1936
1937      if Position.Container.Count = 0 then
1938         pragma Assert (Is_Root (Position));
1939         return;
1940      end if;
1941
1942      declare
1943         T : Tree renames Position.Container.all;
1944         Busy : With_Busy (T.TC'Unrestricted_Access);
1945      begin
1946         if Is_Root (Position) then
1947            Iterate_Children (T, Position.Node, Process);
1948         else
1949            Iterate_Subtree (T, Position.Node, Process);
1950         end if;
1951      end;
1952   end Iterate_Subtree;
1953
1954   procedure Iterate_Subtree
1955     (Container : Tree;
1956      Subtree   : Count_Type;
1957      Process   : not null access procedure (Position : Cursor))
1958   is
1959   begin
1960      --  This is a helper function to recursively iterate over all the nodes
1961      --  in a subtree, in depth-first fashion. It first visits the root of the
1962      --  subtree, then visits its children.
1963
1964      Process (Cursor'(Container'Unrestricted_Access, Subtree));
1965      Iterate_Children (Container, Subtree, Process);
1966   end Iterate_Subtree;
1967
1968   ----------
1969   -- Last --
1970   ----------
1971
1972   overriding function Last (Object : Child_Iterator) return Cursor is
1973   begin
1974      return Last_Child (Cursor'(Object.Container, Object.Subtree));
1975   end Last;
1976
1977   ----------------
1978   -- Last_Child --
1979   ----------------
1980
1981   function Last_Child (Parent : Cursor) return Cursor is
1982      Node : Count_Type'Base;
1983
1984   begin
1985      if Checks and then Parent = No_Element then
1986         raise Constraint_Error with "Parent cursor has no element";
1987      end if;
1988
1989      if Parent.Container.Count = 0 then
1990         pragma Assert (Is_Root (Parent));
1991         return No_Element;
1992      end if;
1993
1994      Node := Parent.Container.Nodes (Parent.Node).Children.Last;
1995
1996      if Node <= 0 then
1997         return No_Element;
1998      end if;
1999
2000      return Cursor'(Parent.Container, Node);
2001   end Last_Child;
2002
2003   ------------------------
2004   -- Last_Child_Element --
2005   ------------------------
2006
2007   function Last_Child_Element (Parent : Cursor) return Element_Type is
2008   begin
2009      return Element (Last_Child (Parent));
2010   end Last_Child_Element;
2011
2012   ----------
2013   -- Move --
2014   ----------
2015
2016   procedure Move (Target : in out Tree; Source : in out Tree) is
2017   begin
2018      if Target'Address = Source'Address then
2019         return;
2020      end if;
2021
2022      TC_Check (Source.TC);
2023
2024      Target.Assign (Source);
2025      Source.Clear;
2026   end Move;
2027
2028   ----------
2029   -- Next --
2030   ----------
2031
2032   overriding function Next
2033     (Object   : Subtree_Iterator;
2034      Position : Cursor) return Cursor
2035   is
2036   begin
2037      if Position.Container = null then
2038         return No_Element;
2039      end if;
2040
2041      if Checks and then Position.Container /= Object.Container then
2042         raise Program_Error with
2043           "Position cursor of Next designates wrong tree";
2044      end if;
2045
2046      pragma Assert (Object.Container.Count > 0);
2047      pragma Assert (Position.Node /= Root_Node (Object.Container.all));
2048
2049      declare
2050         Nodes : Tree_Node_Array renames Object.Container.Nodes;
2051         Node  : Count_Type;
2052
2053      begin
2054         Node := Position.Node;
2055
2056         if Nodes (Node).Children.First > 0 then
2057            return Cursor'(Object.Container, Nodes (Node).Children.First);
2058         end if;
2059
2060         while Node /= Object.Subtree loop
2061            if Nodes (Node).Next > 0 then
2062               return Cursor'(Object.Container, Nodes (Node).Next);
2063            end if;
2064
2065            Node := Nodes (Node).Parent;
2066         end loop;
2067
2068         return No_Element;
2069      end;
2070   end Next;
2071
2072   overriding function Next
2073     (Object   : Child_Iterator;
2074      Position : Cursor) return Cursor
2075   is
2076   begin
2077      if Position.Container = null then
2078         return No_Element;
2079      end if;
2080
2081      if Checks and then Position.Container /= Object.Container then
2082         raise Program_Error with
2083           "Position cursor of Next designates wrong tree";
2084      end if;
2085
2086      pragma Assert (Object.Container.Count > 0);
2087      pragma Assert (Position.Node /= Root_Node (Object.Container.all));
2088
2089      return Next_Sibling (Position);
2090   end Next;
2091
2092   ------------------
2093   -- Next_Sibling --
2094   ------------------
2095
2096   function Next_Sibling (Position : Cursor) return Cursor is
2097   begin
2098      if Position = No_Element then
2099         return No_Element;
2100      end if;
2101
2102      if Position.Container.Count = 0 then
2103         pragma Assert (Is_Root (Position));
2104         return No_Element;
2105      end if;
2106
2107      declare
2108         T  : Tree renames Position.Container.all;
2109         NN : Tree_Node_Array renames T.Nodes;
2110         N  : Tree_Node_Type renames NN (Position.Node);
2111
2112      begin
2113         if N.Next <= 0 then
2114            return No_Element;
2115         end if;
2116
2117         return Cursor'(Position.Container, N.Next);
2118      end;
2119   end Next_Sibling;
2120
2121   procedure Next_Sibling (Position : in out Cursor) is
2122   begin
2123      Position := Next_Sibling (Position);
2124   end Next_Sibling;
2125
2126   ----------------
2127   -- Node_Count --
2128   ----------------
2129
2130   function Node_Count (Container : Tree) return Count_Type is
2131   begin
2132      --  Container.Count is the number of nodes we have actually allocated. We
2133      --  cache the value specifically so this Node_Count operation can execute
2134      --  in O(1) time, which makes it behave similarly to how the Length
2135      --  selector function behaves for other containers.
2136      --
2137      --  The cached node count value only describes the nodes we have
2138      --  allocated; the root node itself is not included in that count. The
2139      --  Node_Count operation returns a value that includes the root node
2140      --  (because the RM says so), so we must add 1 to our cached value.
2141
2142      return 1 + Container.Count;
2143   end Node_Count;
2144
2145   ------------
2146   -- Parent --
2147   ------------
2148
2149   function Parent (Position : Cursor) return Cursor is
2150   begin
2151      if Position = No_Element then
2152         return No_Element;
2153      end if;
2154
2155      if Position.Container.Count = 0 then
2156         pragma Assert (Is_Root (Position));
2157         return No_Element;
2158      end if;
2159
2160      declare
2161         T  : Tree renames Position.Container.all;
2162         NN : Tree_Node_Array renames T.Nodes;
2163         N  : Tree_Node_Type renames NN (Position.Node);
2164
2165      begin
2166         if N.Parent < 0 then
2167            pragma Assert (Position.Node = Root_Node (T));
2168            return No_Element;
2169         end if;
2170
2171         return Cursor'(Position.Container, N.Parent);
2172      end;
2173   end Parent;
2174
2175   -------------------
2176   -- Prepend_Child --
2177   -------------------
2178
2179   procedure Prepend_Child
2180     (Container : in out Tree;
2181      Parent    : Cursor;
2182      New_Item  : Element_Type;
2183      Count     : Count_Type := 1)
2184   is
2185      Nodes       : Tree_Node_Array renames Container.Nodes;
2186      First, Last : Count_Type;
2187
2188   begin
2189      if Checks and then Parent = No_Element then
2190         raise Constraint_Error with "Parent cursor has no element";
2191      end if;
2192
2193      if Checks and then Parent.Container /= Container'Unrestricted_Access then
2194         raise Program_Error with "Parent cursor not in container";
2195      end if;
2196
2197      if Count = 0 then
2198         return;
2199      end if;
2200
2201      if Checks and then Container.Count > Container.Capacity - Count then
2202         raise Capacity_Error
2203           with "requested count exceeds available storage";
2204      end if;
2205
2206      TC_Check (Container.TC);
2207
2208      if Container.Count = 0 then
2209         Initialize_Root (Container);
2210      end if;
2211
2212      Allocate_Node (Container, New_Item, First);
2213      Nodes (First).Parent := Parent.Node;
2214
2215      Last := First;
2216      for J in Count_Type'(2) .. Count loop
2217         Allocate_Node (Container, New_Item, Nodes (Last).Next);
2218         Nodes (Nodes (Last).Next).Parent := Parent.Node;
2219         Nodes (Nodes (Last).Next).Prev := Last;
2220
2221         Last := Nodes (Last).Next;
2222      end loop;
2223
2224      Insert_Subtree_List
2225        (Container => Container,
2226         First     => First,
2227         Last      => Last,
2228         Parent    => Parent.Node,
2229         Before    => Nodes (Parent.Node).Children.First);
2230
2231      Container.Count := Container.Count + Count;
2232   end Prepend_Child;
2233
2234   --------------
2235   -- Previous --
2236   --------------
2237
2238   overriding function Previous
2239     (Object   : Child_Iterator;
2240      Position : Cursor) return Cursor
2241   is
2242   begin
2243      if Position.Container = null then
2244         return No_Element;
2245      end if;
2246
2247      if Checks and then Position.Container /= Object.Container then
2248         raise Program_Error with
2249           "Position cursor of Previous designates wrong tree";
2250      end if;
2251
2252      return Previous_Sibling (Position);
2253   end Previous;
2254
2255   ----------------------
2256   -- Previous_Sibling --
2257   ----------------------
2258
2259   function Previous_Sibling (Position : Cursor) return Cursor is
2260   begin
2261      if Position = No_Element then
2262         return No_Element;
2263      end if;
2264
2265      if Position.Container.Count = 0 then
2266         pragma Assert (Is_Root (Position));
2267         return No_Element;
2268      end if;
2269
2270      declare
2271         T  : Tree renames Position.Container.all;
2272         NN : Tree_Node_Array renames T.Nodes;
2273         N  : Tree_Node_Type renames NN (Position.Node);
2274
2275      begin
2276         if N.Prev <= 0 then
2277            return No_Element;
2278         end if;
2279
2280         return Cursor'(Position.Container, N.Prev);
2281      end;
2282   end Previous_Sibling;
2283
2284   procedure Previous_Sibling (Position : in out Cursor) is
2285   begin
2286      Position := Previous_Sibling (Position);
2287   end Previous_Sibling;
2288
2289   ----------------------
2290   -- Pseudo_Reference --
2291   ----------------------
2292
2293   function Pseudo_Reference
2294     (Container : aliased Tree'Class) return Reference_Control_Type
2295   is
2296      TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
2297   begin
2298      return R : constant Reference_Control_Type := (Controlled with TC) do
2299         Lock (TC.all);
2300      end return;
2301   end Pseudo_Reference;
2302
2303   -------------------
2304   -- Query_Element --
2305   -------------------
2306
2307   procedure Query_Element
2308     (Position : Cursor;
2309      Process  : not null access procedure (Element : Element_Type))
2310   is
2311   begin
2312      if Checks and then Position = No_Element then
2313         raise Constraint_Error with "Position cursor has no element";
2314      end if;
2315
2316      if Checks and then Is_Root (Position) then
2317         raise Program_Error with "Position cursor designates root";
2318      end if;
2319
2320      declare
2321         T : Tree renames Position.Container.all'Unrestricted_Access.all;
2322         Lock : With_Lock (T.TC'Unrestricted_Access);
2323      begin
2324         Process (Element => T.Elements (Position.Node));
2325      end;
2326   end Query_Element;
2327
2328   ----------
2329   -- Read --
2330   ----------
2331
2332   procedure Read
2333     (Stream    : not null access Root_Stream_Type'Class;
2334      Container : out Tree)
2335   is
2336      procedure Read_Children (Subtree : Count_Type);
2337
2338      function Read_Subtree
2339        (Parent : Count_Type) return Count_Type;
2340
2341      NN : Tree_Node_Array renames Container.Nodes;
2342
2343      Total_Count : Count_Type'Base;
2344      --  Value read from the stream that says how many elements follow
2345
2346      Read_Count : Count_Type'Base;
2347      --  Actual number of elements read from the stream
2348
2349      -------------------
2350      -- Read_Children --
2351      -------------------
2352
2353      procedure Read_Children (Subtree : Count_Type) is
2354         Count : Count_Type'Base;
2355         --  number of child subtrees
2356
2357         CC : Children_Type;
2358
2359      begin
2360         Count_Type'Read (Stream, Count);
2361
2362         if Checks and then Count < 0 then
2363            raise Program_Error with "attempt to read from corrupt stream";
2364         end if;
2365
2366         if Count = 0 then
2367            return;
2368         end if;
2369
2370         CC.First := Read_Subtree (Parent => Subtree);
2371         CC.Last := CC.First;
2372
2373         for J in Count_Type'(2) .. Count loop
2374            NN (CC.Last).Next := Read_Subtree (Parent => Subtree);
2375            NN (NN (CC.Last).Next).Prev := CC.Last;
2376            CC.Last := NN (CC.Last).Next;
2377         end loop;
2378
2379         --  Now that the allocation and reads have completed successfully, it
2380         --  is safe to link the children to their parent.
2381
2382         NN (Subtree).Children := CC;
2383      end Read_Children;
2384
2385      ------------------
2386      -- Read_Subtree --
2387      ------------------
2388
2389      function Read_Subtree
2390        (Parent : Count_Type) return Count_Type
2391      is
2392         Subtree : Count_Type;
2393
2394      begin
2395         Allocate_Node (Container, Stream, Subtree);
2396         Container.Nodes (Subtree).Parent := Parent;
2397
2398         Read_Count := Read_Count + 1;
2399
2400         Read_Children (Subtree);
2401
2402         return Subtree;
2403      end Read_Subtree;
2404
2405   --  Start of processing for Read
2406
2407   begin
2408      Container.Clear;  -- checks busy bit
2409
2410      Count_Type'Read (Stream, Total_Count);
2411
2412      if Checks and then Total_Count < 0 then
2413         raise Program_Error with "attempt to read from corrupt stream";
2414      end if;
2415
2416      if Total_Count = 0 then
2417         return;
2418      end if;
2419
2420      if Checks and then Total_Count > Container.Capacity then
2421         raise Capacity_Error  -- ???
2422           with "node count in stream exceeds container capacity";
2423      end if;
2424
2425      Initialize_Root (Container);
2426
2427      Read_Count := 0;
2428
2429      Read_Children (Root_Node (Container));
2430
2431      if Checks and then Read_Count /= Total_Count then
2432         raise Program_Error with "attempt to read from corrupt stream";
2433      end if;
2434
2435      Container.Count := Total_Count;
2436   end Read;
2437
2438   procedure Read
2439     (Stream   : not null access Root_Stream_Type'Class;
2440      Position : out Cursor)
2441   is
2442   begin
2443      raise Program_Error with "attempt to read tree cursor from stream";
2444   end Read;
2445
2446   procedure Read
2447     (Stream : not null access Root_Stream_Type'Class;
2448      Item   : out Reference_Type)
2449   is
2450   begin
2451      raise Program_Error with "attempt to stream reference";
2452   end Read;
2453
2454   procedure Read
2455     (Stream : not null access Root_Stream_Type'Class;
2456      Item   : out Constant_Reference_Type)
2457   is
2458   begin
2459      raise Program_Error with "attempt to stream reference";
2460   end Read;
2461
2462   ---------------
2463   -- Reference --
2464   ---------------
2465
2466   function Reference
2467     (Container : aliased in out Tree;
2468      Position  : Cursor) return Reference_Type
2469   is
2470   begin
2471      if Checks and then Position.Container = null then
2472         raise Constraint_Error with
2473           "Position cursor has no element";
2474      end if;
2475
2476      if Checks and then Position.Container /= Container'Unrestricted_Access
2477      then
2478         raise Program_Error with
2479           "Position cursor designates wrong container";
2480      end if;
2481
2482      if Checks and then Position.Node = Root_Node (Container) then
2483         raise Program_Error with "Position cursor designates root";
2484      end if;
2485
2486      --  Implement Vet for multiway tree???
2487      --  pragma Assert (Vet (Position),
2488      --                 "Position cursor in Constant_Reference is bad");
2489
2490      declare
2491         TC : constant Tamper_Counts_Access :=
2492           Container.TC'Unrestricted_Access;
2493      begin
2494         return R : constant Reference_Type :=
2495           (Element => Container.Elements (Position.Node)'Access,
2496            Control => (Controlled with TC))
2497         do
2498            Lock (TC.all);
2499         end return;
2500      end;
2501   end Reference;
2502
2503   --------------------
2504   -- Remove_Subtree --
2505   --------------------
2506
2507   procedure Remove_Subtree
2508     (Container : in out Tree;
2509      Subtree   : Count_Type)
2510   is
2511      NN : Tree_Node_Array renames Container.Nodes;
2512      N  : Tree_Node_Type renames NN (Subtree);
2513      CC : Children_Type renames NN (N.Parent).Children;
2514
2515   begin
2516      --  This is a utility operation to remove a subtree node from its
2517      --  parent's list of children.
2518
2519      if CC.First = Subtree then
2520         pragma Assert (N.Prev <= 0);
2521
2522         if CC.Last = Subtree then
2523            pragma Assert (N.Next <= 0);
2524            CC.First := 0;
2525            CC.Last := 0;
2526
2527         else
2528            CC.First := N.Next;
2529            NN (CC.First).Prev := 0;
2530         end if;
2531
2532      elsif CC.Last = Subtree then
2533         pragma Assert (N.Next <= 0);
2534         CC.Last := N.Prev;
2535         NN (CC.Last).Next := 0;
2536
2537      else
2538         NN (N.Prev).Next := N.Next;
2539         NN (N.Next).Prev := N.Prev;
2540      end if;
2541   end Remove_Subtree;
2542
2543   ----------------------
2544   -- Replace_Element --
2545   ----------------------
2546
2547   procedure Replace_Element
2548     (Container : in out Tree;
2549      Position  : Cursor;
2550      New_Item  : Element_Type)
2551   is
2552   begin
2553      if Checks and then Position = No_Element then
2554         raise Constraint_Error with "Position cursor has no element";
2555      end if;
2556
2557      if Checks and then Position.Container /= Container'Unrestricted_Access
2558      then
2559         raise Program_Error with "Position cursor not in container";
2560      end if;
2561
2562      if Checks and then Is_Root (Position) then
2563         raise Program_Error with "Position cursor designates root";
2564      end if;
2565
2566      TE_Check (Container.TC);
2567
2568      Container.Elements (Position.Node) := New_Item;
2569   end Replace_Element;
2570
2571   ------------------------------
2572   -- Reverse_Iterate_Children --
2573   ------------------------------
2574
2575   procedure Reverse_Iterate_Children
2576     (Parent  : Cursor;
2577      Process : not null access procedure (Position : Cursor))
2578   is
2579   begin
2580      if Checks and then Parent = No_Element then
2581         raise Constraint_Error with "Parent cursor has no element";
2582      end if;
2583
2584      if Parent.Container.Count = 0 then
2585         pragma Assert (Is_Root (Parent));
2586         return;
2587      end if;
2588
2589      declare
2590         NN : Tree_Node_Array renames Parent.Container.Nodes;
2591         Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
2592         C  : Count_Type;
2593
2594      begin
2595         C := NN (Parent.Node).Children.Last;
2596         while C > 0 loop
2597            Process (Cursor'(Parent.Container, Node => C));
2598            C := NN (C).Prev;
2599         end loop;
2600      end;
2601   end Reverse_Iterate_Children;
2602
2603   ----------
2604   -- Root --
2605   ----------
2606
2607   function Root (Container : Tree) return Cursor is
2608   begin
2609      return (Container'Unrestricted_Access, Root_Node (Container));
2610   end Root;
2611
2612   ---------------
2613   -- Root_Node --
2614   ---------------
2615
2616   function Root_Node (Container : Tree) return Count_Type is
2617      pragma Unreferenced (Container);
2618
2619   begin
2620      return 0;
2621   end Root_Node;
2622
2623   ---------------------
2624   -- Splice_Children --
2625   ---------------------
2626
2627   procedure Splice_Children
2628     (Target        : in out Tree;
2629      Target_Parent : Cursor;
2630      Before        : Cursor;
2631      Source        : in out Tree;
2632      Source_Parent : Cursor)
2633   is
2634   begin
2635      if Checks and then Target_Parent = No_Element then
2636         raise Constraint_Error with "Target_Parent cursor has no element";
2637      end if;
2638
2639      if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
2640      then
2641         raise Program_Error
2642           with "Target_Parent cursor not in Target container";
2643      end if;
2644
2645      if Before /= No_Element then
2646         if Checks and then Before.Container /= Target'Unrestricted_Access then
2647            raise Program_Error
2648              with "Before cursor not in Target container";
2649         end if;
2650
2651         if Checks and then
2652           Target.Nodes (Before.Node).Parent /= Target_Parent.Node
2653         then
2654            raise Constraint_Error
2655              with "Before cursor not child of Target_Parent";
2656         end if;
2657      end if;
2658
2659      if Checks and then Source_Parent = No_Element then
2660         raise Constraint_Error with "Source_Parent cursor has no element";
2661      end if;
2662
2663      if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
2664      then
2665         raise Program_Error
2666           with "Source_Parent cursor not in Source container";
2667      end if;
2668
2669      if Source.Count = 0 then
2670         pragma Assert (Is_Root (Source_Parent));
2671         return;
2672      end if;
2673
2674      if Target'Address = Source'Address then
2675         if Target_Parent = Source_Parent then
2676            return;
2677         end if;
2678
2679         TC_Check (Target.TC);
2680
2681         if Checks and then Is_Reachable (Container => Target,
2682                          From      => Target_Parent.Node,
2683                          To        => Source_Parent.Node)
2684         then
2685            raise Constraint_Error
2686              with "Source_Parent is ancestor of Target_Parent";
2687         end if;
2688
2689         Splice_Children
2690           (Container     => Target,
2691            Target_Parent => Target_Parent.Node,
2692            Before        => Before.Node,
2693            Source_Parent => Source_Parent.Node);
2694
2695         return;
2696      end if;
2697
2698      TC_Check (Target.TC);
2699      TC_Check (Source.TC);
2700
2701      if Target.Count = 0 then
2702         Initialize_Root (Target);
2703      end if;
2704
2705      Splice_Children
2706        (Target        => Target,
2707         Target_Parent => Target_Parent.Node,
2708         Before        => Before.Node,
2709         Source        => Source,
2710         Source_Parent => Source_Parent.Node);
2711   end Splice_Children;
2712
2713   procedure Splice_Children
2714     (Container       : in out Tree;
2715      Target_Parent   : Cursor;
2716      Before          : Cursor;
2717      Source_Parent   : Cursor)
2718   is
2719   begin
2720      if Checks and then Target_Parent = No_Element then
2721         raise Constraint_Error with "Target_Parent cursor has no element";
2722      end if;
2723
2724      if Checks and then
2725        Target_Parent.Container /= Container'Unrestricted_Access
2726      then
2727         raise Program_Error
2728           with "Target_Parent cursor not in container";
2729      end if;
2730
2731      if Before /= No_Element then
2732         if Checks and then Before.Container /= Container'Unrestricted_Access
2733         then
2734            raise Program_Error
2735              with "Before cursor not in container";
2736         end if;
2737
2738         if Checks and then
2739           Container.Nodes (Before.Node).Parent /= Target_Parent.Node
2740         then
2741            raise Constraint_Error
2742              with "Before cursor not child of Target_Parent";
2743         end if;
2744      end if;
2745
2746      if Checks and then Source_Parent = No_Element then
2747         raise Constraint_Error with "Source_Parent cursor has no element";
2748      end if;
2749
2750      if Checks and then
2751        Source_Parent.Container /= Container'Unrestricted_Access
2752      then
2753         raise Program_Error
2754           with "Source_Parent cursor not in container";
2755      end if;
2756
2757      if Target_Parent = Source_Parent then
2758         return;
2759      end if;
2760
2761      pragma Assert (Container.Count > 0);
2762
2763      TC_Check (Container.TC);
2764
2765      if Checks and then Is_Reachable (Container => Container,
2766                       From      => Target_Parent.Node,
2767                       To        => Source_Parent.Node)
2768      then
2769         raise Constraint_Error
2770           with "Source_Parent is ancestor of Target_Parent";
2771      end if;
2772
2773      Splice_Children
2774        (Container     => Container,
2775         Target_Parent => Target_Parent.Node,
2776         Before        => Before.Node,
2777         Source_Parent => Source_Parent.Node);
2778   end Splice_Children;
2779
2780   procedure Splice_Children
2781     (Container     : in out Tree;
2782      Target_Parent : Count_Type;
2783      Before        : Count_Type'Base;
2784      Source_Parent : Count_Type)
2785   is
2786      NN : Tree_Node_Array renames Container.Nodes;
2787      CC : constant Children_Type := NN (Source_Parent).Children;
2788      C  : Count_Type'Base;
2789
2790   begin
2791      --  This is a utility operation to remove the children from Source parent
2792      --  and insert them into Target parent.
2793
2794      NN (Source_Parent).Children := Children_Type'(others => 0);
2795
2796      --  Fix up the Parent pointers of each child to designate its new Target
2797      --  parent.
2798
2799      C := CC.First;
2800      while C > 0 loop
2801         NN (C).Parent := Target_Parent;
2802         C := NN (C).Next;
2803      end loop;
2804
2805      Insert_Subtree_List
2806        (Container => Container,
2807         First     => CC.First,
2808         Last      => CC.Last,
2809         Parent    => Target_Parent,
2810         Before    => Before);
2811   end Splice_Children;
2812
2813   procedure Splice_Children
2814     (Target        : in out Tree;
2815      Target_Parent : Count_Type;
2816      Before        : Count_Type'Base;
2817      Source        : in out Tree;
2818      Source_Parent : Count_Type)
2819   is
2820      S_NN : Tree_Node_Array renames Source.Nodes;
2821      S_CC : Children_Type renames S_NN (Source_Parent).Children;
2822
2823      Target_Count, Source_Count : Count_Type;
2824      T, S                       : Count_Type'Base;
2825
2826   begin
2827      --  This is a utility operation to copy the children from the Source
2828      --  parent and insert them as children of the Target parent, and then
2829      --  delete them from the Source. (This is not a true splice operation,
2830      --  but it is the best we can do in a bounded form.) The Before position
2831      --  specifies where among the Target parent's exising children the new
2832      --  children are inserted.
2833
2834      --  Before we attempt the insertion, we must count the sources nodes in
2835      --  order to determine whether the target have enough storage
2836      --  available. Note that calculating this value is an O(n) operation.
2837
2838      --  Here is an optimization opportunity: iterate of each children the
2839      --  source explicitly, and keep a running count of the total number of
2840      --  nodes. Compare the running total to the capacity of the target each
2841      --  pass through the loop. This is more efficient than summing the counts
2842      --  of child subtree (which is what Subtree_Node_Count does) and then
2843      --  comparing that total sum to the target's capacity.  ???
2844
2845      --  Here is another possibility. We currently treat the splice as an
2846      --  all-or-nothing proposition: either we can insert all of children of
2847      --  the source, or we raise exception with modifying the target. The
2848      --  price for not causing side-effect is an O(n) determination of the
2849      --  source count. If we are willing to tolerate side-effect, then we
2850      --  could loop over the children of the source, counting that subtree and
2851      --  then immediately inserting it in the target. The issue here is that
2852      --  the test for available storage could fail during some later pass,
2853      --  after children have already been inserted into target. ???
2854
2855      Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1;
2856
2857      if Source_Count = 0 then
2858         return;
2859      end if;
2860
2861      if Checks and then Target.Count > Target.Capacity - Source_Count then
2862         raise Capacity_Error  -- ???
2863           with "Source count exceeds available storage on Target";
2864      end if;
2865
2866      --  Copy_Subtree returns a count of the number of nodes it inserts, but
2867      --  it does this by incrementing the value passed in. Therefore we must
2868      --  initialize the count before calling Copy_Subtree.
2869
2870      Target_Count := 0;
2871
2872      S := S_CC.First;
2873      while S > 0 loop
2874         Copy_Subtree
2875           (Source         => Source,
2876            Source_Subtree => S,
2877            Target         => Target,
2878            Target_Parent  => Target_Parent,
2879            Target_Subtree => T,
2880            Count          => Target_Count);
2881
2882         Insert_Subtree_Node
2883           (Container => Target,
2884            Subtree   => T,
2885            Parent    => Target_Parent,
2886            Before    => Before);
2887
2888         S := S_NN (S).Next;
2889      end loop;
2890
2891      pragma Assert (Target_Count = Source_Count);
2892      Target.Count := Target.Count + Target_Count;
2893
2894      --  As with Copy_Subtree, operation Deallocate_Children returns a count
2895      --  of the number of nodes it deallocates, but it works by incrementing
2896      --  the value passed in. We must therefore initialize the count before
2897      --  calling it.
2898
2899      Source_Count := 0;
2900
2901      Deallocate_Children (Source, Source_Parent, Source_Count);
2902      pragma Assert (Source_Count = Target_Count);
2903
2904      Source.Count := Source.Count - Source_Count;
2905   end Splice_Children;
2906
2907   --------------------
2908   -- Splice_Subtree --
2909   --------------------
2910
2911   procedure Splice_Subtree
2912     (Target   : in out Tree;
2913      Parent   : Cursor;
2914      Before   : Cursor;
2915      Source   : in out Tree;
2916      Position : in out Cursor)
2917   is
2918   begin
2919      if Checks and then Parent = No_Element then
2920         raise Constraint_Error with "Parent cursor has no element";
2921      end if;
2922
2923      if Checks and then Parent.Container /= Target'Unrestricted_Access then
2924         raise Program_Error with "Parent cursor not in Target container";
2925      end if;
2926
2927      if Before /= No_Element then
2928         if Checks and then Before.Container /= Target'Unrestricted_Access then
2929            raise Program_Error with "Before cursor not in Target container";
2930         end if;
2931
2932         if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node
2933         then
2934            raise Constraint_Error with "Before cursor not child of Parent";
2935         end if;
2936      end if;
2937
2938      if Checks and then Position = No_Element then
2939         raise Constraint_Error with "Position cursor has no element";
2940      end if;
2941
2942      if Checks and then Position.Container /= Source'Unrestricted_Access then
2943         raise Program_Error with "Position cursor not in Source container";
2944      end if;
2945
2946      if Checks and then Is_Root (Position) then
2947         raise Program_Error with "Position cursor designates root";
2948      end if;
2949
2950      if Target'Address = Source'Address then
2951         if Target.Nodes (Position.Node).Parent = Parent.Node then
2952            if Before = No_Element then
2953               if Target.Nodes (Position.Node).Next <= 0 then  -- last child
2954                  return;
2955               end if;
2956
2957            elsif Position.Node = Before.Node then
2958               return;
2959
2960            elsif Target.Nodes (Position.Node).Next = Before.Node then
2961               return;
2962            end if;
2963         end if;
2964
2965         TC_Check (Target.TC);
2966
2967         if Checks and then Is_Reachable (Container => Target,
2968                          From      => Parent.Node,
2969                          To        => Position.Node)
2970         then
2971            raise Constraint_Error with "Position is ancestor of Parent";
2972         end if;
2973
2974         Remove_Subtree (Target, Position.Node);
2975
2976         Target.Nodes (Position.Node).Parent := Parent.Node;
2977         Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node);
2978
2979         return;
2980      end if;
2981
2982      TC_Check (Target.TC);
2983      TC_Check (Source.TC);
2984
2985      if Target.Count = 0 then
2986         Initialize_Root (Target);
2987      end if;
2988
2989      Splice_Subtree
2990        (Target   => Target,
2991         Parent   => Parent.Node,
2992         Before   => Before.Node,
2993         Source   => Source,
2994         Position => Position.Node);  -- modified during call
2995
2996      Position.Container := Target'Unrestricted_Access;
2997   end Splice_Subtree;
2998
2999   procedure Splice_Subtree
3000     (Container : in out Tree;
3001      Parent    : Cursor;
3002      Before    : Cursor;
3003      Position  : Cursor)
3004   is
3005   begin
3006      if Checks and then Parent = No_Element then
3007         raise Constraint_Error with "Parent cursor has no element";
3008      end if;
3009
3010      if Checks and then Parent.Container /= Container'Unrestricted_Access then
3011         raise Program_Error with "Parent cursor not in container";
3012      end if;
3013
3014      if Before /= No_Element then
3015         if Checks and then Before.Container /= Container'Unrestricted_Access
3016         then
3017            raise Program_Error with "Before cursor not in container";
3018         end if;
3019
3020         if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node
3021         then
3022            raise Constraint_Error with "Before cursor not child of Parent";
3023         end if;
3024      end if;
3025
3026      if Checks and then Position = No_Element then
3027         raise Constraint_Error with "Position cursor has no element";
3028      end if;
3029
3030      if Checks and then Position.Container /= Container'Unrestricted_Access
3031      then
3032         raise Program_Error with "Position cursor not in container";
3033      end if;
3034
3035      if Checks and then Is_Root (Position) then
3036
3037         --  Should this be PE instead?  Need ARG confirmation.  ???
3038
3039         raise Constraint_Error with "Position cursor designates root";
3040      end if;
3041
3042      if Container.Nodes (Position.Node).Parent = Parent.Node then
3043         if Before = No_Element then
3044            if Container.Nodes (Position.Node).Next <= 0 then  -- last child
3045               return;
3046            end if;
3047
3048         elsif Position.Node = Before.Node then
3049            return;
3050
3051         elsif Container.Nodes (Position.Node).Next = Before.Node then
3052            return;
3053         end if;
3054      end if;
3055
3056      TC_Check (Container.TC);
3057
3058      if Checks and then Is_Reachable (Container => Container,
3059                       From      => Parent.Node,
3060                       To        => Position.Node)
3061      then
3062         raise Constraint_Error with "Position is ancestor of Parent";
3063      end if;
3064
3065      Remove_Subtree (Container, Position.Node);
3066      Container.Nodes (Position.Node).Parent := Parent.Node;
3067      Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node);
3068   end Splice_Subtree;
3069
3070   procedure Splice_Subtree
3071     (Target   : in out Tree;
3072      Parent   : Count_Type;
3073      Before   : Count_Type'Base;
3074      Source   : in out Tree;
3075      Position : in out Count_Type)  -- Source on input, Target on output
3076   is
3077      Source_Count : Count_Type := Subtree_Node_Count (Source, Position);
3078      pragma Assert (Source_Count >= 1);
3079
3080      Target_Subtree : Count_Type;
3081      Target_Count   : Count_Type;
3082
3083   begin
3084      --  This is a utility operation to do the heavy lifting associated with
3085      --  splicing a subtree from one tree to another. Note that "splicing"
3086      --  is a bit of a misnomer here in the case of a bounded tree, because
3087      --  the elements must be copied from the source to the target.
3088
3089      if Checks and then Target.Count > Target.Capacity - Source_Count then
3090         raise Capacity_Error  -- ???
3091           with "Source count exceeds available storage on Target";
3092      end if;
3093
3094      --  Copy_Subtree returns a count of the number of nodes it inserts, but
3095      --  it does this by incrementing the value passed in. Therefore we must
3096      --  initialize the count before calling Copy_Subtree.
3097
3098      Target_Count := 0;
3099
3100      Copy_Subtree
3101        (Source         => Source,
3102         Source_Subtree => Position,
3103         Target         => Target,
3104         Target_Parent  => Parent,
3105         Target_Subtree => Target_Subtree,
3106         Count          => Target_Count);
3107
3108      pragma Assert (Target_Count = Source_Count);
3109
3110      --  Now link the newly-allocated subtree into the target.
3111
3112      Insert_Subtree_Node
3113        (Container => Target,
3114         Subtree   => Target_Subtree,
3115         Parent    => Parent,
3116         Before    => Before);
3117
3118      Target.Count := Target.Count + Target_Count;
3119
3120      --  The manipulation of the Target container is complete. Now we remove
3121      --  the subtree from the Source container.
3122
3123      Remove_Subtree (Source, Position);  -- unlink the subtree
3124
3125      --  As with Copy_Subtree, operation Deallocate_Subtree returns a count of
3126      --  the number of nodes it deallocates, but it works by incrementing the
3127      --  value passed in. We must therefore initialize the count before
3128      --  calling it.
3129
3130      Source_Count := 0;
3131
3132      Deallocate_Subtree (Source, Position, Source_Count);
3133      pragma Assert (Source_Count = Target_Count);
3134
3135      Source.Count := Source.Count - Source_Count;
3136
3137      Position := Target_Subtree;
3138   end Splice_Subtree;
3139
3140   ------------------------
3141   -- Subtree_Node_Count --
3142   ------------------------
3143
3144   function Subtree_Node_Count (Position : Cursor) return Count_Type is
3145   begin
3146      if Position = No_Element then
3147         return 0;
3148      end if;
3149
3150      if Position.Container.Count = 0 then
3151         pragma Assert (Is_Root (Position));
3152         return 1;
3153      end if;
3154
3155      return Subtree_Node_Count (Position.Container.all, Position.Node);
3156   end Subtree_Node_Count;
3157
3158   function Subtree_Node_Count
3159     (Container : Tree;
3160      Subtree   : Count_Type) return Count_Type
3161   is
3162      Result : Count_Type;
3163      Node   : Count_Type'Base;
3164
3165   begin
3166      Result := 1;
3167      Node := Container.Nodes (Subtree).Children.First;
3168      while Node > 0 loop
3169         Result := Result + Subtree_Node_Count (Container, Node);
3170         Node := Container.Nodes (Node).Next;
3171      end loop;
3172      return Result;
3173   end Subtree_Node_Count;
3174
3175   ----------
3176   -- Swap --
3177   ----------
3178
3179   procedure Swap
3180     (Container : in out Tree;
3181      I, J      : Cursor)
3182   is
3183   begin
3184      if Checks and then I = No_Element then
3185         raise Constraint_Error with "I cursor has no element";
3186      end if;
3187
3188      if Checks and then I.Container /= Container'Unrestricted_Access then
3189         raise Program_Error with "I cursor not in container";
3190      end if;
3191
3192      if Checks and then Is_Root (I) then
3193         raise Program_Error with "I cursor designates root";
3194      end if;
3195
3196      if I = J then -- make this test sooner???
3197         return;
3198      end if;
3199
3200      if Checks and then J = No_Element then
3201         raise Constraint_Error with "J cursor has no element";
3202      end if;
3203
3204      if Checks and then J.Container /= Container'Unrestricted_Access then
3205         raise Program_Error with "J cursor not in container";
3206      end if;
3207
3208      if Checks and then Is_Root (J) then
3209         raise Program_Error with "J cursor designates root";
3210      end if;
3211
3212      TE_Check (Container.TC);
3213
3214      declare
3215         EE : Element_Array renames Container.Elements;
3216         EI : constant Element_Type := EE (I.Node);
3217
3218      begin
3219         EE (I.Node) := EE (J.Node);
3220         EE (J.Node) := EI;
3221      end;
3222   end Swap;
3223
3224   --------------------
3225   -- Update_Element --
3226   --------------------
3227
3228   procedure Update_Element
3229     (Container : in out Tree;
3230      Position  : Cursor;
3231      Process   : not null access procedure (Element : in out Element_Type))
3232   is
3233   begin
3234      if Checks and then Position = No_Element then
3235         raise Constraint_Error with "Position cursor has no element";
3236      end if;
3237
3238      if Checks and then Position.Container /= Container'Unrestricted_Access
3239      then
3240         raise Program_Error with "Position cursor not in container";
3241      end if;
3242
3243      if Checks and then Is_Root (Position) then
3244         raise Program_Error with "Position cursor designates root";
3245      end if;
3246
3247      declare
3248         T : Tree renames Position.Container.all'Unrestricted_Access.all;
3249         Lock : With_Lock (T.TC'Unrestricted_Access);
3250      begin
3251         Process (Element => T.Elements (Position.Node));
3252      end;
3253   end Update_Element;
3254
3255   -----------
3256   -- Write --
3257   -----------
3258
3259   procedure Write
3260     (Stream    : not null access Root_Stream_Type'Class;
3261      Container : Tree)
3262   is
3263      procedure Write_Children (Subtree : Count_Type);
3264      procedure Write_Subtree (Subtree : Count_Type);
3265
3266      --------------------
3267      -- Write_Children --
3268      --------------------
3269
3270      procedure Write_Children (Subtree : Count_Type) is
3271         CC : Children_Type renames Container.Nodes (Subtree).Children;
3272         C  : Count_Type'Base;
3273
3274      begin
3275         Count_Type'Write (Stream, Child_Count (Container, Subtree));
3276
3277         C := CC.First;
3278         while C > 0 loop
3279            Write_Subtree (C);
3280            C := Container.Nodes (C).Next;
3281         end loop;
3282      end Write_Children;
3283
3284      -------------------
3285      -- Write_Subtree --
3286      -------------------
3287
3288      procedure Write_Subtree (Subtree : Count_Type) is
3289      begin
3290         Element_Type'Write (Stream, Container.Elements (Subtree));
3291         Write_Children (Subtree);
3292      end Write_Subtree;
3293
3294   --  Start of processing for Write
3295
3296   begin
3297      Count_Type'Write (Stream, Container.Count);
3298
3299      if Container.Count = 0 then
3300         return;
3301      end if;
3302
3303      Write_Children (Root_Node (Container));
3304   end Write;
3305
3306   procedure Write
3307     (Stream   : not null access Root_Stream_Type'Class;
3308      Position : Cursor)
3309   is
3310   begin
3311      raise Program_Error with "attempt to write tree cursor to stream";
3312   end Write;
3313
3314   procedure Write
3315     (Stream : not null access Root_Stream_Type'Class;
3316      Item   : Reference_Type)
3317   is
3318   begin
3319      raise Program_Error with "attempt to stream reference";
3320   end Write;
3321
3322   procedure Write
3323     (Stream : not null access Root_Stream_Type'Class;
3324      Item   : Constant_Reference_Type)
3325   is
3326   begin
3327      raise Program_Error with "attempt to stream reference";
3328   end Write;
3329
3330end Ada.Containers.Bounded_Multiway_Trees;
3331