URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-comutr.adb] - Blame information for rev 749

Go to most recent revision | Details | Compare with Previous | View Log

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

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-comutr.adb] - Blame information for rev 749

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT LIBRARY COMPONENTS --`
4			`-- --`
5			`-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2004-2012, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- This unit was originally developed by Matthew J Heaney. --`
28			`------------------------------------------------------------------------------`
29
30			`with Ada.Unchecked_Conversion;`
31			`with Ada.Unchecked_Deallocation;`
32
33			`with System; use type System.Address;`
34
35			`package body Ada.Containers.Multiway_Trees is`
36
37			`--------------------`
38			`-- Root_Iterator --`
39			`--------------------`
40