+2011-08-05 Thomas Quinot <quinot@adacore.com>
+
+ * g-expect.adb: Minor reformatting.
+
+2011-08-05 Bob Duff <duff@adacore.com>
+
+ * a-fihema.adb: Comment out OS_Lib.
+
+2011-08-05 Matthew Heaney <heaney@adacore.com>
+
+ * Makefile.rtl, impunit.adb: Added a-c[oi]mutr.ad[sb]
+ (unbounded multiway tree containers) and a-iteint.ads.
+ * a-comutr.ads, a-comutr.adb:
+ This is the new Ada 2012 unit for unbounded multiway tree containers
+ * a-cimutr.ads, a-cimutr.adb
+ This is the new Ada 2012 unit for indefinite multiway tree containers
+ * a-iteint.ads: New file.
+
2011-08-05 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* gcc-interface/Makefile.in (raise-gcc.o): Search
a-crbtgk$(objext) \
a-crbtgo$(objext) \
a-crdlli$(objext) \
+ a-comutr$(objext) \
+ a-cimutr$(objext) \
a-cwila1$(objext) \
a-cwila9$(objext) \
a-decima$(objext) \
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2011, 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_Deallocation;
+with System; use type System.Address;
+
+package body Ada.Containers.Indefinite_Multiway_Trees is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Root_Node (Container : Tree) return Tree_Node_Access;
+
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ procedure Deallocate_Node (X : in out 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;
+
+ -------------------
+ -- Ancestor_Find --
+ -------------------
+
+ function Ancestor_Find
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor
+ is
+ R : constant Tree_Node_Access := Root_Node (Container);
+ N : 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;
+
+ -- 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;
+
+ N := Position.Node;
+ while N /= R loop
+ if N.Element.all = Item then
+ return Cursor'(Container'Unrestricted_Access, 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;
+ Element : Element_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;
+
+ Element := new Element_Type'(New_Item);
+ First := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => Element,
+ others => <>);
+
+ Last := First;
+
+ for J in Count_Type'(2) .. Count loop
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Element := new Element_Type'(New_Item);
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => Element,
+ 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;
+
+ -----------
+ -- 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;
+
+ --------------
+ -- 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;
+
+ -- We add the newly-allocated children to their parent list
+ -- only after the allocation has succeeded, in order to
+ -- preserve invariants of the parent.
+
+ Parent.Children := CC;
+ end Copy_Children;
+
+ -----------------
+ -- Child_Count --
+ -----------------
+
+ function Child_Count (Parent : Cursor) return Count_Type is
+ begin
+ if Parent = No_Element then
+ return 0;
+ end if;
+
+ return 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;
+
+ ------------------
+ -- 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_Node --
+ ---------------------
+
+ procedure Deallocate_Node (X : in out Tree_Node_Access) is
+ procedure Free_Node is
+ new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
+
+ -- Start of processing for Deallocate_Node
+
+ begin
+ if X /= null then
+ Free_Element (X.Element);
+ Free_Node (X);
+ end if;
+ end Deallocate_Node;
+
+ ------------------------
+ -- 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 an 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.all;
+ 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;
+
+ ----------
+ -- 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;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, N);
+ end Find;
+
+ -----------------
+ -- 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
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor
+ is
+ Result : 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
+ Result := Find_In_Children (Position.Node, Item);
+
+ else
+ Result := Find_In_Subtree (Position.Node, Item);
+ end if;
+
+ if Result = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, 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.all = 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
+ if Position = No_Element then
+ return False;
+ end if;
+
+ return 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;
+ Element : Element_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;
+
+ Element := new Element_Type'(New_Item);
+ Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => Element,
+ others => <>);
+
+ Last := Position.Node;
+
+ for J in Count_Type'(2) .. Count loop
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Element := new Element_Type'(New_Item);
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => 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
+ if Position = No_Element then
+ return False;
+ end if;
+
+ return 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
+ if Position.Container = null then
+ return False;
+ end if;
+
+ return Position = Root (Position.Container.all);
+ end Is_Root;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Tree;
+ Process : not null access procedure (Position : Cursor))
+ is
+ T : Tree renames Container'Unrestricted_Access.all;
+ B : Integer renames T.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;
+
+ ----------------------
+ -- 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 : Integer 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;
+
+ ---------------------
+ -- 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 : Integer 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_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_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;
+ Element : Element_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;
+
+ Element := new Element_Type'(New_Item);
+ First := new Tree_Node_Type'(Parent => Parent.Node,
+ Element => Element,
+ others => <>);
+
+ Last := First;
+
+ for J in Count_Type'(2) .. Count loop
+ -- Reclaim other nodes if Storage_Error. ???
+
+ Element := new Element_Type'(New_Item);
+ Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
+ Prev => Last,
+ Element => Element,
+ 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_Sibling --
+ ----------------------
+
+ function Previous_Sibling (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ if Position.Node.Prev = null then
+ return No_Element;
+ end if;
+
+ return 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 : Integer renames T.Busy;
+ L : Integer renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ Process (Position.Node.Element.all);
+
+ 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, Read_Count : Count_Type;
+
+ -------------------
+ -- 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; -- number of child subtrees
+ C : Children_Type;
+
+ begin
+ Count_Type'Read (Stream, Count);
+
+ if not Count'Valid then -- Is this check necessary???
+ 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
+ Element : constant Element_Access :=
+ new Element_Type'(Element_Type'Input (Stream));
+
+ Subtree : constant Tree_Node_Access :=
+ new Tree_Node_Type'
+ (Parent => Parent,
+ Element => Element,
+ 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 not Total_Count'Valid then -- Is this check necessary???
+ 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;
+
+ --------------------
+ -- 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
+ E, X : Element_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 Container.Lock > 0 then
+ raise Program_Error
+ with "attempt to tamper with elements (tree is locked)";
+ end if;
+
+ E := new Element_Type'(New_Item);
+
+ X := Position.Node.Element;
+ Position.Node.Element := E;
+
+ Free_Element (X);
+ 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 : Integer 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
+ begin
+ return 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 = Before.Node
+ or else Position.Node.Next = Before.Node
+ 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 => 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 = Before.Node
+ or else Position.Node.Next = Before.Node
+ 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 => 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_Access := 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 : Integer renames T.Busy;
+ L : Integer renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ Process (Position.Node.Element.all);
+
+ 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.all);
+ Write_Children (Subtree);
+ end Write_Subtree;
+
+ -- Start of processing for Write
+
+ begin
+ Count_Type'Write (Stream, Container.Count);
+ 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;
+
+end Ada.Containers.Indefinite_Multiway_Trees;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Finalization;
+private with Ada.Streams;
+
+generic
+ type Element_Type (<>) is private;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Multiway_Trees is
+ pragma Preelaborate;
+ pragma Remote_Types;
+
+ type Tree is tagged private;
+ pragma Preelaborable_Initialization (Tree);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Tree : constant Tree;
+
+ No_Element : constant Cursor;
+
+ function Equal_Subtree
+ (Left_Position : Cursor;
+ Right_Position : Cursor) return Boolean;
+
+ function "=" (Left, Right : Tree) return Boolean;
+
+ function Is_Empty (Container : Tree) return Boolean;
+
+ function Node_Count (Container : Tree) return Count_Type;
+
+ function Subtree_Node_Count (Position : Cursor) return Count_Type;
+
+ function Depth (Position : Cursor) return Count_Type;
+
+ function Is_Root (Position : Cursor) return Boolean;
+
+ function Is_Leaf (Position : Cursor) return Boolean;
+
+ function Root (Container : Tree) return Cursor;
+
+ procedure Clear (Container : in out Tree);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Assign (Target : in out Tree; Source : Tree);
+
+ function Copy (Source : Tree) return Tree;
+
+ procedure Move (Target : in out Tree; Source : in out Tree);
+
+ procedure Delete_Leaf
+ (Container : in out Tree;
+ Position : in out Cursor);
+
+ procedure Delete_Subtree
+ (Container : in out Tree;
+ Position : in out Cursor);
+
+ procedure Swap
+ (Container : in out Tree;
+ I, J : Cursor);
+
+ function Find
+ (Container : Tree;
+ Item : Element_Type) return Cursor;
+
+ function Find_In_Subtree
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor;
+
+ function Ancestor_Find
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor;
+
+ function Contains
+ (Container : Tree;
+ Item : Element_Type) return Boolean;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Tree;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Iterate_Subtree
+ (Position : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+ function Child_Count (Parent : Cursor) return Count_Type;
+
+ function Child_Depth (Parent, Child : Cursor) return Count_Type;
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Delete_Children
+ (Container : in out Tree;
+ Parent : Cursor);
+
+ procedure Copy_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : Cursor);
+
+ procedure Splice_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Position : in out Cursor);
+
+ procedure Splice_Subtree
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Position : Cursor);
+
+ procedure Splice_Children
+ (Target : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Source_Parent : Cursor);
+
+ procedure Splice_Children
+ (Container : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source_Parent : Cursor);
+
+ function Parent (Position : Cursor) return Cursor;
+
+ function First_Child (Parent : Cursor) return Cursor;
+
+ function First_Child_Element (Parent : Cursor) return Element_Type;
+
+ function Last_Child (Parent : Cursor) return Cursor;
+
+ function Last_Child_Element (Parent : Cursor) return Element_Type;
+
+ function Next_Sibling (Position : Cursor) return Cursor;
+
+ function Previous_Sibling (Position : Cursor) return Cursor;
+
+ procedure Next_Sibling (Position : in out Cursor);
+
+ procedure Previous_Sibling (Position : in out Cursor);
+
+ -- This version of the AI:
+ -- 10-06-02 AI05-0136-1/07
+ -- declares Iterate_Children this way:
+ --
+ -- procedure Iterate_Children
+ -- (Container : Tree;
+ -- Parent : Cursor;
+ -- Process : not null access procedure (Position : Cursor));
+ --
+ -- It seems that the Container parameter is there by mistake, but
+ -- we need an official ruling from the ARG. ???
+
+ procedure Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ type Tree_Node_Type;
+ type Tree_Node_Access is access all Tree_Node_Type;
+
+ type Children_Type is record
+ First : Tree_Node_Access;
+ Last : Tree_Node_Access;
+ end record;
+
+ type Element_Access is access Element_Type;
+
+ type Tree_Node_Type is record
+ Parent : Tree_Node_Access;
+ Prev : Tree_Node_Access;
+ Next : Tree_Node_Access;
+ Children : Children_Type;
+ Element : Element_Access;
+ end record;
+
+ use Ada.Finalization;
+
+ -- The Count component of type Tree represents the number of
+ -- nodes that have been (dynamically) allocated. It does not
+ -- include the root node itself. As implementors, we decide
+ -- to cache this value, so that the selector function Node_Count
+ -- can execute in O(1) time, in order to be consistent with
+ -- the behavior of the Length selector function for other
+ -- standard container library units. This does mean, however,
+ -- that the two-container forms for Splice_XXX (that move subtrees
+ -- across tree containers) will execute in O(n) time, because
+ -- we must count the number of nodes in the subtree(s) that
+ -- get moved. (We resolve the tension between Node_Count
+ -- and Splice_XXX in favor of Node_Count, under the assumption
+ -- that Node_Count is the more common operation).
+
+ type Tree is new Controlled with record
+ Root : aliased Tree_Node_Type;
+ Busy : Integer := 0;
+ Lock : Integer := 0;
+ Count : Count_Type := 0;
+ end record;
+
+ overriding procedure Adjust (Container : in out Tree);
+
+ overriding procedure Finalize (Container : in out Tree) renames Clear;
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Tree);
+
+ for Tree'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Tree);
+
+ for Tree'Read use Read;
+
+ type Tree_Access is access all Tree;
+ for Tree_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Tree_Access;
+ Node : Tree_Node_Access;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor);
+
+ for Cursor'Read use Read;
+
+ Empty_Tree : constant Tree := (Controlled with others => <>);
+
+ No_Element : constant Cursor := (others => <>);
+
+end Ada.Containers.Indefinite_Multiway_Trees;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-2011, 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
+
+ -----------------------
+ -- 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;
+
+ -------------------
+ -- Ancestor_Find --
+ -------------------
+
+ function Ancestor_Find
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor
+ is
+ R : constant Tree_Node_Access := Root_Node (Container);
+ N : 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;
+
+ -- 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;
+
+ N := Position.Node;
+ while N /= R loop
+ if N.Element = Item then
+ return Cursor'(Container'Unrestricted_Access, 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;
+
+ -----------
+ -- 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;
+
+ --------------
+ -- 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;
+
+ -- We add the newly-allocated children to their parent list
+ -- only after the allocation has succeeded, in order to
+ -- preserve invariants of the parent.
+
+ Parent.Children := CC;
+ end Copy_Children;
+
+ -----------------
+ -- Child_Count --
+ -----------------
+
+ function Child_Count (Parent : Cursor) return Count_Type is
+ begin
+ if Parent = No_Element then
+ return 0;
+ end if;
+
+ return 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;
+
+ ------------------
+ -- 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 an 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;
+
+ ----------
+ -- 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;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, N);
+ end Find;
+
+ -----------------
+ -- 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
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor
+ is
+ Result : 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
+ Result := Find_In_Children (Position.Node, Item);
+
+ else
+ Result := Find_In_Subtree (Position.Node, Item);
+ end if;
+
+ if Result = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, 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
+ if Position = No_Element then
+ return False;
+ end if;
+
+ return 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
+ if Position = No_Element then
+ return False;
+ end if;
+
+ return 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
+ if Position.Container = null then
+ return False;
+ end if;
+
+ return Position = Root (Position.Container.all);
+ end Is_Root;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Tree;
+ Process : not null access procedure (Position : Cursor))
+ is
+ T : Tree renames Container'Unrestricted_Access.all;
+ B : Integer renames T.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;
+
+ ----------------------
+ -- 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 : Integer 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;
+
+ ---------------------
+ -- 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 : Integer 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_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_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_Sibling --
+ ----------------------
+
+ function Previous_Sibling (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ if Position.Node.Prev = null then
+ return No_Element;
+ end if;
+
+ return 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 : Integer renames T.Busy;
+ L : Integer 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, Read_Count : Count_Type;
+
+ -------------------
+ -- 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; -- number of child subtrees
+ C : Children_Type;
+
+ begin
+ Count_Type'Read (Stream, Count);
+
+ if not Count'Valid then -- Is this check necessary???
+ 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 not Total_Count'Valid then -- Is this check necessary???
+ 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;
+
+ --------------------
+ -- 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 : Integer 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 = Before.Node
+ or else Position.Node.Next = Before.Node
+ 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 => 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 = Before.Node
+ or else Position.Node.Next = Before.Node
+ 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 => 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 : Integer renames T.Busy;
+ L : Integer 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);
+ 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;
+
+end Ada.Containers.Multiway_Trees;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Finalization;
+private with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Multiway_Trees is
+ pragma Preelaborate;
+ pragma Remote_Types;
+
+ type Tree is tagged private;
+ pragma Preelaborable_Initialization (Tree);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Tree : constant Tree;
+
+ No_Element : constant Cursor;
+
+ function Equal_Subtree
+ (Left_Position : Cursor;
+ Right_Position : Cursor) return Boolean;
+
+ function "=" (Left, Right : Tree) return Boolean;
+
+ function Is_Empty (Container : Tree) return Boolean;
+
+ function Node_Count (Container : Tree) return Count_Type;
+
+ function Subtree_Node_Count (Position : Cursor) return Count_Type;
+
+ function Depth (Position : Cursor) return Count_Type;
+
+ function Is_Root (Position : Cursor) return Boolean;
+
+ function Is_Leaf (Position : Cursor) return Boolean;
+
+ function Root (Container : Tree) return Cursor;
+
+ procedure Clear (Container : in out Tree);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Tree;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Assign (Target : in out Tree; Source : Tree);
+
+ function Copy (Source : Tree) return Tree;
+
+ procedure Move (Target : in out Tree; Source : in out Tree);
+
+ procedure Delete_Leaf
+ (Container : in out Tree;
+ Position : in out Cursor);
+
+ procedure Delete_Subtree
+ (Container : in out Tree;
+ Position : in out Cursor);
+
+ procedure Swap
+ (Container : in out Tree;
+ I, J : Cursor);
+
+ function Find
+ (Container : Tree;
+ Item : Element_Type) return Cursor;
+
+ function Find_In_Subtree
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor;
+
+ function Ancestor_Find
+ (Container : Tree;
+ Item : Element_Type;
+ Position : Cursor) return Cursor;
+
+ function Contains
+ (Container : Tree;
+ Item : Element_Type) return Boolean;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Tree;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Iterate_Subtree
+ (Position : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+ function Child_Count (Parent : Cursor) return Count_Type;
+
+ function Child_Depth (Parent, Child : Cursor) return Count_Type;
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Insert_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append_Child
+ (Container : in out Tree;
+ Parent : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Delete_Children
+ (Container : in out Tree;
+ Parent : Cursor);
+
+ procedure Copy_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : Cursor);
+
+ procedure Splice_Subtree
+ (Target : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Position : in out Cursor);
+
+ procedure Splice_Subtree
+ (Container : in out Tree;
+ Parent : Cursor;
+ Before : Cursor;
+ Position : Cursor);
+
+ procedure Splice_Children
+ (Target : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source : in out Tree;
+ Source_Parent : Cursor);
+
+ procedure Splice_Children
+ (Container : in out Tree;
+ Target_Parent : Cursor;
+ Before : Cursor;
+ Source_Parent : Cursor);
+
+ function Parent (Position : Cursor) return Cursor;
+
+ function First_Child (Parent : Cursor) return Cursor;
+
+ function First_Child_Element (Parent : Cursor) return Element_Type;
+
+ function Last_Child (Parent : Cursor) return Cursor;
+
+ function Last_Child_Element (Parent : Cursor) return Element_Type;
+
+ function Next_Sibling (Position : Cursor) return Cursor;
+
+ function Previous_Sibling (Position : Cursor) return Cursor;
+
+ procedure Next_Sibling (Position : in out Cursor);
+
+ procedure Previous_Sibling (Position : in out Cursor);
+
+ -- This version of the AI:
+ -- 10-06-02 AI05-0136-1/07
+ -- declares Iterate_Children this way:
+ --
+ -- procedure Iterate_Children
+ -- (Container : Tree;
+ -- Parent : Cursor;
+ -- Process : not null access procedure (Position : Cursor));
+ --
+ -- It seems that the Container parameter is there by mistake, but
+ -- we need an official ruling from the ARG. ???
+
+ procedure Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate_Children
+ (Parent : Cursor;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ -- A node of this multiway tree comprises an element and a list of
+ -- children (that are themselves trees). The root node is distinguished
+ -- because it contains only children: it does not have an element itself.
+ --
+ -- This design feature puts two design goals in tension:
+ -- (1) treat the root node the same as any other node
+ -- (2) not declare any objects of type Element_Type unnecessarily
+ --
+ -- To satisfy (1), we could simply declare the Root node of the tree
+ -- using the normal Tree_Node_Type, but that would mean that (2) is not
+ -- satisfied. To resolve the tension (in favor of (2)), we declare the
+ -- component Root as having a different node type, without an Element
+ -- component (thus satisfying goal (2)) but otherwise identical to a
+ -- normal node, and then use Unchecked_Conversion to convert an access
+ -- object designating the Root node component to the access type
+ -- designating a normal, non-root node (thus satisfying goal (1)). We make
+ -- an explicit check for Root when there is any attempt to manipulate the
+ -- Element component of the node (a check required by the RM anyway).
+ --
+ -- In order to be explicit about node (and pointer) representation, we
+ -- specify that the respective node types have convention C, to ensure
+ -- that the layout of the components of the node records is the same,
+ -- thus guaranteeing that (unchecked) conversions between access types
+ -- designating each kind of node type is a meaningful conversion.
+
+ type Tree_Node_Type;
+ type Tree_Node_Access is access all Tree_Node_Type;
+ pragma Convention (C, Tree_Node_Access);
+
+ type Children_Type is record
+ First : Tree_Node_Access;
+ Last : Tree_Node_Access;
+ end record;
+
+ -- See the comment above. This declaration must exactly
+ -- match the declaration of Root_Node_Type (except for
+ -- the Element component).
+
+ type Tree_Node_Type is record
+ Parent : Tree_Node_Access;
+ Prev : Tree_Node_Access;
+ Next : Tree_Node_Access;
+ Children : Children_Type;
+ Element : Element_Type;
+ end record;
+ pragma Convention (C, Tree_Node_Type);
+
+ -- See the comment above. This declaration must match
+ -- the declaration of Tree_Node_Type (except for the
+ -- Element component).
+
+ type Root_Node_Type is record
+ Parent : Tree_Node_Access;
+ Prev : Tree_Node_Access;
+ Next : Tree_Node_Access;
+ Children : Children_Type;
+ end record;
+ pragma Convention (C, Root_Node_Type);
+
+ use Ada.Finalization;
+
+ -- The Count component of type Tree represents the number of
+ -- nodes that have been (dynamically) allocated. It does not
+ -- include the root node itself. As implementors, we decide
+ -- to cache this value, so that the selector function Node_Count
+ -- can execute in O(1) time, in order to be consistent with
+ -- the behavior of the Length selector function for other
+ -- standard container library units. This does mean, however,
+ -- that the two-container forms for Splice_XXX (that move subtrees
+ -- across tree containers) will execute in O(n) time, because
+ -- we must count the number of nodes in the subtree(s) that
+ -- get moved. (We resolve the tension between Node_Count
+ -- and Splice_XXX in favor of Node_Count, under the assumption
+ -- that Node_Count is the more common operation).
+
+ type Tree is new Controlled with record
+ Root : aliased Root_Node_Type;
+ Busy : Integer := 0;
+ Lock : Integer := 0;
+ Count : Count_Type := 0;
+ end record;
+
+ overriding procedure Adjust (Container : in out Tree);
+
+ overriding procedure Finalize (Container : in out Tree) renames Clear;
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Tree);
+
+ for Tree'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Tree);
+
+ for Tree'Read use Read;
+
+ type Tree_Access is access all Tree;
+ for Tree_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Tree_Access;
+ Node : Tree_Node_Access;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor);
+
+ for Cursor'Read use Read;
+
+ Empty_Tree : constant Tree := (Controlled with others => <>);
+
+ No_Element : constant Cursor := (others => <>);
+
+end Ada.Containers.Multiway_Trees;
with System; use System;
with System.Address_Image;
with System.IO; use System.IO;
-with System.OS_Lib;
+-- ???with System.OS_Lib;
+-- Breaks ravenscar runtimes
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools; use System.Storage_Pools;
procedure Fail is
begin
Put_Line ("Heap_Management: Fin_Assert failed: " & Message);
- OS_Lib.OS_Abort;
+ -- ???OS_Lib.OS_Abort;
+ -- Breaks ravenscar runtimes
end Fail;
-- Start of processing for Fin_Assert
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . I T E R A T O R . I N T E R F A C E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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/>. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Cursor is private;
+ No_Element : Cursor;
+ pragma Unreferenced (No_Element);
+package Ada.Iterator_Interfaces is
+ type Forward_Iterator is limited interface;
+ function First (Object : Forward_Iterator) return Cursor is abstract;
+ function Next (Object : Forward_Iterator; Position : Cursor) return Cursor
+ is abstract;
+ type Reversible_Iterator is limited interface and Forward_Iterator;
+ function Last (Object : Reversible_Iterator) return Cursor is abstract;
+ function Previous (Object : Reversible_Iterator; Position : Cursor)
+ return Cursor is abstract;
+end Ada.Iterator_Interfaces;
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2010, AdaCore --
+-- Copyright (C) 2000-2011, AdaCore --
-- --
-- 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- --
NOutput (Output'Range) := Output.all;
Free (Output);
- -- Here if current buffer size is OK
+ -- Here if current buffer size is OK
else
NOutput := Output;
"a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets
"a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps
"a-coinho", -- Ada.Containers.Indefinite_Holders
+ "a-comutr", -- Ada.Containers.Multiway_Trees
+ "a-cimutr", -- Ada.Containers.Indefinite_Multiway_Trees
"a-extiin", -- Ada.Execution_Time.Interrupts
+ "a-iteint", -- Ada.Iterator_Interfaces
-----------------------------------------
-- GNAT Defined Additions to Ada 20012 --
projects / gcc.git / commitdiff