Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/libgnat/a-cimutr.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/libgnat/a-cimutr.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,2698 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Multiway_Trees is + + 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 + 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); + + 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 + 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; + + -- 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 + 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 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; + 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; + Element : Element_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); + + 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; + + ------------------- + -- Prepent_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + Element : Element_Access; + + begin + if 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); + + 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 + 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.all); + 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 + 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 + 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 + E, X : Element_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; + + TE_Check (Container.TC); + + 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 + 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_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;