aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/a-comutr.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/a-comutr.adb')
-rw-r--r--gcc-4.9/gcc/ada/a-comutr.adb2807
1 files changed, 2807 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/a-comutr.adb b/gcc-4.9/gcc/ada/a-comutr.adb
new file mode 100644
index 000000000..01e7e1c80
--- /dev/null
+++ b/gcc-4.9/gcc/ada/a-comutr.adb
@@ -0,0 +1,2807 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Multiway_Trees is
+
+ --------------------
+ -- Root_Iterator --
+ --------------------
+
+ type Root_Iterator is abstract new Limited_Controlled and
+ Tree_Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Tree_Access;
+ Subtree : Tree_Node_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Root_Iterator);
+
+ -----------------------
+ -- Subtree_Iterator --
+ -----------------------
+
+ -- ??? these headers are a bit odd, but for sure they do not substitute
+ -- for documenting things, what *is* a Subtree_Iterator?
+
+ type Subtree_Iterator is new Root_Iterator with null record;
+
+ overriding function First (Object : Subtree_Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Subtree_Iterator;
+ Position : Cursor) return Cursor;
+
+ ---------------------
+ -- Child_Iterator --
+ ---------------------
+
+ type Child_Iterator is new Root_Iterator and
+ Tree_Iterator_Interfaces.Reversible_Iterator with null record;
+
+ overriding function First (Object : Child_Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Child_Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Last (Object : Child_Iterator) return Cursor;
+
+ overriding function Previous
+ (Object : Child_Iterator;
+ Position : Cursor) return Cursor;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Root_Node (Container : Tree) return Tree_Node_Access;
+
+ procedure Deallocate_Node is
+ new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
+
+ procedure Deallocate_Children
+ (Subtree : Tree_Node_Access;
+ Count : in out Count_Type);
+
+ procedure Deallocate_Subtree
+ (Subtree : in out Tree_Node_Access;
+ Count : in out Count_Type);
+
+ function Equal_Children
+ (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
+
+ function Equal_Subtree
+ (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
+
+ procedure Iterate_Children
+ (Container : Tree_Access;
+ Subtree : Tree_Node_Access;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Iterate_Subtree
+ (Container : Tree_Access;
+ Subtree : Tree_Node_Access;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Copy_Children
+ (Source : Children_Type;
+ Parent : Tree_Node_Access;
+ Count : in out Count_Type);
+
+ procedure Copy_Subtree
+ (Source : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Target : out Tree_Node_Access;
+ Count : in out Count_Type);
+
+ function Find_In_Children
+ (Subtree : Tree_Node_Access;
+ Item : Element_Type) return Tree_Node_Access;
+
+ function Find_In_Subtree
+ (Subtree : Tree_Node_Access;
+ Item : Element_Type) return Tree_Node_Access;
+
+ function Child_Count (Children : Children_Type) return Count_Type;
+
+ function Subtree_Node_Count
+ (Subtree : Tree_Node_Access) return Count_Type;
+
+ function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
+
+ procedure Remove_Subtree (Subtree : Tree_Node_Access);
+
+ procedure Insert_Subtree_Node
+ (Subtree : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Before : Tree_Node_Access);
+
+ procedure Insert_Subtree_List
+ (First : Tree_Node_Access;
+ Last : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Before : Tree_Node_Access);
+
+ procedure Splice_Children
+ (Target_Parent : Tree_Node_Access;
+ Before : Tree_Node_Access;
+ Source_Parent : Tree_Node_Access);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Tree) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ return Equal_Children (Root_Node (Left), Root_Node (Right));
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Container : in out Tree) is
+ Source : constant Children_Type := Container.Root.Children;
+ Source_Count : constant Count_Type := Container.Count;
+ Target_Count : Count_Type;
+
+ begin
+ -- We first restore the target container to its default-initialized
+ -- state, before we attempt any allocation, to ensure that invariants
+ -- are preserved in the event that the allocation fails.
+
+ Container.Root.Children := Children_Type'(others => null);
+ Container.Busy := 0;
+ Container.Lock := 0;
+ Container.Count := 0;
+
+ -- Copy_Children returns a count of the number of nodes that it
+ -- allocates, but it works by incrementing the value that is passed
+ -- in. We must therefore initialize the count value before calling
+ -- Copy_Children.
+
+ Target_Count := 0;
+
+ -- Now we attempt the allocation of subtrees. The invariants are
+ -- satisfied even if the allocation fails.
+
+ Copy_Children (Source, Root_Node (Container), Target_Count);
+ pragma Assert (Target_Count = Source_Count);
+
+ Container.Count := Source_Count;
+ end Adjust;
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ C : Tree renames Control.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ B := B + 1;
+ L := L + 1;
+ end;
+ end if;
+ end Adjust;
+
+ -------------------
+ -- Ancestor_Find --
+ -------------------
+
+ function Ancestor_Find
+ (Position : Cursor;
+ Item : Element_Type) return Cursor
+ is
+ R, N : Tree_Node_Access;
+
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ -- Commented-out pending official ruling from ARG. ???
+
+ -- if Position.Container /= Container'Unrestricted_Access then
+ -- raise Program_Error with "Position cursor not in container";
+ -- end if;
+
+ -- AI-0136 says to raise PE if Position equals the root node. This does
+ -- not seem correct, as this value is just the limiting condition of the
+ -- search. For now we omit this check, pending a ruling from the ARG.???
+
+ -- if Is_Root (Position) then
+ -- raise Program_Error with "Position cursor designates root";
+ -- end if;
+
+ R := Root_Node (Position.Container.all);
+ N := Position.Node;
+ while N /= R loop
+ if N.Element = Item then
+ return Cursor'(Position.Container, N);
+ end if;
+
+ N := N.Parent;
+ end loop;
+
+ return No_Element;
+ end Ancestor_Find;
+
+ ------------------
+ -- Append_Child --
+ ------------------
+
+ procedure Append_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ First, Last : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ First := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => New_Item,
+ others => <>);
+
+ Last := First;
+
+ for J in Count_Type'(2) .. Count loop
+
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => New_Item,
+ others => <>);
+
+ Last := Last.Next;
+ end loop;
+
+ Insert_Subtree_List
+ (First => First,
+ Last => Last,
+ Parent => Parent.Node,
+ Before => null); -- null means "insert at end of list"
+
+ -- In order for operation Node_Count to complete in O(1) time, we cache
+ -- the count value. Here we increment the total count by the number of
+ -- nodes we just inserted.
+
+ Container.Count := Container.Count + Count;
+ end Append_Child;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Tree; Source : Tree) is
+ Source_Count : constant Count_Type := Source.Count;
+ Target_Count : Count_Type;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Target.Clear; -- checks busy bit
+
+ -- Copy_Children returns the number of nodes that it allocates, but it
+ -- does this by incrementing the count value passed in, so we must
+ -- initialize the count before calling Copy_Children.
+
+ Target_Count := 0;
+
+ -- Note that Copy_Children inserts the newly-allocated children into
+ -- their parent list only after the allocation of all the children has
+ -- succeeded. This preserves invariants even if the allocation fails.
+
+ Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
+ pragma Assert (Target_Count = Source_Count);
+
+ Target.Count := Source_Count;
+ end Assign;
+
+ -----------------
+ -- Child_Count --
+ -----------------
+
+ function Child_Count (Parent : Cursor) return Count_Type is
+ begin
+ return (if Parent = No_Element
+ then 0 else Child_Count (Parent.Node.Children));
+ end Child_Count;
+
+ function Child_Count (Children : Children_Type) return Count_Type is
+ Result : Count_Type;
+ Node : Tree_Node_Access;
+
+ begin
+ Result := 0;
+ Node := Children.First;
+ while Node /= null loop
+ Result := Result + 1;
+ Node := Node.Next;
+ end loop;
+
+ return Result;
+ end Child_Count;
+
+ -----------------
+ -- Child_Depth --
+ -----------------
+
+ function Child_Depth (Parent, Child : Cursor) return Count_Type is
+ Result : Count_Type;
+ N : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Child = No_Element then
+ raise Constraint_Error with "Child cursor has no element";
+ end if;
+
+ if Parent.Container /= Child.Container then
+ raise Program_Error with "Parent and Child in different containers";
+ end if;
+
+ Result := 0;
+ N := Child.Node;
+ while N /= Parent.Node loop
+ Result := Result + 1;
+ N := N.Parent;
+
+ if N = null then
+ raise Program_Error with "Parent is not ancestor of Child";
+ end if;
+ end loop;
+
+ return Result;
+ end Child_Depth;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Tree) is
+ Container_Count, Children_Count : Count_Type;
+
+ begin
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ -- We first set the container count to 0, in order to preserve
+ -- invariants in case the deallocation fails. (This works because
+ -- Deallocate_Children immediately removes the children from their
+ -- parent, and then does the actual deallocation.)
+
+ Container_Count := Container.Count;
+ Container.Count := 0;
+
+ -- Deallocate_Children returns the number of nodes that it deallocates,
+ -- but it does this by incrementing the count value that is passed in,
+ -- so we must first initialize the count return value before calling it.
+
+ Children_Count := 0;
+
+ -- See comment above. Deallocate_Children immediately removes the
+ -- children list from their parent node (here, the root of the tree),
+ -- and only after that does it attempt the actual deallocation. So even
+ -- if the deallocation fails, the representation invariants for the tree
+ -- are preserved.
+
+ Deallocate_Children (Root_Node (Container), Children_Count);
+ pragma Assert (Children_Count = Container_Count);
+ end Clear;
+
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Tree;
+ Position : Cursor) return Constant_Reference_Type
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong container";
+ end if;
+
+ if Position.Node = Root_Node (Container) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ -- Implement Vet for multiway tree???
+ -- pragma Assert (Vet (Position),
+ -- "Position cursor in Constant_Reference is bad");
+
+ declare
+ C : Tree renames Position.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => Position.Node.Element'Access,
+ Control => (Controlled with Container'Unrestricted_Access))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
+ end Constant_Reference;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : Tree;
+ Item : Element_Type) return Boolean
+ is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Tree) return Tree is
+ begin
+ return Target : Tree do
+ Copy_Children
+ (Source => Source.Root.Children,
+ Parent => Root_Node (Target),
+ Count => Target.Count);
+
+ pragma Assert (Target.Count = Source.Count);
+ end return;
+ end Copy;
+
+ -------------------
+ -- Copy_Children --
+ -------------------
+
+ procedure Copy_Children
+ (Source : Children_Type;
+ Parent : Tree_Node_Access;
+ Count : in out Count_Type)
+ is
+ pragma Assert (Parent /= null);
+ pragma Assert (Parent.Children.First = null);
+ pragma Assert (Parent.Children.Last = null);
+
+ CC : Children_Type;
+ C : Tree_Node_Access;
+
+ begin
+ -- We special-case the first allocation, in order to establish the
+ -- representation invariants for type Children_Type.
+
+ C := Source.First;
+
+ if C = null then
+ return;
+ end if;
+
+ Copy_Subtree
+ (Source => C,
+ Parent => Parent,
+ Target => CC.First,
+ Count => Count);
+
+ CC.Last := CC.First;
+
+ -- The representation invariants for the Children_Type list have been
+ -- established, so we can now copy the remaining children of Source.
+
+ C := C.Next;
+ while C /= null loop
+ Copy_Subtree
+ (Source => C,
+ Parent => Parent,
+ Target => CC.Last.Next,
+ Count => Count);
+
+ CC.Last.Next.Prev := CC.Last;
+ CC.Last := CC.Last.Next;
+
+ C := C.Next;
+ end loop;
+
+ -- Add the newly-allocated children to their parent list only after the
+ -- allocation has succeeded, so as to preserve invariants of the parent.
+
+ Parent.Children := CC;
+ end Copy_Children;
+
+ ------------------
+ -- Copy_Subtree --
+ ------------------
+
+ procedure Copy_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : Cursor)
+ is
+ Target_Subtree : Tree_Node_Access;
+ Target_Count : Count_Type;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Target'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Target'Unrestricted_Access then
+ raise Program_Error with "Before cursor not in container";
+ end if;
+
+ if Before.Node.Parent /= Parent.Node then
+ raise Constraint_Error with "Before cursor not child of Parent";
+ end if;
+ end if;
+
+ if Source = No_Element then
+ return;
+ end if;
+
+ if Is_Root (Source) then
+ raise Constraint_Error with "Source cursor designates root";
+ end if;
+
+ -- Copy_Subtree returns a count of the number of nodes that it
+ -- allocates, but it works by incrementing the value that is passed
+ -- in. We must therefore initialize the count value before calling
+ -- Copy_Subtree.
+
+ Target_Count := 0;
+
+ Copy_Subtree
+ (Source => Source.Node,
+ Parent => Parent.Node,
+ Target => Target_Subtree,
+ Count => Target_Count);
+
+ pragma Assert (Target_Subtree /= null);
+ pragma Assert (Target_Subtree.Parent = Parent.Node);
+ pragma Assert (Target_Count >= 1);
+
+ Insert_Subtree_Node
+ (Subtree => Target_Subtree,
+ Parent => Parent.Node,
+ Before => Before.Node);
+
+ -- In order for operation Node_Count to complete in O(1) time, we cache
+ -- the count value. Here we increment the total count by the number of
+ -- nodes we just inserted.
+
+ Target.Count := Target.Count + Target_Count;
+ end Copy_Subtree;
+
+ procedure Copy_Subtree
+ (Source : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Target : out Tree_Node_Access;
+ Count : in out Count_Type)
+ is
+ begin
+ Target := new Tree_Node_Type'(Element => Source.Element,
+ Parent => Parent,
+ others => <>);
+
+ Count := Count + 1;
+
+ Copy_Children
+ (Source => Source.Children,
+ Parent => Target,
+ Count => Count);
+ end Copy_Subtree;
+
+ -------------------------
+ -- Deallocate_Children --
+ -------------------------
+
+ procedure Deallocate_Children
+ (Subtree : Tree_Node_Access;
+ Count : in out Count_Type)
+ is
+ pragma Assert (Subtree /= null);
+
+ CC : Children_Type := Subtree.Children;
+ C : Tree_Node_Access;
+
+ begin
+ -- We immediately remove the children from their parent, in order to
+ -- preserve invariants in case the deallocation fails.
+
+ Subtree.Children := Children_Type'(others => null);
+
+ while CC.First /= null loop
+ C := CC.First;
+ CC.First := C.Next;
+
+ Deallocate_Subtree (C, Count);
+ end loop;
+ end Deallocate_Children;
+
+ ------------------------
+ -- Deallocate_Subtree --
+ ------------------------
+
+ procedure Deallocate_Subtree
+ (Subtree : in out Tree_Node_Access;
+ Count : in out Count_Type)
+ is
+ begin
+ Deallocate_Children (Subtree, Count);
+ Deallocate_Node (Subtree);
+ Count := Count + 1;
+ end Deallocate_Subtree;
+
+ ---------------------
+ -- Delete_Children --
+ ---------------------
+
+ procedure Delete_Children
+ (Container : in out Tree;
+ Parent : Cursor)
+ is
+ Count : Count_Type;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ -- Deallocate_Children returns a count of the number of nodes that it
+ -- deallocates, but it works by incrementing the value that is passed
+ -- in. We must therefore initialize the count value before calling
+ -- Deallocate_Children.
+
+ Count := 0;
+
+ Deallocate_Children (Parent.Node, Count);
+ pragma Assert (Count <= Container.Count);
+
+ Container.Count := Container.Count - Count;
+ end Delete_Children;
+
+ -----------------
+ -- Delete_Leaf --
+ -----------------
+
+ procedure Delete_Leaf
+ (Container : in out Tree;
+ Position : in out Cursor)
+ is
+ X : Tree_Node_Access;
+
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in container";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ if not Is_Leaf (Position) then
+ raise Constraint_Error with "Position cursor does not designate leaf";
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ X := Position.Node;
+ Position := No_Element;
+
+ -- Restore represention invariants before attempting the actual
+ -- deallocation.
+
+ Remove_Subtree (X);
+ Container.Count := Container.Count - 1;
+
+ -- It is now safe to attempt the deallocation. This leaf node has been
+ -- disassociated from the tree, so even if the deallocation fails,
+ -- representation invariants will remain satisfied.
+
+ Deallocate_Node (X);
+ end Delete_Leaf;
+
+ --------------------
+ -- Delete_Subtree --
+ --------------------
+
+ procedure Delete_Subtree
+ (Container : in out Tree;
+ Position : in out Cursor)
+ is
+ X : Tree_Node_Access;
+ Count : Count_Type;
+
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in container";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ X := Position.Node;
+ Position := No_Element;
+
+ -- Here is one case where a deallocation failure can result in the
+ -- violation of a representation invariant. We disassociate the subtree
+ -- from the tree now, but we only decrement the total node count after
+ -- we attempt the deallocation. However, if the deallocation fails, the
+ -- total node count will not get decremented.
+
+ -- One way around this dilemma is to count the nodes in the subtree
+ -- before attempt to delete the subtree, but that is an O(n) operation,
+ -- so it does not seem worth it.
+
+ -- Perhaps this is much ado about nothing, since the only way
+ -- deallocation can fail is if Controlled Finalization fails: this
+ -- propagates Program_Error so all bets are off anyway. ???
+
+ Remove_Subtree (X);
+
+ -- Deallocate_Subtree returns a count of the number of nodes that it
+ -- deallocates, but it works by incrementing the value that is passed
+ -- in. We must therefore initialize the count value before calling
+ -- Deallocate_Subtree.
+
+ Count := 0;
+
+ Deallocate_Subtree (X, Count);
+ pragma Assert (Count <= Container.Count);
+
+ -- See comments above. We would prefer to do this sooner, but there's no
+ -- way to satisfy that goal without a potentially severe execution
+ -- penalty.
+
+ Container.Count := Container.Count - Count;
+ end Delete_Subtree;
+
+ -----------
+ -- Depth --
+ -----------
+
+ function Depth (Position : Cursor) return Count_Type is
+ Result : Count_Type;
+ N : Tree_Node_Access;
+
+ begin
+ Result := 0;
+ N := Position.Node;
+ while N /= null loop
+ N := N.Parent;
+ Result := Result + 1;
+ end loop;
+
+ return Result;
+ end Depth;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Node = Root_Node (Position.Container.all) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ return Position.Node.Element;
+ end Element;
+
+ --------------------
+ -- Equal_Children --
+ --------------------
+
+ function Equal_Children
+ (Left_Subtree : Tree_Node_Access;
+ Right_Subtree : Tree_Node_Access) return Boolean
+ is
+ Left_Children : Children_Type renames Left_Subtree.Children;
+ Right_Children : Children_Type renames Right_Subtree.Children;
+
+ L, R : Tree_Node_Access;
+
+ begin
+ if Child_Count (Left_Children) /= Child_Count (Right_Children) then
+ return False;
+ end if;
+
+ L := Left_Children.First;
+ R := Right_Children.First;
+ while L /= null loop
+ if not Equal_Subtree (L, R) then
+ return False;
+ end if;
+
+ L := L.Next;
+ R := R.Next;
+ end loop;
+
+ return True;
+ end Equal_Children;
+
+ -------------------
+ -- Equal_Subtree --
+ -------------------
+
+ function Equal_Subtree
+ (Left_Position : Cursor;
+ Right_Position : Cursor) return Boolean
+ is
+ begin
+ if Left_Position = No_Element then
+ raise Constraint_Error with "Left cursor has no element";
+ end if;
+
+ if Right_Position = No_Element then
+ raise Constraint_Error with "Right cursor has no element";
+ end if;
+
+ if Left_Position = Right_Position then
+ return True;
+ end if;
+
+ if Is_Root (Left_Position) then
+ if not Is_Root (Right_Position) then
+ return False;
+ end if;
+
+ return Equal_Children (Left_Position.Node, Right_Position.Node);
+ end if;
+
+ if Is_Root (Right_Position) then
+ return False;
+ end if;
+
+ return Equal_Subtree (Left_Position.Node, Right_Position.Node);
+ end Equal_Subtree;
+
+ function Equal_Subtree
+ (Left_Subtree : Tree_Node_Access;
+ Right_Subtree : Tree_Node_Access) return Boolean
+ is
+ begin
+ if Left_Subtree.Element /= Right_Subtree.Element then
+ return False;
+ end if;
+
+ return Equal_Children (Left_Subtree, Right_Subtree);
+ end Equal_Subtree;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Root_Iterator) is
+ B : Natural renames Object.Container.Busy;
+ begin
+ B := B - 1;
+ end Finalize;
+
+ procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ C : Tree renames Control.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ B := B - 1;
+ L := L - 1;
+ end;
+
+ Control.Container := null;
+ end if;
+ end Finalize;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Tree;
+ Item : Element_Type) return Cursor
+ is
+ N : constant Tree_Node_Access :=
+ Find_In_Children (Root_Node (Container), Item);
+ begin
+ if N = null then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, N);
+ end if;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ overriding function First (Object : Subtree_Iterator) return Cursor is
+ begin
+ if Object.Subtree = Root_Node (Object.Container.all) then
+ return First_Child (Root (Object.Container.all));
+ else
+ return Cursor'(Object.Container, Object.Subtree);
+ end if;
+ end First;
+
+ overriding function First (Object : Child_Iterator) return Cursor is
+ begin
+ return First_Child (Cursor'(Object.Container, Object.Subtree));
+ end First;
+
+ -----------------
+ -- First_Child --
+ -----------------
+
+ function First_Child (Parent : Cursor) return Cursor is
+ Node : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ Node := Parent.Node.Children.First;
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Parent.Container, Node);
+ end First_Child;
+
+ -------------------------
+ -- First_Child_Element --
+ -------------------------
+
+ function First_Child_Element (Parent : Cursor) return Element_Type is
+ begin
+ return Element (First_Child (Parent));
+ end First_Child_Element;
+
+ ----------------------
+ -- Find_In_Children --
+ ----------------------
+
+ function Find_In_Children
+ (Subtree : Tree_Node_Access;
+ Item : Element_Type) return Tree_Node_Access
+ is
+ N, Result : Tree_Node_Access;
+
+ begin
+ N := Subtree.Children.First;
+ while N /= null loop
+ Result := Find_In_Subtree (N, Item);
+
+ if Result /= null then
+ return Result;
+ end if;
+
+ N := N.Next;
+ end loop;
+
+ return null;
+ end Find_In_Children;
+
+ ---------------------
+ -- Find_In_Subtree --
+ ---------------------
+
+ function Find_In_Subtree
+ (Position : Cursor;
+ Item : Element_Type) return Cursor
+ is
+ Result : Tree_Node_Access;
+
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ -- Commented out pending official ruling by ARG. ???
+
+ -- if Position.Container /= Container'Unrestricted_Access then
+ -- raise Program_Error with "Position cursor not in container";
+ -- end if;
+
+ Result :=
+ (if Is_Root (Position)
+ then Find_In_Children (Position.Node, Item)
+ else Find_In_Subtree (Position.Node, Item));
+
+ if Result = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Result);
+ end Find_In_Subtree;
+
+ function Find_In_Subtree
+ (Subtree : Tree_Node_Access;
+ Item : Element_Type) return Tree_Node_Access
+ is
+ begin
+ if Subtree.Element = Item then
+ return Subtree;
+ end if;
+
+ return Find_In_Children (Subtree, Item);
+ end Find_In_Subtree;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return (if Position = No_Element then False
+ else Position.Node.Parent /= null);
+ end Has_Element;
+
+ ------------------
+ -- Insert_Child --
+ ------------------
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ begin
+ Insert_Child (Container, Parent, Before, New_Item, Position, Count);
+ end Insert_Child;
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Last : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Before cursor not in container";
+ end if;
+
+ if Before.Node.Parent /= Parent.Node then
+ raise Constraint_Error with "Parent cursor not parent of Before";
+ end if;
+ end if;
+
+ if Count = 0 then
+ Position := No_Element; -- Need ruling from ARG ???
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ Position.Container := Parent.Container;
+ Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => New_Item,
+ others => <>);
+
+ Last := Position.Node;
+
+ for J in Count_Type'(2) .. Count loop
+
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => New_Item,
+ others => <>);
+
+ Last := Last.Next;
+ end loop;
+
+ Insert_Subtree_List
+ (First => Position.Node,
+ Last => Last,
+ Parent => Parent.Node,
+ Before => Before.Node);
+
+ -- In order for operation Node_Count to complete in O(1) time, we cache
+ -- the count value. Here we increment the total count by the number of
+ -- nodes we just inserted.
+
+ Container.Count := Container.Count + Count;
+ end Insert_Child;
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Last : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Before cursor not in container";
+ end if;
+
+ if Before.Node.Parent /= Parent.Node then
+ raise Constraint_Error with "Parent cursor not parent of Before";
+ end if;
+ end if;
+
+ if Count = 0 then
+ Position := No_Element; -- Need ruling from ARG ???
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ Position.Container := Parent.Container;
+ Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => <>,
+ others => <>);
+
+ Last := Position.Node;
+
+ for J in Count_Type'(2) .. Count loop
+
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => <>,
+ others => <>);
+
+ Last := Last.Next;
+ end loop;
+
+ Insert_Subtree_List
+ (First => Position.Node,
+ Last => Last,
+ Parent => Parent.Node,
+ Before => Before.Node);
+
+ -- In order for operation Node_Count to complete in O(1) time, we cache
+ -- the count value. Here we increment the total count by the number of
+ -- nodes we just inserted.
+
+ Container.Count := Container.Count + Count;
+ end Insert_Child;
+
+ -------------------------
+ -- Insert_Subtree_List --
+ -------------------------
+
+ procedure Insert_Subtree_List
+ (First : Tree_Node_Access;
+ Last : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Before : Tree_Node_Access)
+ is
+ pragma Assert (Parent /= null);
+ C : Children_Type renames Parent.Children;
+
+ begin
+ -- This is a simple utility operation to insert a list of nodes (from
+ -- First..Last) as children of Parent. The Before node specifies where
+ -- the new children should be inserted relative to the existing
+ -- children.
+
+ if First = null then
+ pragma Assert (Last = null);
+ return;
+ end if;
+
+ pragma Assert (Last /= null);
+ pragma Assert (Before = null or else Before.Parent = Parent);
+
+ if C.First = null then
+ C.First := First;
+ C.First.Prev := null;
+ C.Last := Last;
+ C.Last.Next := null;
+
+ elsif Before = null then -- means "insert after existing nodes"
+ C.Last.Next := First;
+ First.Prev := C.Last;
+ C.Last := Last;
+ C.Last.Next := null;
+
+ elsif Before = C.First then
+ Last.Next := C.First;
+ C.First.Prev := Last;
+ C.First := First;
+ C.First.Prev := null;
+
+ else
+ Before.Prev.Next := First;
+ First.Prev := Before.Prev;
+ Last.Next := Before;
+ Before.Prev := Last;
+ end if;
+ end Insert_Subtree_List;
+
+ -------------------------
+ -- Insert_Subtree_Node --
+ -------------------------
+
+ procedure Insert_Subtree_Node
+ (Subtree : Tree_Node_Access;
+ Parent : Tree_Node_Access;
+ Before : Tree_Node_Access)
+ is
+ begin
+ -- This is a simple wrapper operation to insert a single child into the
+ -- Parent's children list.
+
+ Insert_Subtree_List
+ (First => Subtree,
+ Last => Subtree,
+ Parent => Parent,
+ Before => Before);
+ end Insert_Subtree_Node;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Tree) return Boolean is
+ begin
+ return Container.Root.Children.First = null;
+ end Is_Empty;
+
+ -------------
+ -- Is_Leaf --
+ -------------
+
+ function Is_Leaf (Position : Cursor) return Boolean is
+ begin
+ return (if Position = No_Element then False
+ else Position.Node.Children.First = null);
+ end Is_Leaf;
+
+ ------------------
+ -- Is_Reachable --
+ ------------------
+
+ function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
+ pragma Assert (From /= null);
+ pragma Assert (To /= null);
+
+ N : Tree_Node_Access;
+
+ begin
+ N := From;
+ while N /= null loop
+ if N = To then
+ return True;
+ end if;
+
+ N := N.Parent;
+ end loop;
+
+ return False;
+ end Is_Reachable;
+
+ -------------
+ -- Is_Root --
+ -------------
+
+ function Is_Root (Position : Cursor) return Boolean is
+ begin
+ return (if Position.Container = null then False
+ else Position = Root (Position.Container.all));
+ end Is_Root;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Tree;
+ Process : not null access procedure (Position : Cursor))
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
+ begin
+ B := B + 1;
+
+ Iterate_Children
+ (Container => Container'Unrestricted_Access,
+ Subtree => Root_Node (Container),
+ Process => Process);
+
+ B := B - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end Iterate;
+
+ function Iterate (Container : Tree)
+ return Tree_Iterator_Interfaces.Forward_Iterator'Class
+ is
+ begin
+ return Iterate_Subtree (Root (Container));
+ end Iterate;
+
+ ----------------------
+ -- Iterate_Children --
+ ----------------------
+
+ procedure Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ declare
+ B : Natural renames Parent.Container.Busy;
+ C : Tree_Node_Access;
+
+ begin
+ B := B + 1;
+
+ C := Parent.Node.Children.First;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Next;
+ end loop;
+
+ B := B - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+ end Iterate_Children;
+
+ procedure Iterate_Children
+ (Container : Tree_Access;
+ Subtree : Tree_Node_Access;
+ Process : not null access procedure (Position : Cursor))
+ is
+ Node : Tree_Node_Access;
+
+ begin
+ -- This is a helper function to recursively iterate over all the nodes
+ -- in a subtree, in depth-first fashion. This particular helper just
+ -- visits the children of this subtree, not the root of the subtree node
+ -- itself. This is useful when starting from the ultimate root of the
+ -- entire tree (see Iterate), as that root does not have an element.
+
+ Node := Subtree.Children.First;
+ while Node /= null loop
+ Iterate_Subtree (Container, Node, Process);
+ Node := Node.Next;
+ end loop;
+ end Iterate_Children;
+
+ function Iterate_Children
+ (Container : Tree;
+ Parent : Cursor)
+ return Tree_Iterator_Interfaces.Reversible_Iterator'Class
+ is
+ C : constant Tree_Access := Container'Unrestricted_Access;
+ B : Natural renames C.Busy;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= C then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ return It : constant Child_Iterator :=
+ (Limited_Controlled with
+ Container => C,
+ Subtree => Parent.Node)
+ do
+ B := B + 1;
+ end return;
+ end Iterate_Children;
+
+ ---------------------
+ -- Iterate_Subtree --
+ ---------------------
+
+ function Iterate_Subtree
+ (Position : Cursor)
+ return Tree_Iterator_Interfaces.Forward_Iterator'Class
+ is
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ -- Implement Vet for multiway trees???
+ -- pragma Assert (Vet (Position), "bad subtree cursor");
+
+ declare
+ B : Natural renames Position.Container.Busy;
+ begin
+ return It : constant Subtree_Iterator :=
+ (Limited_Controlled with
+ Container => Position.Container,
+ Subtree => Position.Node)
+ do
+ B := B + 1;
+ end return;
+ end;
+ end Iterate_Subtree;
+
+ procedure Iterate_Subtree
+ (Position : Cursor;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ declare
+ B : Natural renames Position.Container.Busy;
+
+ begin
+ B := B + 1;
+
+ if Is_Root (Position) then
+ Iterate_Children (Position.Container, Position.Node, Process);
+ else
+ Iterate_Subtree (Position.Container, Position.Node, Process);
+ end if;
+
+ B := B - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+ end Iterate_Subtree;
+
+ procedure Iterate_Subtree
+ (Container : Tree_Access;
+ Subtree : Tree_Node_Access;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ -- This is a helper function to recursively iterate over all the nodes
+ -- in a subtree, in depth-first fashion. It first visits the root of the
+ -- subtree, then visits its children.
+
+ Process (Cursor'(Container, Subtree));
+ Iterate_Children (Container, Subtree, Process);
+ end Iterate_Subtree;
+
+ ----------
+ -- Last --
+ ----------
+
+ overriding function Last (Object : Child_Iterator) return Cursor is
+ begin
+ return Last_Child (Cursor'(Object.Container, Object.Subtree));
+ end Last;
+
+ ----------------
+ -- Last_Child --
+ ----------------
+
+ function Last_Child (Parent : Cursor) return Cursor is
+ Node : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ Node := Parent.Node.Children.Last;
+
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return (Parent.Container, Node);
+ end Last_Child;
+
+ ------------------------
+ -- Last_Child_Element --
+ ------------------------
+
+ function Last_Child_Element (Parent : Cursor) return Element_Type is
+ begin
+ return Element (Last_Child (Parent));
+ end Last_Child_Element;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Tree; Source : in out Tree) is
+ Node : Tree_Node_Access;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors of Source (tree is busy)";
+ end if;
+
+ Target.Clear; -- checks busy bit
+
+ Target.Root.Children := Source.Root.Children;
+ Source.Root.Children := Children_Type'(others => null);
+
+ Node := Target.Root.Children.First;
+ while Node /= null loop
+ Node.Parent := Root_Node (Target);
+ Node := Node.Next;
+ end loop;
+
+ Target.Count := Source.Count;
+ Source.Count := 0;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next
+ (Object : Subtree_Iterator;
+ Position : Cursor) return Cursor
+ is
+ Node : Tree_Node_Access;
+
+ begin
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong tree";
+ end if;
+
+ Node := Position.Node;
+
+ if Node.Children.First /= null then
+ return Cursor'(Object.Container, Node.Children.First);
+ end if;
+
+ while Node /= Object.Subtree loop
+ if Node.Next /= null then
+ return Cursor'(Object.Container, Node.Next);
+ end if;
+
+ Node := Node.Parent;
+ end loop;
+
+ return No_Element;
+ end Next;
+
+ function Next
+ (Object : Child_Iterator;
+ Position : Cursor) return Cursor
+ is
+ begin
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong tree";
+ end if;
+
+ return Next_Sibling (Position);
+ end Next;
+
+ ------------------
+ -- Next_Sibling --
+ ------------------
+
+ function Next_Sibling (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ if Position.Node.Next = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Position.Node.Next);
+ end Next_Sibling;
+
+ procedure Next_Sibling (Position : in out Cursor) is
+ begin
+ Position := Next_Sibling (Position);
+ end Next_Sibling;
+
+ ----------------
+ -- Node_Count --
+ ----------------
+
+ function Node_Count (Container : Tree) return Count_Type is
+ begin
+ -- Container.Count is the number of nodes we have actually allocated. We
+ -- cache the value specifically so this Node_Count operation can execute
+ -- in O(1) time, which makes it behave similarly to how the Length
+ -- selector function behaves for other containers.
+
+ -- The cached node count value only describes the nodes we have
+ -- allocated; the root node itself is not included in that count. The
+ -- Node_Count operation returns a value that includes the root node
+ -- (because the RM says so), so we must add 1 to our cached value.
+
+ return 1 + Container.Count;
+ end Node_Count;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ if Position.Node.Parent = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Position.Node.Parent);
+ end Parent;
+
+ -------------------
+ -- Prepent_Child --
+ -------------------
+
+ procedure Prepend_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ First, Last : Tree_Node_Access;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ First := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => New_Item,
+ others => <>);
+
+ Last := First;
+
+ for J in Count_Type'(2) .. Count loop
+
+ -- Reclaim other nodes if Storage_Error???
+
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => New_Item,
+ others => <>);
+
+ Last := Last.Next;
+ end loop;
+
+ Insert_Subtree_List
+ (First => First,
+ Last => Last,
+ Parent => Parent.Node,
+ Before => Parent.Node.Children.First);
+
+ -- In order for operation Node_Count to complete in O(1) time, we cache
+ -- the count value. Here we increment the total count by the number of
+ -- nodes we just inserted.
+
+ Container.Count := Container.Count + Count;
+ end Prepend_Child;
+
+ --------------
+ -- Previous --
+ --------------
+
+ overriding function Previous
+ (Object : Child_Iterator;
+ Position : Cursor) return Cursor
+ is
+ begin
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Previous designates wrong tree";
+ end if;
+
+ return Previous_Sibling (Position);
+ end Previous;
+
+ ----------------------
+ -- Previous_Sibling --
+ ----------------------
+
+ function Previous_Sibling (Position : Cursor) return Cursor is
+ begin
+ return
+ (if Position = No_Element then No_Element
+ elsif Position.Node.Prev = null then No_Element
+ else Cursor'(Position.Container, Position.Node.Prev));
+ end Previous_Sibling;
+
+ procedure Previous_Sibling (Position : in out Cursor) is
+ begin
+ Position := Previous_Sibling (Position);
+ end Previous_Sibling;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ declare
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ Process (Position.Node.Element);
+
+ L := L - 1;
+ B := B - 1;
+
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+
+ raise;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Tree)
+ is
+ procedure Read_Children (Subtree : Tree_Node_Access);
+
+ function Read_Subtree
+ (Parent : Tree_Node_Access) return Tree_Node_Access;
+
+ Total_Count : Count_Type'Base;
+ -- Value read from the stream that says how many elements follow
+
+ Read_Count : Count_Type'Base;
+ -- Actual number of elements read from the stream
+
+ -------------------
+ -- Read_Children --
+ -------------------
+
+ procedure Read_Children (Subtree : Tree_Node_Access) is
+ pragma Assert (Subtree /= null);
+ pragma Assert (Subtree.Children.First = null);
+ pragma Assert (Subtree.Children.Last = null);
+
+ Count : Count_Type'Base;
+ -- Number of child subtrees
+
+ C : Children_Type;
+
+ begin
+ Count_Type'Read (Stream, Count);
+
+ if Count < 0 then
+ raise Program_Error with "attempt to read from corrupt stream";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ C.First := Read_Subtree (Parent => Subtree);
+ C.Last := C.First;
+
+ for J in Count_Type'(2) .. Count loop
+ C.Last.Next := Read_Subtree (Parent => Subtree);
+ C.Last.Next.Prev := C.Last;
+ C.Last := C.Last.Next;
+ end loop;
+
+ -- Now that the allocation and reads have completed successfully, it
+ -- is safe to link the children to their parent.
+
+ Subtree.Children := C;
+ end Read_Children;
+
+ ------------------
+ -- Read_Subtree --
+ ------------------
+
+ function Read_Subtree
+ (Parent : Tree_Node_Access) return Tree_Node_Access
+ is
+ Subtree : constant Tree_Node_Access :=
+ new Tree_Node_Type'
+ (Parent => Parent,
+ Element => Element_Type'Input (Stream),
+ others => <>);
+
+ begin
+ Read_Count := Read_Count + 1;
+
+ Read_Children (Subtree);
+
+ return Subtree;
+ end Read_Subtree;
+
+ -- Start of processing for Read
+
+ begin
+ Container.Clear; -- checks busy bit
+
+ Count_Type'Read (Stream, Total_Count);
+
+ if Total_Count < 0 then
+ raise Program_Error with "attempt to read from corrupt stream";
+ end if;
+
+ if Total_Count = 0 then
+ return;
+ end if;
+
+ Read_Count := 0;
+
+ Read_Children (Root_Node (Container));
+
+ if Read_Count /= Total_Count then
+ raise Program_Error with "attempt to read from corrupt stream";
+ end if;
+
+ Container.Count := Total_Count;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to read tree cursor from stream";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : aliased in out Tree;
+ Position : Cursor) return Reference_Type
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong container";
+ end if;
+
+ if Position.Node = Root_Node (Container) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ -- Implement Vet for multiway tree???
+ -- pragma Assert (Vet (Position),
+ -- "Position cursor in Constant_Reference is bad");
+
+ declare
+ C : Tree renames Position.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ return R : constant Reference_Type :=
+ (Element => Position.Node.Element'Access,
+ Control => (Controlled with Position.Container))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
+ end Reference;
+
+ --------------------
+ -- Remove_Subtree --
+ --------------------
+
+ procedure Remove_Subtree (Subtree : Tree_Node_Access) is
+ C : Children_Type renames Subtree.Parent.Children;
+
+ begin
+ -- This is a utility operation to remove a subtree node from its
+ -- parent's list of children.
+
+ if C.First = Subtree then
+ pragma Assert (Subtree.Prev = null);
+
+ if C.Last = Subtree then
+ pragma Assert (Subtree.Next = null);
+ C.First := null;
+ C.Last := null;
+
+ else
+ C.First := Subtree.Next;
+ C.First.Prev := null;
+ end if;
+
+ elsif C.Last = Subtree then
+ pragma Assert (Subtree.Next = null);
+ C.Last := Subtree.Prev;
+ C.Last.Next := null;
+
+ else
+ Subtree.Prev.Next := Subtree.Next;
+ Subtree.Next.Prev := Subtree.Prev;
+ end if;
+ end Remove_Subtree;
+
+ ----------------------
+ -- Replace_Element --
+ ----------------------
+
+ procedure Replace_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in container";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error
+ with "attempt to tamper with elements (tree is locked)";
+ end if;
+
+ Position.Node.Element := New_Item;
+ end Replace_Element;
+
+ ------------------------------
+ -- Reverse_Iterate_Children --
+ ------------------------------
+
+ procedure Reverse_Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor))
+ is
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ declare
+ B : Natural renames Parent.Container.Busy;
+ C : Tree_Node_Access;
+
+ begin
+ B := B + 1;
+
+ C := Parent.Node.Children.Last;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Prev;
+ end loop;
+
+ B := B - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+ end Reverse_Iterate_Children;
+
+ ----------
+ -- Root --
+ ----------
+
+ function Root (Container : Tree) return Cursor is
+ begin
+ return (Container'Unrestricted_Access, Root_Node (Container));
+ end Root;
+
+ ---------------
+ -- Root_Node --
+ ---------------
+
+ function Root_Node (Container : Tree) return Tree_Node_Access is
+ type Root_Node_Access is access all Root_Node_Type;
+ for Root_Node_Access'Storage_Size use 0;
+ pragma Convention (C, Root_Node_Access);
+
+ function To_Tree_Node_Access is
+ new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access);
+
+ -- Start of processing for Root_Node
+
+ begin
+ -- This is a utility function for converting from an access type that
+ -- designates the distinguished root node to an access type designating
+ -- a non-root node. The representation of a root node does not have an
+ -- element, but is otherwise identical to a non-root node, so the
+ -- conversion itself is safe.
+
+ return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
+ end Root_Node;
+
+ ---------------------
+ -- Splice_Children --
+ ---------------------
+
+ procedure Splice_Children
+ (Target : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Source_Parent : Cursor)
+ is
+ Count : Count_Type;
+
+ begin
+ if Target_Parent = No_Element then
+ raise Constraint_Error with "Target_Parent cursor has no element";
+ end if;
+
+ if Target_Parent.Container /= Target'Unrestricted_Access then
+ raise Program_Error
+ with "Target_Parent cursor not in Target container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Target'Unrestricted_Access then
+ raise Program_Error
+ with "Before cursor not in Target container";
+ end if;
+
+ if Before.Node.Parent /= Target_Parent.Node then
+ raise Constraint_Error
+ with "Before cursor not child of Target_Parent";
+ end if;
+ end if;
+
+ if Source_Parent = No_Element then
+ raise Constraint_Error with "Source_Parent cursor has no element";
+ end if;
+
+ if Source_Parent.Container /= Source'Unrestricted_Access then
+ raise Program_Error
+ with "Source_Parent cursor not in Source container";
+ end if;
+
+ if Target'Address = Source'Address then
+ if Target_Parent = Source_Parent then
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Target tree is busy)";
+ end if;
+
+ if Is_Reachable (From => Target_Parent.Node,
+ To => Source_Parent.Node)
+ then
+ raise Constraint_Error
+ with "Source_Parent is ancestor of Target_Parent";
+ end if;
+
+ Splice_Children
+ (Target_Parent => Target_Parent.Node,
+ Before => Before.Node,
+ Source_Parent => Source_Parent.Node);
+
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Target tree is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Source tree is busy)";
+ end if;
+
+ -- We cache the count of the nodes we have allocated, so that operation
+ -- Node_Count can execute in O(1) time. But that means we must count the
+ -- nodes in the subtree we remove from Source and insert into Target, in
+ -- order to keep the count accurate.
+
+ Count := Subtree_Node_Count (Source_Parent.Node);
+ pragma Assert (Count >= 1);
+
+ Count := Count - 1; -- because Source_Parent node does not move
+
+ Splice_Children
+ (Target_Parent => Target_Parent.Node,
+ Before => Before.Node,
+ Source_Parent => Source_Parent.Node);
+
+ Source.Count := Source.Count - Count;
+ Target.Count := Target.Count + Count;
+ end Splice_Children;
+
+ procedure Splice_Children
+ (Container : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source_Parent : Cursor)
+ is
+ begin
+ if Target_Parent = No_Element then
+ raise Constraint_Error with "Target_Parent cursor has no element";
+ end if;
+
+ if Target_Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error
+ with "Target_Parent cursor not in container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Container'Unrestricted_Access then
+ raise Program_Error
+ with "Before cursor not in container";
+ end if;
+
+ if Before.Node.Parent /= Target_Parent.Node then
+ raise Constraint_Error
+ with "Before cursor not child of Target_Parent";
+ end if;
+ end if;
+
+ if Source_Parent = No_Element then
+ raise Constraint_Error with "Source_Parent cursor has no element";
+ end if;
+
+ if Source_Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error
+ with "Source_Parent cursor not in container";
+ end if;
+
+ if Target_Parent = Source_Parent then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ if Is_Reachable (From => Target_Parent.Node,
+ To => Source_Parent.Node)
+ then
+ raise Constraint_Error
+ with "Source_Parent is ancestor of Target_Parent";
+ end if;
+
+ Splice_Children
+ (Target_Parent => Target_Parent.Node,
+ Before => Before.Node,
+ Source_Parent => Source_Parent.Node);
+ end Splice_Children;
+
+ procedure Splice_Children
+ (Target_Parent : Tree_Node_Access;
+ Before : Tree_Node_Access;
+ Source_Parent : Tree_Node_Access)
+ is
+ CC : constant Children_Type := Source_Parent.Children;
+ C : Tree_Node_Access;
+
+ begin
+ -- This is a utility operation to remove the children from
+ -- Source parent and insert them into Target parent.
+
+ Source_Parent.Children := Children_Type'(others => null);
+
+ -- Fix up the Parent pointers of each child to designate
+ -- its new Target parent.
+
+ C := CC.First;
+ while C /= null loop
+ C.Parent := Target_Parent;
+ C := C.Next;
+ end loop;
+
+ Insert_Subtree_List
+ (First => CC.First,
+ Last => CC.Last,
+ Parent => Target_Parent,
+ Before => Before);
+ end Splice_Children;
+
+ --------------------
+ -- Splice_Subtree --
+ --------------------
+
+ procedure Splice_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Position : in out Cursor)
+ is
+ Subtree_Count : Count_Type;
+
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Target'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in Target container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Target'Unrestricted_Access then
+ raise Program_Error with "Before cursor not in Target container";
+ end if;
+
+ if Before.Node.Parent /= Parent.Node then
+ raise Constraint_Error with "Before cursor not child of Parent";
+ end if;
+ end if;
+
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Source'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in Source container";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ if Target'Address = Source'Address then
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Target tree is busy)";
+ end if;
+
+ if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ raise Constraint_Error with "Position is ancestor of Parent";
+ end if;
+
+ Remove_Subtree (Position.Node);
+
+ Position.Node.Parent := Parent.Node;
+ Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
+
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Target tree is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (Source tree is busy)";
+ end if;
+
+ -- This is an unfortunate feature of this API: we must count the nodes
+ -- in the subtree that we remove from the source tree, which is an O(n)
+ -- operation. It would have been better if the Tree container did not
+ -- have a Node_Count selector; a user that wants the number of nodes in
+ -- the tree could simply call Subtree_Node_Count, with the understanding
+ -- that such an operation is O(n).
+
+ -- Of course, we could choose to implement the Node_Count selector as an
+ -- O(n) operation, which would turn this splice operation into an O(1)
+ -- operation. ???
+
+ Subtree_Count := Subtree_Node_Count (Position.Node);
+ pragma Assert (Subtree_Count <= Source.Count);
+
+ Remove_Subtree (Position.Node);
+ Source.Count := Source.Count - Subtree_Count;
+
+ Position.Node.Parent := Parent.Node;
+ Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
+
+ Target.Count := Target.Count + Subtree_Count;
+
+ Position.Container := Target'Unrestricted_Access;
+ end Splice_Subtree;
+
+ procedure Splice_Subtree
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Position : Cursor)
+ is
+ begin
+ if Parent = No_Element then
+ raise Constraint_Error with "Parent cursor has no element";
+ end if;
+
+ if Parent.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Parent cursor not in container";
+ end if;
+
+ if Before /= No_Element then
+ if Before.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Before cursor not in container";
+ end if;
+
+ if Before.Node.Parent /= Parent.Node then
+ raise Constraint_Error with "Before cursor not child of Parent";
+ end if;
+ end if;
+
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in container";
+ end if;
+
+ if Is_Root (Position) then
+
+ -- Should this be PE instead? Need ARG confirmation. ???
+
+ raise Constraint_Error with "Position cursor designates root";
+ end if;
+
+ if Position.Node.Parent = Parent.Node then
+ if Position.Node = Before.Node then
+ return;
+ end if;
+
+ if Position.Node.Next = Before.Node then
+ return;
+ end if;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error
+ with "attempt to tamper with cursors (tree is busy)";
+ end if;
+
+ if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ raise Constraint_Error with "Position is ancestor of Parent";
+ end if;
+
+ Remove_Subtree (Position.Node);
+
+ Position.Node.Parent := Parent.Node;
+ Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
+ end Splice_Subtree;
+
+ ------------------------
+ -- Subtree_Node_Count --
+ ------------------------
+
+ function Subtree_Node_Count (Position : Cursor) return Count_Type is
+ begin
+ if Position = No_Element then
+ return 0;
+ end if;
+
+ return Subtree_Node_Count (Position.Node);
+ end Subtree_Node_Count;
+
+ function Subtree_Node_Count
+ (Subtree : Tree_Node_Access) return Count_Type
+ is
+ Result : Count_Type;
+ Node : Tree_Node_Access;
+
+ begin
+ Result := 1;
+ Node := Subtree.Children.First;
+ while Node /= null loop
+ Result := Result + Subtree_Node_Count (Node);
+ Node := Node.Next;
+ end loop;
+
+ return Result;
+ end Subtree_Node_Count;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap
+ (Container : in out Tree;
+ I, J : Cursor)
+ is
+ begin
+ if I = No_Element then
+ raise Constraint_Error with "I cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "I cursor not in container";
+ end if;
+
+ if Is_Root (I) then
+ raise Program_Error with "I cursor designates root";
+ end if;
+
+ if I = J then -- make this test sooner???
+ return;
+ end if;
+
+ if J = No_Element then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if J.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "J cursor not in container";
+ end if;
+
+ if Is_Root (J) then
+ raise Program_Error with "J cursor designates root";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error
+ with "attempt to tamper with elements (tree is locked)";
+ end if;
+
+ declare
+ EI : constant Element_Type := I.Node.Element;
+
+ begin
+ I.Node.Element := J.Node.Element;
+ J.Node.Element := EI;
+ end;
+ end Swap;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position = No_Element then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor not in container";
+ end if;
+
+ if Is_Root (Position) then
+ raise Program_Error with "Position cursor designates root";
+ end if;
+
+ declare
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ Process (Position.Node.Element);
+
+ L := L - 1;
+ B := B - 1;
+
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+
+ raise;
+ end;
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Tree)
+ is
+ procedure Write_Children (Subtree : Tree_Node_Access);
+ procedure Write_Subtree (Subtree : Tree_Node_Access);
+
+ --------------------
+ -- Write_Children --
+ --------------------
+
+ procedure Write_Children (Subtree : Tree_Node_Access) is
+ CC : Children_Type renames Subtree.Children;
+ C : Tree_Node_Access;
+
+ begin
+ Count_Type'Write (Stream, Child_Count (CC));
+
+ C := CC.First;
+ while C /= null loop
+ Write_Subtree (C);
+ C := C.Next;
+ end loop;
+ end Write_Children;
+
+ -------------------
+ -- Write_Subtree --
+ -------------------
+
+ procedure Write_Subtree (Subtree : Tree_Node_Access) is
+ begin
+ Element_Type'Output (Stream, Subtree.Element);
+ Write_Children (Subtree);
+ end Write_Subtree;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Write (Stream, Container.Count);
+
+ if Container.Count = 0 then
+ return;
+ end if;
+
+ Write_Children (Root_Node (Container));
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to write tree cursor to stream";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+end Ada.Containers.Multiway_Trees;