diff options
Diffstat (limited to 'gcc/ada/a-cbmutr.adb')
| -rw-r--r-- | gcc/ada/a-cbmutr.adb | 3327 |
1 files changed, 0 insertions, 3327 deletions
diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb deleted file mode 100644 index 3fe986d..0000000 --- a/gcc/ada/a-cbmutr.adb +++ /dev/null @@ -1,3327 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System; use type System.Address; - -package body Ada.Containers.Bounded_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 - - use Finalization; - - -------------------- - -- Root_Iterator -- - -------------------- - - type Root_Iterator is abstract new Limited_Controlled and - Tree_Iterator_Interfaces.Forward_Iterator with - record - Container : Tree_Access; - Subtree : Count_Type; - 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 -- - ----------------------- - - procedure Initialize_Node (Container : in out Tree; Index : Count_Type); - procedure Initialize_Root (Container : in out Tree); - - procedure Allocate_Node - (Container : in out Tree; - Initialize_Element : not null access procedure (Index : Count_Type); - New_Node : out Count_Type); - - procedure Allocate_Node - (Container : in out Tree; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Allocate_Node - (Container : in out Tree; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type); - - procedure Deallocate_Node - (Container : in out Tree; - X : Count_Type); - - procedure Deallocate_Children - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type); - - procedure Deallocate_Subtree - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type); - - function Equal_Children - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean; - - function Equal_Subtree - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean; - - procedure Iterate_Children - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)); - - procedure Copy_Children - (Source : Tree; - Source_Parent : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Count : in out Count_Type); - - procedure Copy_Subtree - (Source : Tree; - Source_Subtree : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Target_Subtree : out Count_Type; - Count : in out Count_Type); - - function Find_In_Children - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type; - - function Find_In_Subtree - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type; - - function Child_Count - (Container : Tree; - Parent : Count_Type) return Count_Type; - - function Subtree_Node_Count - (Container : Tree; - Subtree : Count_Type) return Count_Type; - - function Is_Reachable - (Container : Tree; - From, To : Count_Type) return Boolean; - - function Root_Node (Container : Tree) return Count_Type; - - procedure Remove_Subtree - (Container : in out Tree; - Subtree : Count_Type); - - procedure Insert_Subtree_Node - (Container : in out Tree; - Subtree : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base); - - procedure Insert_Subtree_List - (Container : in out Tree; - First : Count_Type'Base; - Last : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base); - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source_Parent : Count_Type); - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Source_Parent : Count_Type); - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Position : in out Count_Type); -- source on input, target on output - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Tree) return Boolean is - begin - if Left.Count /= Right.Count then - return False; - end if; - - if Left.Count = 0 then - return True; - end if; - - return Equal_Children - (Left_Tree => Left, - Left_Subtree => Root_Node (Left), - Right_Tree => Right, - Right_Subtree => Root_Node (Right)); - end "="; - - ------------------- - -- Allocate_Node -- - ------------------- - - procedure Allocate_Node - (Container : in out Tree; - Initialize_Element : not null access procedure (Index : Count_Type); - New_Node : out Count_Type) - is - begin - if Container.Free >= 0 then - New_Node := Container.Free; - pragma Assert (New_Node in Container.Elements'Range); - - -- We always perform the assignment first, before we change container - -- state, in order to defend against exceptions duration assignment. - - Initialize_Element (New_Node); - - Container.Free := Container.Nodes (New_Node).Next; - - else - -- A negative free store value means that the links of the nodes in - -- the free store have not been initialized. In this case, the nodes - -- are physically contiguous in the array, starting at the index that - -- is the absolute value of the Container.Free, and continuing until - -- the end of the array (Nodes'Last). - - New_Node := abs Container.Free; - pragma Assert (New_Node in Container.Elements'Range); - - -- As above, we perform this assignment first, before modifying any - -- container state. - - Initialize_Element (New_Node); - - Container.Free := Container.Free - 1; - - if abs Container.Free > Container.Capacity then - Container.Free := 0; - end if; - end if; - - Initialize_Node (Container, New_Node); - end Allocate_Node; - - procedure Allocate_Node - (Container : in out Tree; - New_Item : Element_Type; - New_Node : out Count_Type) - is - procedure Initialize_Element (Index : Count_Type); - - procedure Initialize_Element (Index : Count_Type) is - begin - Container.Elements (Index) := New_Item; - end Initialize_Element; - - begin - Allocate_Node (Container, Initialize_Element'Access, New_Node); - end Allocate_Node; - - procedure Allocate_Node - (Container : in out Tree; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type) - is - procedure Initialize_Element (Index : Count_Type); - - procedure Initialize_Element (Index : Count_Type) is - begin - Element_Type'Read (Stream, Container.Elements (Index)); - end Initialize_Element; - - begin - Allocate_Node (Container, Initialize_Element'Access, New_Node); - end Allocate_Node; - - ------------------- - -- Ancestor_Find -- - ------------------- - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor - is - R, N : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - 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 Position.Container.Elements (N) = Item then - return Cursor'(Position.Container, N); - end if; - - N := Position.Container.Nodes (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 - Nodes : Tree_Node_Array renames Container.Nodes; - First, Last : 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; - - if Count = 0 then - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => No_Node); -- means "insert at end of list" - - Container.Count := Container.Count + Count; - end Append_Child; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Tree; Source : Tree) is - Target_Count : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Count then - raise Capacity_Error -- ??? - with "Target capacity is less than Source count"; - end if; - - Target.Clear; -- Checks busy bit - - if Source.Count = 0 then - return; - end if; - - Initialize_Root (Target); - - -- 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; - - Copy_Children - (Source => Source, - Source_Parent => Root_Node (Source), - Target => Target, - Target_Parent => Root_Node (Target), - Count => 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; - - elsif Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return 0; - - else - return Child_Count (Parent.Container.all, Parent.Node); - end if; - end Child_Count; - - function Child_Count - (Container : Tree; - Parent : Count_Type) return Count_Type - is - NN : Tree_Node_Array renames Container.Nodes; - CC : Children_Type renames NN (Parent).Children; - - Result : Count_Type; - Node : Count_Type'Base; - - begin - Result := 0; - Node := CC.First; - while Node > 0 loop - Result := Result + 1; - Node := NN (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 : Count_Type'Base; - - 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; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - pragma Assert (Child = Parent); - return 0; - end if; - - Result := 0; - N := Child.Node; - while N /= Parent.Node loop - Result := Result + 1; - N := Parent.Container.Nodes (N).Parent; - - if Checks and then N < 0 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 : constant Count_Type := Container.Count; - Count : Count_Type; - - begin - TC_Check (Container.TC); - - if Container_Count = 0 then - return; - end if; - - 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. - - Count := 0; - - Deallocate_Children - (Container => Container, - Subtree => Root_Node (Container), - Count => Count); - - pragma Assert (Count = Container_Count); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements (Position.Node)'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; - Capacity : Count_Type := 0) return Tree - is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Count; - elsif Capacity >= Source.Count then - C := Capacity; - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - return Target : Tree (Capacity => C) do - Initialize_Root (Target); - - if Source.Count = 0 then - return; - end if; - - Copy_Children - (Source => Source, - Source_Parent => Root_Node (Source), - Target => Target, - Target_Parent => Root_Node (Target), - Count => Target.Count); - - pragma Assert (Target.Count = Source.Count); - end return; - end Copy; - - ------------------- - -- Copy_Children -- - ------------------- - - procedure Copy_Children - (Source : Tree; - Source_Parent : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Count : in out Count_Type) - is - S_Nodes : Tree_Node_Array renames Source.Nodes; - S_Node : Tree_Node_Type renames S_Nodes (Source_Parent); - - T_Nodes : Tree_Node_Array renames Target.Nodes; - T_Node : Tree_Node_Type renames T_Nodes (Target_Parent); - - pragma Assert (T_Node.Children.First <= 0); - pragma Assert (T_Node.Children.Last <= 0); - - T_CC : Children_Type; - C : Count_Type'Base; - - begin - -- We special-case the first allocation, in order to establish the - -- representation invariants for type Children_Type. - - C := S_Node.Children.First; - - if C <= 0 then -- source parent has no children - return; - end if; - - Copy_Subtree - (Source => Source, - Source_Subtree => C, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T_CC.First, - Count => Count); - - T_CC.Last := T_CC.First; - - -- The representation invariants for the Children_Type list have been - -- established, so we can now copy the remaining children of Source. - - C := S_Nodes (C).Next; - while C > 0 loop - Copy_Subtree - (Source => Source, - Source_Subtree => C, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T_Nodes (T_CC.Last).Next, - Count => Count); - - T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last; - T_CC.Last := T_Nodes (T_CC.Last).Next; - - C := S_Nodes (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. - - T_Node.Children := T_CC; - end Copy_Children; - - ------------------ - -- Copy_Subtree -- - ------------------ - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor) - is - Target_Subtree : Count_Type; - 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.Container.Nodes (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; - - if Target.Count = 0 then - Initialize_Root (Target); - 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.Container.all, - Source_Subtree => Source.Node, - Target => Target, - Target_Parent => Parent.Node, - Target_Subtree => Target_Subtree, - Count => Target_Count); - - Insert_Subtree_Node - (Container => Target, - Subtree => Target_Subtree, - Parent => Parent.Node, - Before => Before.Node); - - Target.Count := Target.Count + Target_Count; - end Copy_Subtree; - - procedure Copy_Subtree - (Source : Tree; - Source_Subtree : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Target_Subtree : out Count_Type; - Count : in out Count_Type) - is - T_Nodes : Tree_Node_Array renames Target.Nodes; - - begin - -- First we allocate the root of the target subtree. - - Allocate_Node - (Container => Target, - New_Item => Source.Elements (Source_Subtree), - New_Node => Target_Subtree); - - T_Nodes (Target_Subtree).Parent := Target_Parent; - Count := Count + 1; - - -- We now have a new subtree (for the Target tree), containing only a - -- copy of the corresponding element in the Source subtree. Next we copy - -- the children of the Source subtree as children of the new Target - -- subtree. - - Copy_Children - (Source => Source, - Source_Parent => Source_Subtree, - Target => Target, - Target_Parent => Target_Subtree, - Count => Count); - end Copy_Subtree; - - ------------------------- - -- Deallocate_Children -- - ------------------------- - - procedure Deallocate_Children - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type) - is - Nodes : Tree_Node_Array renames Container.Nodes; - Node : Tree_Node_Type renames Nodes (Subtree); -- parent - CC : Children_Type renames Node.Children; - C : Count_Type'Base; - - begin - while CC.First > 0 loop - C := CC.First; - CC.First := Nodes (C).Next; - - Deallocate_Subtree (Container, C, Count); - end loop; - - CC.Last := 0; - end Deallocate_Children; - - --------------------- - -- Deallocate_Node -- - --------------------- - - procedure Deallocate_Node - (Container : in out Tree; - X : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - pragma Assert (X > 0); - pragma Assert (X <= NN'Last); - - N : Tree_Node_Type renames NN (X); - pragma Assert (N.Parent /= X); -- node is active - - begin - -- The tree container actually contains two lists: one for the "active" - -- nodes that contain elements that have been inserted onto the tree, - -- and another for the "inactive" nodes of the free store, from which - -- nodes are allocated when a new child is inserted in the tree. - - -- We desire that merely declaring a tree object should have only - -- minimal cost; specially, we want to avoid having to initialize the - -- free store (to fill in the links), especially if the capacity of the - -- tree object is large. - - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized in - -- the "normal" way: Container.Free points to the head of the list of - -- free (inactive) nodes, and the value 0 means the free list is - -- empty. Each node on the free list has been initialized to point to - -- the next free node (via its Next component), and the value 0 means - -- that this is the last node of the free list. - - -- If Container.Free is negative, then the links on the free store have - -- not been initialized. In this case the link values are implied: the - -- free store comprises the components of the node array started with - -- the absolute value of Container.Free, and continuing until the end of - -- the array (Nodes'Last). - - -- We prefer to lazy-init the free store (in fact, we would prefer to - -- not initialize it at all, because such initialization is an O(n) - -- operation). The time when we need to actually initialize the nodes in - -- the free store is when the node that becomes inactive is not at the - -- end of the active list. The free store would then be discontigous and - -- so its nodes would need to be linked in the traditional way. - - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one comprising - -- the non-contiguous inactive nodes linked together in the normal way, - -- and the other comprising the contiguous inactive nodes (that are not - -- linked together, at the end of the nodes array). This would allow us - -- to never have to initialize the free store, except in a lazy way as - -- nodes become inactive. ??? - - -- When an element is deleted from the list container, its node becomes - -- inactive, and so we set its Parent and Prev components to an - -- impossible value (the index of the node itself), to indicate that it - -- is now inactive. This provides a useful way to detect a dangling - -- cursor reference. - - N.Parent := X; -- Node is deallocated (not on active list) - N.Prev := X; - - if Container.Free >= 0 then - -- The free store has previously been initialized. All we need to do - -- here is link the newly-free'd node onto the free list. - - N.Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - N.Next := X; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- See the comments above for an optimization opportunity. If the - -- next link for a node on the free store is negative, then this - -- means the remaining nodes on the free store are physically - -- contiguous, starting at the absolute value of that index value. - -- ??? - - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for J in Container.Free .. Container.Capacity - 1 loop - NN (J).Next := J + 1; - end loop; - - NN (Container.Capacity).Next := 0; - end if; - - NN (X).Next := Container.Free; - Container.Free := X; - end if; - end Deallocate_Node; - - ------------------------ - -- Deallocate_Subtree -- - ------------------------ - - procedure Deallocate_Subtree - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type) - is - begin - Deallocate_Children (Container, Subtree, Count); - Deallocate_Node (Container, 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); - - if Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - 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 (Container, 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 : 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; - - 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; - - Remove_Subtree (Container, X); - Container.Count := Container.Count - 1; - - Deallocate_Node (Container, X); - end Delete_Leaf; - - -------------------- - -- Delete_Subtree -- - -------------------- - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor) - is - X : Count_Type; - 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; - - Remove_Subtree (Container, 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 (Container, X, Count); - pragma Assert (Count <= Container.Count); - - Container.Count := Container.Count - Count; - end Delete_Subtree; - - ----------- - -- Depth -- - ----------- - - function Depth (Position : Cursor) return Count_Type is - Result : Count_Type; - N : Count_Type'Base; - - begin - if Position = No_Element then - return 0; - end if; - - if Is_Root (Position) then - return 1; - end if; - - Result := 0; - N := Position.Node; - while N >= 0 loop - N := Position.Container.Nodes (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.Container.Elements (Position.Node); - end Element; - - -------------------- - -- Equal_Children -- - -------------------- - - function Equal_Children - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean - is - L_NN : Tree_Node_Array renames Left_Tree.Nodes; - R_NN : Tree_Node_Array renames Right_Tree.Nodes; - - Left_Children : Children_Type renames L_NN (Left_Subtree).Children; - Right_Children : Children_Type renames R_NN (Right_Subtree).Children; - - L, R : Count_Type'Base; - - begin - if Child_Count (Left_Tree, Left_Subtree) - /= Child_Count (Right_Tree, Right_Subtree) - then - return False; - end if; - - L := Left_Children.First; - R := Right_Children.First; - while L > 0 loop - if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then - return False; - end if; - - L := L_NN (L).Next; - R := R_NN (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; - - if Left_Position.Container.Count = 0 then - return Right_Position.Container.Count = 0; - end if; - - if Right_Position.Container.Count = 0 then - return False; - end if; - - return Equal_Children - (Left_Tree => Left_Position.Container.all, - Left_Subtree => Left_Position.Node, - Right_Tree => Right_Position.Container.all, - Right_Subtree => Right_Position.Node); - end if; - - if Is_Root (Right_Position) then - return False; - end if; - - return Equal_Subtree - (Left_Tree => Left_Position.Container.all, - Left_Subtree => Left_Position.Node, - Right_Tree => Right_Position.Container.all, - Right_Subtree => Right_Position.Node); - end Equal_Subtree; - - function Equal_Subtree - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean - is - begin - if Left_Tree.Elements (Left_Subtree) /= - Right_Tree.Elements (Right_Subtree) - then - return False; - end if; - - return Equal_Children - (Left_Tree => Left_Tree, - Left_Subtree => Left_Subtree, - Right_Tree => Right_Tree, - Right_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 - Node : Count_Type; - - begin - if Container.Count = 0 then - return No_Element; - end if; - - Node := Find_In_Children (Container, Root_Node (Container), Item); - - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - 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 : Count_Type'Base; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return No_Element; - end if; - - Node := Parent.Container.Nodes (Parent.Node).Children.First; - - if Node <= 0 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 - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type - is - N : Count_Type'Base; - Result : Count_Type; - - begin - N := Container.Nodes (Subtree).Children.First; - while N > 0 loop - Result := Find_In_Subtree (Container, N, Item); - - if Result > 0 then - return Result; - end if; - - N := Container.Nodes (N).Next; - end loop; - - return 0; - end Find_In_Children; - - --------------------- - -- Find_In_Subtree -- - --------------------- - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor - is - Result : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented-out pending ruling by ARG. ??? - - -- if Checks and then - -- Position.Container /= Container'Unrestricted_Access - -- then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - if Is_Root (Position) then - Result := Find_In_Children - (Container => Position.Container.all, - Subtree => Position.Node, - Item => Item); - - else - Result := Find_In_Subtree - (Container => Position.Container.all, - Subtree => Position.Node, - Item => Item); - end if; - - if Result = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Result); - end Find_In_Subtree; - - function Find_In_Subtree - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type - is - begin - if Container.Elements (Subtree) = Item then - return Subtree; - end if; - - return Find_In_Children (Container, Subtree, Item); - end Find_In_Subtree; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Elements (Position.Node)'Access; - 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 /= Root_Node (Position.Container.all); - end Has_Element; - - --------------------- - -- Initialize_Node -- - --------------------- - - procedure Initialize_Node - (Container : in out Tree; - Index : Count_Type) - is - begin - Container.Nodes (Index) := - (Parent => No_Node, - Prev => 0, - Next => 0, - Children => (others => 0)); - end Initialize_Node; - - --------------------- - -- Initialize_Root -- - --------------------- - - procedure Initialize_Root (Container : in out Tree) is - begin - Initialize_Node (Container, Root_Node (Container)); - end Initialize_Root; - - ------------------ - -- 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 - Nodes : Tree_Node_Array renames Container.Nodes; - First : Count_Type; - Last : 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; - - 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.Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First : Count_Type; - Last : Count_Type; - - New_Item : Element_Type; - pragma Unmodified (New_Item); - -- OK to reference, see below - - 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.Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - -- There is no explicit element provided, but in an instance the element - -- type may be a scalar with a Default_Value aspect, or a composite - -- type with such a scalar component, or components with default - -- initialization, so insert the specified number of possibly - -- initialized elements at the given position. - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - ------------------------- - -- Insert_Subtree_List -- - ------------------------- - - procedure Insert_Subtree_List - (Container : in out Tree; - First : Count_Type'Base; - Last : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Parent); - CC : Children_Type renames N.Children; - - begin - -- This is a simple utility operation to insert a list of nodes - -- (First..Last) as children of Parent. The Before node specifies where - -- the new children should be inserted relative to existing children. - - if First <= 0 then - pragma Assert (Last <= 0); - return; - end if; - - pragma Assert (Last > 0); - pragma Assert (Before <= 0 or else NN (Before).Parent = Parent); - - if CC.First <= 0 then -- no existing children - CC.First := First; - NN (CC.First).Prev := 0; - CC.Last := Last; - NN (CC.Last).Next := 0; - - elsif Before <= 0 then -- means "insert after existing nodes" - NN (CC.Last).Next := First; - NN (First).Prev := CC.Last; - CC.Last := Last; - NN (CC.Last).Next := 0; - - elsif Before = CC.First then - NN (Last).Next := CC.First; - NN (CC.First).Prev := Last; - CC.First := First; - NN (CC.First).Prev := 0; - - else - NN (NN (Before).Prev).Next := First; - NN (First).Prev := NN (Before).Prev; - NN (Last).Next := Before; - NN (Before).Prev := Last; - end if; - end Insert_Subtree_List; - - ------------------------- - -- Insert_Subtree_Node -- - ------------------------- - - procedure Insert_Subtree_Node - (Container : in out Tree; - Subtree : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base) - is - begin - -- This is a simple wrapper operation to insert a single child into the - -- Parent's children list. - - Insert_Subtree_List - (Container => Container, - 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.Count = 0; - end Is_Empty; - - ------------- - -- Is_Leaf -- - ------------- - - function Is_Leaf (Position : Cursor) return Boolean is - begin - if Position = No_Element then - return False; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return True; - end if; - - return Position.Container.Nodes (Position.Node).Children.First <= 0; - end Is_Leaf; - - ------------------ - -- Is_Reachable -- - ------------------ - - function Is_Reachable - (Container : Tree; - From, To : Count_Type) return Boolean - is - Idx : Count_Type; - - begin - Idx := From; - while Idx >= 0 loop - if Idx = To then - return True; - end if; - - Idx := Container.Nodes (Idx).Parent; - end loop; - - return False; - end Is_Reachable; - - ------------- - -- Is_Root -- - ------------- - - function Is_Root (Position : Cursor) return Boolean is - begin - return - (if Position.Container = null then False - else Position.Node = Root_Node (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 - if Container.Count = 0 then - return; - end if; - - Iterate_Children - (Container => Container, - 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 - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - end if; - - declare - C : Count_Type; - NN : Tree_Node_Array renames Parent.Container.Nodes; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - - begin - C := NN (Parent.Node).Children.First; - while C > 0 loop - Process (Cursor'(Parent.Container, Node => C)); - C := NN (C).Next; - end loop; - end; - end Iterate_Children; - - procedure Iterate_Children - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Subtree); - C : Count_Type; - - 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 - -- itself. This is useful when starting from the ultimate root of the - -- entire tree (see Iterate), as that root does not have an element. - - C := N.Children.First; - while C > 0 loop - Iterate_Subtree (Container, C, Process); - C := NN (C).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 => C, - Subtree => Position.Node) - do - Busy (C.TC); - end return; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return; - end if; - - declare - T : Tree renames Position.Container.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - begin - if Is_Root (Position) then - Iterate_Children (T, Position.Node, Process); - else - Iterate_Subtree (T, Position.Node, Process); - end if; - end; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Container : Tree; - Subtree : Count_Type; - 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'Unrestricted_Access, 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 : Count_Type'Base; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return No_Element; - end if; - - Node := Parent.Container.Nodes (Parent.Node).Children.Last; - - if Node <= 0 then - return No_Element; - end if; - - return Cursor'(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 - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - overriding function Next - (Object : Subtree_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; - - pragma Assert (Object.Container.Count > 0); - pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - - declare - Nodes : Tree_Node_Array renames Object.Container.Nodes; - Node : Count_Type; - - begin - Node := Position.Node; - - if Nodes (Node).Children.First > 0 then - return Cursor'(Object.Container, Nodes (Node).Children.First); - end if; - - while Node /= Object.Subtree loop - if Nodes (Node).Next > 0 then - return Cursor'(Object.Container, Nodes (Node).Next); - end if; - - Node := Nodes (Node).Parent; - end loop; - - return No_Element; - end; - end Next; - - overriding 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; - - pragma Assert (Object.Container.Count > 0); - pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - - 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.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Next <= 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, N.Next); - end; - 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.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Parent < 0 then - pragma Assert (Position.Node = Root_Node (T)); - return No_Element; - end if; - - return Cursor'(Position.Container, N.Parent); - end; - end Parent; - - ------------------- - -- Prepend_Child -- - ------------------- - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First, Last : 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; - - if Count = 0 then - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Nodes (Parent.Node).Children.First); - - 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.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Prev <= 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, N.Prev); - end; - 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 - 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; - - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Element => T.Elements (Position.Node)); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree) - is - procedure Read_Children (Subtree : Count_Type); - - function Read_Subtree - (Parent : Count_Type) return Count_Type; - - NN : Tree_Node_Array renames Container.Nodes; - - 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 : Count_Type) is - Count : Count_Type'Base; - -- number of child subtrees - - CC : 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; - - CC.First := Read_Subtree (Parent => Subtree); - CC.Last := CC.First; - - for J in Count_Type'(2) .. Count loop - NN (CC.Last).Next := Read_Subtree (Parent => Subtree); - NN (NN (CC.Last).Next).Prev := CC.Last; - CC.Last := NN (CC.Last).Next; - end loop; - - -- Now that the allocation and reads have completed successfully, it - -- is safe to link the children to their parent. - - NN (Subtree).Children := CC; - end Read_Children; - - ------------------ - -- Read_Subtree -- - ------------------ - - function Read_Subtree - (Parent : Count_Type) return Count_Type - is - Subtree : Count_Type; - - begin - Allocate_Node (Container, Stream, Subtree); - Container.Nodes (Subtree).Parent := Parent; - - 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; - - if Checks and then Total_Count > Container.Capacity then - raise Capacity_Error -- ??? - with "node count in stream exceeds container capacity"; - end if; - - Initialize_Root (Container); - - Read_Count := 0; - - Read_Children (Root_Node (Container)); - - if Checks and then Read_Count /= Total_Count then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - Container.Count := Total_Count; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to read tree cursor from stream"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - -------------------- - -- Remove_Subtree -- - -------------------- - - procedure Remove_Subtree - (Container : in out Tree; - Subtree : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Subtree); - CC : Children_Type renames NN (N.Parent).Children; - - begin - -- This is a utility operation to remove a subtree node from its - -- parent's list of children. - - if CC.First = Subtree then - pragma Assert (N.Prev <= 0); - - if CC.Last = Subtree then - pragma Assert (N.Next <= 0); - CC.First := 0; - CC.Last := 0; - - else - CC.First := N.Next; - NN (CC.First).Prev := 0; - end if; - - elsif CC.Last = Subtree then - pragma Assert (N.Next <= 0); - CC.Last := N.Prev; - NN (CC.Last).Next := 0; - - else - NN (N.Prev).Next := N.Next; - NN (N.Next).Prev := N.Prev; - end if; - end Remove_Subtree; - - ---------------------- - -- Replace_Element -- - ---------------------- - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TE_Check (Container.TC); - - Container.Elements (Position.Node) := New_Item; - end Replace_Element; - - ------------------------------ - -- Reverse_Iterate_Children -- - ------------------------------ - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - end if; - - declare - NN : Tree_Node_Array renames Parent.Container.Nodes; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - C : Count_Type; - - begin - C := NN (Parent.Node).Children.Last; - while C > 0 loop - Process (Cursor'(Parent.Container, Node => C)); - C := NN (C).Prev; - end loop; - end; - end Reverse_Iterate_Children; - - ---------- - -- Root -- - ---------- - - function Root (Container : Tree) return Cursor is - begin - return (Container'Unrestricted_Access, Root_Node (Container)); - end Root; - - --------------- - -- Root_Node -- - --------------- - - function Root_Node (Container : Tree) return Count_Type is - pragma Unreferenced (Container); - - begin - return 0; - 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 - 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 - Target.Nodes (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 Source.Count = 0 then - pragma Assert (Is_Root (Source_Parent)); - return; - 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 (Container => Target, - From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Container => Target, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - if Target.Count = 0 then - Initialize_Root (Target); - end if; - - Splice_Children - (Target => Target, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source => Source, - Source_Parent => Source_Parent.Node); - 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 - Container.Nodes (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; - - pragma Assert (Container.Count > 0); - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (Container => Container, - From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Container => Container, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - end Splice_Children; - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source_Parent : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - CC : constant Children_Type := NN (Source_Parent).Children; - C : Count_Type'Base; - - begin - -- This is a utility operation to remove the children from Source parent - -- and insert them into Target parent. - - NN (Source_Parent).Children := Children_Type'(others => 0); - - -- Fix up the Parent pointers of each child to designate its new Target - -- parent. - - C := CC.First; - while C > 0 loop - NN (C).Parent := Target_Parent; - C := NN (C).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => CC.First, - Last => CC.Last, - Parent => Target_Parent, - Before => Before); - end Splice_Children; - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Source_Parent : Count_Type) - is - S_NN : Tree_Node_Array renames Source.Nodes; - S_CC : Children_Type renames S_NN (Source_Parent).Children; - - Target_Count, Source_Count : Count_Type; - T, S : Count_Type'Base; - - begin - -- This is a utility operation to copy the children from the Source - -- parent and insert them as children of the Target parent, and then - -- delete them from the Source. (This is not a true splice operation, - -- but it is the best we can do in a bounded form.) The Before position - -- specifies where among the Target parent's exising children the new - -- children are inserted. - - -- Before we attempt the insertion, we must count the sources nodes in - -- order to determine whether the target have enough storage - -- available. Note that calculating this value is an O(n) operation. - - -- Here is an optimization opportunity: iterate of each children the - -- source explicitly, and keep a running count of the total number of - -- nodes. Compare the running total to the capacity of the target each - -- pass through the loop. This is more efficient than summing the counts - -- of child subtree (which is what Subtree_Node_Count does) and then - -- comparing that total sum to the target's capacity. ??? - - -- Here is another possibility. We currently treat the splice as an - -- all-or-nothing proposition: either we can insert all of children of - -- the source, or we raise exception with modifying the target. The - -- price for not causing side-effect is an O(n) determination of the - -- source count. If we are willing to tolerate side-effect, then we - -- could loop over the children of the source, counting that subtree and - -- then immediately inserting it in the target. The issue here is that - -- the test for available storage could fail during some later pass, - -- after children have already been inserted into target. ??? - - Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1; - - if Source_Count = 0 then - return; - end if; - - if Checks and then Target.Count > Target.Capacity - Source_Count then - raise Capacity_Error -- ??? - with "Source count exceeds available storage on Target"; - end if; - - -- Copy_Subtree returns a count of the number of nodes it inserts, but - -- it does this by incrementing the value passed in. Therefore we must - -- initialize the count before calling Copy_Subtree. - - Target_Count := 0; - - S := S_CC.First; - while S > 0 loop - Copy_Subtree - (Source => Source, - Source_Subtree => S, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T, - Count => Target_Count); - - Insert_Subtree_Node - (Container => Target, - Subtree => T, - Parent => Target_Parent, - Before => Before); - - S := S_NN (S).Next; - end loop; - - pragma Assert (Target_Count = Source_Count); - Target.Count := Target.Count + Target_Count; - - -- As with Copy_Subtree, operation Deallocate_Children returns a count - -- of the number of nodes it deallocates, but it works by incrementing - -- the value passed in. We must therefore initialize the count before - -- calling it. - - Source_Count := 0; - - Deallocate_Children (Source, Source_Parent, Source_Count); - pragma Assert (Source_Count = Target_Count); - - Source.Count := Source.Count - Source_Count; - 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 - 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 Target.Nodes (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 Target.Nodes (Position.Node).Parent = Parent.Node then - if Before = No_Element then - if Target.Nodes (Position.Node).Next <= 0 then -- last child - return; - end if; - - elsif Position.Node = Before.Node then - return; - - elsif Target.Nodes (Position.Node).Next = Before.Node then - return; - end if; - end if; - - TC_Check (Target.TC); - - if Checks and then Is_Reachable (Container => Target, - From => Parent.Node, - To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Target, Position.Node); - - Target.Nodes (Position.Node).Parent := Parent.Node; - Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - if Target.Count = 0 then - Initialize_Root (Target); - end if; - - Splice_Subtree - (Target => Target, - Parent => Parent.Node, - Before => Before.Node, - Source => Source, - Position => Position.Node); -- modified during call - - 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 Container.Nodes (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 Container.Nodes (Position.Node).Parent = Parent.Node then - if Before = No_Element then - if Container.Nodes (Position.Node).Next <= 0 then -- last child - return; - end if; - - elsif Position.Node = Before.Node then - return; - - elsif Container.Nodes (Position.Node).Next = Before.Node then - return; - end if; - end if; - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (Container => Container, - From => Parent.Node, - To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Container, Position.Node); - Container.Nodes (Position.Node).Parent := Parent.Node; - Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node); - end Splice_Subtree; - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Position : in out Count_Type) -- Source on input, Target on output - is - Source_Count : Count_Type := Subtree_Node_Count (Source, Position); - pragma Assert (Source_Count >= 1); - - Target_Subtree : Count_Type; - Target_Count : Count_Type; - - begin - -- This is a utility operation to do the heavy lifting associated with - -- splicing a subtree from one tree to another. Note that "splicing" - -- is a bit of a misnomer here in the case of a bounded tree, because - -- the elements must be copied from the source to the target. - - if Checks and then Target.Count > Target.Capacity - Source_Count then - raise Capacity_Error -- ??? - with "Source count exceeds available storage on Target"; - end if; - - -- Copy_Subtree returns a count of the number of nodes it inserts, but - -- it does this by incrementing the value passed in. Therefore we must - -- initialize the count before calling Copy_Subtree. - - Target_Count := 0; - - Copy_Subtree - (Source => Source, - Source_Subtree => Position, - Target => Target, - Target_Parent => Parent, - Target_Subtree => Target_Subtree, - Count => Target_Count); - - pragma Assert (Target_Count = Source_Count); - - -- Now link the newly-allocated subtree into the target. - - Insert_Subtree_Node - (Container => Target, - Subtree => Target_Subtree, - Parent => Parent, - Before => Before); - - Target.Count := Target.Count + Target_Count; - - -- The manipulation of the Target container is complete. Now we remove - -- the subtree from the Source container. - - Remove_Subtree (Source, Position); -- unlink the subtree - - -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of - -- the number of nodes it deallocates, but it works by incrementing the - -- value passed in. We must therefore initialize the count before - -- calling it. - - Source_Count := 0; - - Deallocate_Subtree (Source, Position, Source_Count); - pragma Assert (Source_Count = Target_Count); - - Source.Count := Source.Count - Source_Count; - - Position := Target_Subtree; - 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; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return 1; - end if; - - return Subtree_Node_Count (Position.Container.all, Position.Node); - end Subtree_Node_Count; - - function Subtree_Node_Count - (Container : Tree; - Subtree : Count_Type) return Count_Type - is - Result : Count_Type; - Node : Count_Type'Base; - - begin - Result := 1; - Node := Container.Nodes (Subtree).Children.First; - while Node > 0 loop - Result := Result + Subtree_Node_Count (Container, Node); - Node := Container.Nodes (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 - EE : Element_Array renames Container.Elements; - EI : constant Element_Type := EE (I.Node); - - begin - EE (I.Node) := EE (J.Node); - EE (J.Node) := EI; - end; - end Swap; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if 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 - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Element => T.Elements (Position.Node)); - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree) - is - procedure Write_Children (Subtree : Count_Type); - procedure Write_Subtree (Subtree : Count_Type); - - -------------------- - -- Write_Children -- - -------------------- - - procedure Write_Children (Subtree : Count_Type) is - CC : Children_Type renames Container.Nodes (Subtree).Children; - C : Count_Type'Base; - - begin - Count_Type'Write (Stream, Child_Count (Container, Subtree)); - - C := CC.First; - while C > 0 loop - Write_Subtree (C); - C := Container.Nodes (C).Next; - end loop; - end Write_Children; - - ------------------- - -- Write_Subtree -- - ------------------- - - procedure Write_Subtree (Subtree : Count_Type) is - begin - Element_Type'Write (Stream, Container.Elements (Subtree)); - 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.Bounded_Multiway_Trees; |