blob: 5a066fbd45d1209dc55d7a99282496b4f2010424 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with System; use type System.Address;
with System.Put_Images;
package body Ada.Containers.Indefinite_Multiway_Trees with
SPARK_Mode => Off
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 --
-----------------------
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 Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
procedure Deallocate_Node (X : in out Tree_Node_Access);
procedure Deallocate_Children
(Subtree : Tree_Node_Access;
Count : in out Count_Type);
procedure Deallocate_Subtree
(Subtree : in out Tree_Node_Access;
Count : in out Count_Type);
function Equal_Children
(Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
function Equal_Subtree
(Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
procedure Iterate_Children
(Container : Tree_Access;
Subtree : Tree_Node_Access;
Process : not null access procedure (Position : Cursor));
procedure Iterate_Subtree
(Container : Tree_Access;
Subtree : Tree_Node_Access;
Process : not null access procedure (Position : Cursor));
procedure Copy_Children
(Source : Children_Type;
Parent : Tree_Node_Access;
Count : in out Count_Type);
procedure Copy_Subtree
(Source : Tree_Node_Access;
Parent : Tree_Node_Access;
Target : out Tree_Node_Access;
Count : in out Count_Type);
function Find_In_Children
(Subtree : Tree_Node_Access;
Item : Element_Type) return Tree_Node_Access;
function Find_In_Subtree
(Subtree : Tree_Node_Access;
Item : Element_Type) return Tree_Node_Access;
function Child_Count (Children : Children_Type) return Count_Type;
function Subtree_Node_Count
(Subtree : Tree_Node_Access) return Count_Type;
function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
procedure Remove_Subtree (Subtree : Tree_Node_Access);
procedure Insert_Subtree_Node
(Subtree : Tree_Node_Access;
Parent : Tree_Node_Access;
Before : Tree_Node_Access);
procedure Insert_Subtree_List
(First : Tree_Node_Access;
Last : Tree_Node_Access;
Parent : Tree_Node_Access;
Before : Tree_Node_Access);
procedure Splice_Children
(Target_Parent : Tree_Node_Access;
Before : Tree_Node_Access;
Source_Parent : Tree_Node_Access);
---------
-- "=" --
---------
function "=" (Left, Right : Tree) return Boolean is
begin
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 ARG ruling. ???
-- if Checks and then
-- 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.all = 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;
Element : Element_Access;
begin
TC_Check (Container.TC);
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;
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
-- allocator in the loop below, because the one in this block would
-- have failed already.
pragma Unsuppress (Accessibility_Check);
begin
Element := new Element_Type'(New_Item);
end;
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => Element,
others => <>);
Last := Last.Next;
end loop;
Insert_Subtree_List
(First => First,
Last => Last,
Parent => Parent.Node,
Before => null); -- null means "insert at end of list"
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Append_Child;
------------
-- Assign --
------------
procedure Assign (Target : in out Tree; Source : Tree) is
Source_Count : constant Count_Type := Source.Count;
Target_Count : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
Target.Clear; -- checks busy bit
-- Copy_Children returns the number of nodes that it allocates, but it
-- does this by incrementing the count value passed in, so we must
-- initialize the count before calling Copy_Children.
Target_Count := 0;
-- Note that Copy_Children inserts the newly-allocated children into
-- their parent list only after the allocation of all the children has
-- succeeded. This preserves invariants even if the allocation fails.
Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
pragma Assert (Target_Count = Source_Count);
Target.Count := Source_Count;
end Assign;
-----------------
-- Child_Count --
-----------------
function Child_Count (Parent : Cursor) return Count_Type is
begin
if Parent = No_Element then
return 0;
else
return Child_Count (Parent.Node.Children);
end if;
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 : Count_Type;
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
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;
if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
-- Implement Vet for multiway tree???
-- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad");
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
Busy (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;
-- We add the newly-allocated children to their parent list only after
-- the allocation has succeeded, in order to preserve invariants of the
-- parent.
Parent.Children := CC;
end Copy_Children;
------------------
-- 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
E : constant Element_Access := new Element_Type'(Source.Element.all);
begin
Target := new Tree_Node_Type'(Element => E,
Parent => Parent,
others => <>);
Count := Count + 1;
Copy_Children
(Source => Source.Children,
Parent => Target,
Count => Count);
end Copy_Subtree;
-------------------------
-- Deallocate_Children --
-------------------------
procedure Deallocate_Children
(Subtree : Tree_Node_Access;
Count : in out Count_Type)
is
pragma Assert (Subtree /= null);
CC : Children_Type := Subtree.Children;
C : Tree_Node_Access;
begin
-- We immediately remove the children from their parent, in order to
-- preserve invariants in case the deallocation fails.
Subtree.Children := Children_Type'(others => null);
while CC.First /= null loop
C := CC.First;
CC.First := C.Next;
Deallocate_Subtree (C, Count);
end loop;
end Deallocate_Children;
---------------------
-- Deallocate_Node --
---------------------
procedure Deallocate_Node (X : in out Tree_Node_Access) is
procedure Free_Node is
new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
-- Start of processing for Deallocate_Node
begin
if X /= null then
Free_Element (X.Element);
Free_Node (X);
end if;
end Deallocate_Node;
------------------------
-- Deallocate_Subtree --
------------------------
procedure Deallocate_Subtree
(Subtree : in out Tree_Node_Access;
Count : in out Count_Type)
is
begin
Deallocate_Children (Subtree, Count);
Deallocate_Node (Subtree);
Count := Count + 1;
end Deallocate_Subtree;
---------------------
-- Delete_Children --
---------------------
procedure Delete_Children
(Container : in out Tree;
Parent : Cursor)
is
Count : Count_Type;
begin
TC_Check (Container.TC);
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;
-- 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
TC_Check (Container.TC);
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;
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
TC_Check (Container.TC);
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;
X := Position.Node;
Position := No_Element;
-- Here is one case where a deallocation failure can result in the
-- violation of a representation invariant. We disassociate the subtree
-- from the tree now, but we only decrement the total node count after
-- we attempt the deallocation. However, if the deallocation fails, the
-- total node count will not get decremented.
-- One way around this dilemma is to count the nodes in the subtree
-- before attempt to delete the subtree, but that is an O(n) operation,
-- so it does not seem worth it.
-- Perhaps this is much ado about nothing, since the only way
-- deallocation can fail is if Controlled Finalization fails: this
-- propagates Program_Error so all bets are off anyway. ???
Remove_Subtree (X);
-- Deallocate_Subtree returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Deallocate_Subtree.
Count := 0;
Deallocate_Subtree (X, Count);
pragma Assert (Count <= Container.Count);
-- See comments above. We would prefer to do this sooner, but there's no
-- way to satisfy that goal without an potentially severe execution
-- penalty.
Container.Count := Container.Count - Count;
end Delete_Subtree;
-----------
-- Depth --
-----------
function Depth (Position : Cursor) return Count_Type is
Result : Count_Type;
N : Tree_Node_Access;
begin
Result := 0;
N := Position.Node;
while N /= null loop
N := N.Parent;
Result := Result + 1;
end loop;
return Result;
end Depth;
-------------
-- Element --
-------------
function Element (Position : Cursor) return Element_Type is
begin
if 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.all;
end Element;
--------------------
-- Equal_Children --
--------------------
function Equal_Children
(Left_Subtree : Tree_Node_Access;
Right_Subtree : Tree_Node_Access) return Boolean
is
Left_Children : Children_Type renames Left_Subtree.Children;
Right_Children : Children_Type renames Right_Subtree.Children;
L, R : Tree_Node_Access;
begin
if Child_Count (Left_Children) /= Child_Count (Right_Children) then
return False;
end if;
L := Left_Children.First;
R := Right_Children.First;
while L /= null loop
if not Equal_Subtree (L, R) then
return False;
end if;
L := L.Next;
R := R.Next;
end loop;
return True;
end Equal_Children;
-------------------
-- Equal_Subtree --
-------------------
function Equal_Subtree
(Left_Position : Cursor;
Right_Position : Cursor) return Boolean
is
begin
if 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.all /= Right_Subtree.Element.all 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;
end if;
return Cursor'(Container'Unrestricted_Access, N);
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 ruling from ARG. ???
-- if Checks and then
-- Position.Container /= Container'Unrestricted_Access
-- then
-- raise Program_Error with "Position cursor not in container";
-- end if;
if Is_Root (Position) then
Result := Find_In_Children (Position.Node, Item);
else
Result := Find_In_Subtree (Position.Node, Item);
end if;
if Result = null then
return No_Element;
end if;
return Cursor'(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.all = 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;
end Get_Element_Access;
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
if Position = No_Element then
return False;
end if;
return Position.Node.Parent /= null;
end Has_Element;
------------------
-- Insert_Child --
------------------
procedure Insert_Child
(Container : in out Tree;
Parent : Cursor;
Before : Cursor;
New_Item : Element_Type;
Count : Count_Type := 1)
is
Position : Cursor;
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;
Element : Element_Access;
begin
TC_Check (Container.TC);
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;
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
-- allocator in the loop below, because the one in this block would
-- have failed already.
pragma Unsuppress (Accessibility_Check);
begin
Element := new Element_Type'(New_Item);
end;
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => Element,
others => <>);
Last := Last.Next;
end loop;
Insert_Subtree_List
(First => First,
Last => Last,
Parent => Parent.Node,
Before => 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
if Position = No_Element then
return False;
end if;
return Position.Node.Children.First = null;
end Is_Leaf;
------------------
-- Is_Reachable --
------------------
function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
pragma Assert (From /= null);
pragma Assert (To /= null);
N : Tree_Node_Access;
begin
N := From;
while N /= null loop
if N = To then
return True;
end if;
N := N.Parent;
end loop;
return False;
end Is_Reachable;
-------------
-- Is_Root --
-------------
function Is_Root (Position : Cursor) return Boolean is
begin
if Position.Container = null then
return False;
end if;
return Position = Root (Position.Container.all);
end Is_Root;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Tree;
Process : not null access procedure (Position : Cursor))
is
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 :=
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 => Position.Container,
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;
-------------------
-- Prepend_Child --
-------------------
procedure Prepend_Child
(Container : in out Tree;
Parent : Cursor;
New_Item : Element_Type;
Count : Count_Type := 1)
is
First, Last : Tree_Node_Access;
Element : Element_Access;
begin
TC_Check (Container.TC);
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;
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
-- allocator in the loop below, because the one in this block would
-- have failed already.
pragma Unsuppress (Accessibility_Check);
begin
Element := new Element_Type'(New_Item);
end;
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => Element,
others => <>);
Last := Last.Next;
end loop;
Insert_Subtree_List
(First => First,
Last => Last,
Parent => Parent.Node,
Before => Parent.Node.Children.First);
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Prepend_Child;
--------------
-- Previous --
--------------
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
if Position = No_Element then
return No_Element;
end if;
if Position.Node.Prev = null then
return No_Element;
end if;
return Cursor'(Position.Container, Position.Node.Prev);
end Previous_Sibling;
procedure Previous_Sibling (Position : in out Cursor) is
begin
Position := Previous_Sibling (Position);
end Previous_Sibling;
----------------------
-- 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
Busy (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.all);
end Query_Element;
---------------
-- Put_Image --
---------------
procedure Put_Image
(S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
procedure Rec (Position : Cursor);
-- Recursive routine operating on cursors
procedure Rec (Position : Cursor) is
First_Time : Boolean := True;
begin
Array_Before (S);
for X in Iterate_Children (V, Position) loop
if First_Time then
First_Time := False;
else
Array_Between (S);
end if;
Element_Type'Put_Image (S, Element (X));
if Child_Count (X) > 0 then
Simple_Array_Between (S);
Rec (X);
end if;
end loop;
Array_After (S);
end Rec;
begin
if First_Child (Root (V)) = No_Element then
Array_Before (S);
Array_After (S);
else
Rec (First_Child (Root (V)));
end if;
end Put_Image;
----------
-- 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
Element : constant Element_Access :=
new Element_Type'(Element_Type'Input (Stream));
Subtree : constant Tree_Node_Access :=
new Tree_Node_Type'
(Parent => Parent, Element => Element, others => <>);
begin
Read_Count := Read_Count + 1;
Read_Children (Subtree);
return Subtree;
end Read_Subtree;
-- Start of processing for Read
begin
Container.Clear; -- checks busy bit
Count_Type'Read (Stream, Total_Count);
if 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;
if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
-- Implement Vet for multiway tree???
-- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad");
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
Busy (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
E, X : Element_Access;
begin
TE_Check (Container.TC);
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;
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
-- RM 4.8(10.1) and AI12-0035).
pragma Unsuppress (Accessibility_Check);
begin
E := new Element_Type'(New_Item);
end;
X := Position.Node.Element;
Position.Node.Element := E;
Free_Element (X);
end Replace_Element;
------------------------------
-- Reverse_Iterate_Children --
------------------------------
procedure Reverse_Iterate_Children
(Parent : Cursor;
Process : not null access procedure (Position : Cursor))
is
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
begin
return Container.Root'Unrestricted_Access;
end Root_Node;
---------------------
-- Splice_Children --
---------------------
procedure Splice_Children
(Target : in out Tree;
Target_Parent : Cursor;
Before : Cursor;
Source : in out Tree;
Source_Parent : Cursor)
is
Count : Count_Type;
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
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;
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;
-- 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
TC_Check (Container.TC);
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;
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
TC_Check (Target.TC);
TC_Check (Source.TC);
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;
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;
-- 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
TC_Check (Container.TC);
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;
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
TE_Check (Container.TC);
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;
declare
EI : constant Element_Access := I.Node.Element;
begin
I.Node.Element := J.Node.Element;
J.Node.Element := EI;
end;
end Swap;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : in out Tree;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
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.all);
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Tree)
is
procedure Write_Children (Subtree : Tree_Node_Access);
procedure Write_Subtree (Subtree : Tree_Node_Access);
--------------------
-- Write_Children --
--------------------
procedure Write_Children (Subtree : Tree_Node_Access) is
CC : Children_Type renames Subtree.Children;
C : Tree_Node_Access;
begin
Count_Type'Write (Stream, Child_Count (CC));
C := CC.First;
while C /= null loop
Write_Subtree (C);
C := C.Next;
end loop;
end Write_Children;
-------------------
-- Write_Subtree --
-------------------
procedure Write_Subtree (Subtree : Tree_Node_Access) is
begin
Element_Type'Output (Stream, Subtree.Element.all);
Write_Children (Subtree);
end Write_Subtree;
-- Start of processing for Write
begin
Count_Type'Write (Stream, Container.Count);
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.Indefinite_Multiway_Trees;