2675 lines
75 KiB
Ada
2675 lines
75 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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-2015, 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
|
|
|
|
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
-- See comment in Ada.Containers.Helpers
|
|
|
|
--------------------
|
|
-- 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
|
|
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);
|
|
Zero_Counts (Container.TC);
|
|
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
|
|
(Position : Cursor;
|
|
Item : Element_Type) return Cursor
|
|
is
|
|
R, N : Tree_Node_Access;
|
|
|
|
begin
|
|
if Checks and then 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 Checks and then 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 : Tree_Node_Access;
|
|
Last : Tree_Node_Access;
|
|
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Count = 0 then
|
|
return;
|
|
end if;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Child = No_Element then
|
|
raise Constraint_Error with "Child cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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 Checks and then 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
|
|
TC_Check (Container.TC);
|
|
|
|
-- 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 Checks and then Position.Container = null then
|
|
raise Constraint_Error with
|
|
"Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with
|
|
"Position cursor designates wrong container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
TC : constant Tamper_Counts_Access :=
|
|
C.TC'Unrestricted_Access;
|
|
begin
|
|
return R : constant Constant_Reference_Type :=
|
|
(Element => Position.Node.Element'Access,
|
|
Control => (Controlled with TC))
|
|
do
|
|
Lock (TC.all);
|
|
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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Before /= No_Element then
|
|
if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
raise Program_Error with "Before cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then 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 Checks and then 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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
-- 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 Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Position cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (Position) then
|
|
raise Program_Error with "Position cursor designates root";
|
|
end if;
|
|
|
|
if Checks and then not Is_Leaf (Position) then
|
|
raise Constraint_Error with "Position cursor does not designate leaf";
|
|
end if;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
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 Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Position cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (Position) then
|
|
raise Program_Error with "Position cursor designates root";
|
|
end if;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
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 Checks and then Position.Container = null then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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 Checks and then Left_Position = No_Element then
|
|
raise Constraint_Error with "Left cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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
|
|
begin
|
|
Unbusy (Object.Container.TC);
|
|
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 Checks and then 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 Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
-- Commented out pending official ruling by ARG. ???
|
|
|
|
-- if Checks and then
|
|
-- 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;
|
|
|
|
------------------------
|
|
-- Get_Element_Access --
|
|
------------------------
|
|
|
|
function Get_Element_Access
|
|
(Position : Cursor) return not null Element_Access is
|
|
begin
|
|
return Position.Node.Element'Access;
|
|
end Get_Element_Access;
|
|
|
|
-----------------
|
|
-- 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
|
|
First : Tree_Node_Access;
|
|
Last : Tree_Node_Access;
|
|
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Before /= No_Element then
|
|
if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Before cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
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 => 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;
|
|
|
|
Position := Cursor'(Parent.Container, First);
|
|
end Insert_Child;
|
|
|
|
procedure Insert_Child
|
|
(Container : in out Tree;
|
|
Parent : Cursor;
|
|
Before : Cursor;
|
|
Position : out Cursor;
|
|
Count : Count_Type := 1)
|
|
is
|
|
First : Tree_Node_Access;
|
|
Last : Tree_Node_Access;
|
|
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Before /= No_Element then
|
|
if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Before cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
First := new Tree_Node_Type'(Parent => Parent.Node,
|
|
Element => <>,
|
|
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 => <>,
|
|
others => <>);
|
|
|
|
Last := Last.Next;
|
|
end loop;
|
|
|
|
Insert_Subtree_List
|
|
(First => First,
|
|
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;
|
|
|
|
Position := Cursor'(Parent.Container, First);
|
|
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
|
|
Busy : With_Busy (Container.TC'Unrestricted_Access);
|
|
begin
|
|
Iterate_Children
|
|
(Container => Container'Unrestricted_Access,
|
|
Subtree => Root_Node (Container),
|
|
Process => Process);
|
|
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
|
|
C : Tree_Node_Access;
|
|
Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
C := Parent.Node.Children.First;
|
|
while C /= null loop
|
|
Process (Position => Cursor'(Parent.Container, Node => C));
|
|
C := C.Next;
|
|
end loop;
|
|
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;
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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
|
|
Busy (C.TC);
|
|
end return;
|
|
end Iterate_Children;
|
|
|
|
---------------------
|
|
-- Iterate_Subtree --
|
|
---------------------
|
|
|
|
function Iterate_Subtree
|
|
(Position : Cursor)
|
|
return Tree_Iterator_Interfaces.Forward_Iterator'Class
|
|
is
|
|
C : constant Tree_Access := Position.Container;
|
|
begin
|
|
if Checks and then 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");
|
|
|
|
return It : constant Subtree_Iterator :=
|
|
(Limited_Controlled with
|
|
Container => C,
|
|
Subtree => Position.Node)
|
|
do
|
|
Busy (C.TC);
|
|
end return;
|
|
end Iterate_Subtree;
|
|
|
|
procedure Iterate_Subtree
|
|
(Position : Cursor;
|
|
Process : not null access procedure (Position : Cursor))
|
|
is
|
|
Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
|
|
begin
|
|
if Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Is_Root (Position) then
|
|
Iterate_Children (Position.Container, Position.Node, Process);
|
|
else
|
|
Iterate_Subtree (Position.Container, Position.Node, Process);
|
|
end if;
|
|
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 Checks and then 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;
|
|
|
|
TC_Check (Source.TC);
|
|
|
|
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 Checks and then 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 Checks and then 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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Count = 0 then
|
|
return;
|
|
end if;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
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 Checks and then 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;
|
|
|
|
----------------------
|
|
-- Pseudo_Reference --
|
|
----------------------
|
|
|
|
function Pseudo_Reference
|
|
(Container : aliased Tree'Class) return Reference_Control_Type
|
|
is
|
|
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
|
|
begin
|
|
return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
Lock (TC.all);
|
|
end return;
|
|
end Pseudo_Reference;
|
|
|
|
-------------------
|
|
-- Query_Element --
|
|
-------------------
|
|
|
|
procedure Query_Element
|
|
(Position : Cursor;
|
|
Process : not null access procedure (Element : Element_Type))
|
|
is
|
|
T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
begin
|
|
if Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (Position) then
|
|
raise Program_Error with "Position cursor designates root";
|
|
end if;
|
|
|
|
Process (Position.Node.Element);
|
|
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 Checks and then 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 Checks and then 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 Checks and then 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 Checks and then Position.Container = null then
|
|
raise Constraint_Error with
|
|
"Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with
|
|
"Position cursor designates wrong container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
TC : constant Tamper_Counts_Access :=
|
|
C.TC'Unrestricted_Access;
|
|
begin
|
|
return R : constant Reference_Type :=
|
|
(Element => Position.Node.Element'Access,
|
|
Control => (Controlled with TC))
|
|
do
|
|
Lock (TC.all);
|
|
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 Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Position cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (Position) then
|
|
raise Program_Error with "Position cursor designates root";
|
|
end if;
|
|
|
|
TE_Check (Container.TC);
|
|
|
|
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
|
|
C : Tree_Node_Access;
|
|
Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
begin
|
|
if Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
C := Parent.Node.Children.Last;
|
|
while C /= null loop
|
|
Process (Position => Cursor'(Parent.Container, Node => C));
|
|
C := C.Prev;
|
|
end loop;
|
|
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 Checks and then Target_Parent = No_Element then
|
|
raise Constraint_Error with "Target_Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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 Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
raise Program_Error
|
|
with "Before cursor not in Target container";
|
|
end if;
|
|
|
|
if Checks and then Before.Node.Parent /= Target_Parent.Node then
|
|
raise Constraint_Error
|
|
with "Before cursor not child of Target_Parent";
|
|
end if;
|
|
end if;
|
|
|
|
if Checks and then Source_Parent = No_Element then
|
|
raise Constraint_Error with "Source_Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Target.TC);
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Target.TC);
|
|
TC_Check (Source.TC);
|
|
|
|
-- 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 Checks and then Target_Parent = No_Element then
|
|
raise Constraint_Error with "Target_Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then
|
|
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 Checks and then Before.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error
|
|
with "Before cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Before.Node.Parent /= Target_Parent.Node then
|
|
raise Constraint_Error
|
|
with "Before cursor not child of Target_Parent";
|
|
end if;
|
|
end if;
|
|
|
|
if Checks and then Source_Parent = No_Element then
|
|
raise Constraint_Error with "Source_Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then
|
|
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;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
if Checks and then 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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in Target container";
|
|
end if;
|
|
|
|
if Before /= No_Element then
|
|
if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
raise Program_Error with "Before cursor not in Target container";
|
|
end if;
|
|
|
|
if Checks and then Before.Node.Parent /= Parent.Node then
|
|
raise Constraint_Error with "Before cursor not child of Parent";
|
|
end if;
|
|
end if;
|
|
|
|
if Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Source'Unrestricted_Access then
|
|
raise Program_Error with "Position cursor not in Source container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Target.TC);
|
|
|
|
if Checks and then
|
|
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;
|
|
|
|
TC_Check (Target.TC);
|
|
TC_Check (Source.TC);
|
|
|
|
-- 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 Checks and then Parent = No_Element then
|
|
raise Constraint_Error with "Parent cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "Parent cursor not in container";
|
|
end if;
|
|
|
|
if Before /= No_Element then
|
|
if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Before cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Before.Node.Parent /= Parent.Node then
|
|
raise Constraint_Error with "Before cursor not child of Parent";
|
|
end if;
|
|
end if;
|
|
|
|
if Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Position cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then 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;
|
|
|
|
TC_Check (Container.TC);
|
|
|
|
if Checks and then
|
|
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 Checks and then I = No_Element then
|
|
raise Constraint_Error with "I cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then I.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "I cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then 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 Checks and then J = No_Element then
|
|
raise Constraint_Error with "J cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then J.Container /= Container'Unrestricted_Access then
|
|
raise Program_Error with "J cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (J) then
|
|
raise Program_Error with "J cursor designates root";
|
|
end if;
|
|
|
|
TE_Check (Container.TC);
|
|
|
|
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
|
|
T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
begin
|
|
if Checks and then Position = No_Element then
|
|
raise Constraint_Error with "Position cursor has no element";
|
|
end if;
|
|
|
|
if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
then
|
|
raise Program_Error with "Position cursor not in container";
|
|
end if;
|
|
|
|
if Checks and then Is_Root (Position) then
|
|
raise Program_Error with "Position cursor designates root";
|
|
end if;
|
|
|
|
Process (Position.Node.Element);
|
|
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;
|