| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT LIBRARY COMPONENTS -- |
| -- -- |
| -- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2011-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- This unit was originally developed by Matthew J Heaney. -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Finalization; |
| with System; use type System.Address; |
| with System.Put_Images; |
| |
| package body Ada.Containers.Bounded_Multiway_Trees with |
| SPARK_Mode => Off |
| is |
| |
| pragma Warnings (Off, "variable ""Busy*"" is not referenced"); |
| pragma Warnings (Off, "variable ""Lock*"" is not referenced"); |
| -- See comment in Ada.Containers.Helpers |
| |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if Count = 0 then |
| return; |
| end if; |
| |
| if Checks and then Container.Count > Container.Capacity - Count then |
| raise Capacity_Error |
| with "requested count exceeds available storage"; |
| end if; |
| |
| 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)'Unchecked_Access, |
| Control => (Controlled with TC)) |
| do |
| Busy (TC.all); |
| end return; |
| end; |
| end Constant_Reference; |
| |
| -------------- |
| -- Contains -- |
| -------------- |
| |
| function Contains |
| (Container : Tree; |
| Item : Element_Type) return Boolean |
| is |
| begin |
| return Find (Container, Item) /= No_Element; |
| end Contains; |
| |
| ---------- |
| -- Copy -- |
| ---------- |
| |
| function Copy |
| (Source : Tree; |
| Capacity : Count_Type := 0) return Tree |
| is |
| C : constant Count_Type := |
| (if Capacity = 0 then Source.Count |
| else Capacity); |
| begin |
| if Checks and then C < Source.Count then |
| raise Capacity_Error with "Capacity 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Position = No_Element then |
| raise Constraint_Error with "Position cursor has no element"; |
| end if; |
| |
| if Checks and then Position.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Position cursor not in container"; |
| end if; |
| |
| if Checks and then Is_Root (Position) then |
| raise Program_Error with "Position cursor designates root"; |
| end if; |
| |
| if Checks and then not Is_Leaf (Position) then |
| raise Constraint_Error with "Position cursor does not designate leaf"; |
| end if; |
| |
| X := Position.Node; |
| Position := No_Element; |
| |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Position = No_Element then |
| raise Constraint_Error with "Position cursor has no element"; |
| end if; |
| |
| if Checks and then Position.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Position cursor not in container"; |
| end if; |
| |
| if Checks and then Is_Root (Position) then |
| raise Program_Error with "Position cursor designates root"; |
| end if; |
| |
| X := Position.Node; |
| Position := No_Element; |
| |
| 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; |
| |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Before cursor not in container"; |
| end if; |
| |
| if Checks and then |
| Before.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; |
| |
| 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; |
| |
| pragma Warnings (Off); |
| Default_Initialized_Item : Element_Type; |
| pragma Unmodified (Default_Initialized_Item); |
| -- OK to reference, see below |
| |
| begin |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Before cursor not in container"; |
| end if; |
| |
| if Checks and then |
| Before.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; |
| |
| 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, Default_Initialized_Item, First); |
| Nodes (First).Parent := Parent.Node; |
| |
| Last := First; |
| for J in Count_Type'(2) .. Count loop |
| Allocate_Node |
| (Container, Default_Initialized_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); |
| pragma Warnings (On); |
| 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'Base := From; |
| begin |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if Count = 0 then |
| return; |
| end if; |
| |
| if Checks and then Container.Count > Container.Capacity - Count then |
| raise Capacity_Error |
| with "requested count exceeds available storage"; |
| end if; |
| |
| 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 |
| Busy (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; |
| |
| --------------- |
| -- Put_Image -- |
| --------------- |
| |
| procedure Put_Image |
| (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree) |
| is |
| use System.Put_Images; |
| |
| procedure Rec (Position : Cursor); |
| -- Recursive routine operating on cursors |
| |
| procedure Rec (Position : Cursor) is |
| First_Time : Boolean := True; |
| begin |
| Array_Before (S); |
| |
| for X in Iterate_Children (V, Position) loop |
| if First_Time then |
| First_Time := False; |
| else |
| Array_Between (S); |
| end if; |
| |
| Element_Type'Put_Image (S, Element (X)); |
| if Child_Count (X) > 0 then |
| Simple_Array_Between (S); |
| Rec (X); |
| end if; |
| end loop; |
| |
| Array_After (S); |
| end Rec; |
| |
| begin |
| if First_Child (Root (V)) = No_Element then |
| Array_Before (S); |
| Array_After (S); |
| else |
| Rec (First_Child (Root (V))); |
| end if; |
| end Put_Image; |
| |
| ---------- |
| -- Read -- |
| ---------- |
| |
| procedure Read |
| (Stream : not null access Root_Stream_Type'Class; |
| Container : out Tree) |
| is |
| procedure Read_Children (Subtree : 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)'Unchecked_Access, |
| Control => (Controlled with TC)) |
| do |
| Busy (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 |
| TE_Check (Container.TC); |
| |
| if Checks and then Position = No_Element then |
| raise Constraint_Error with "Position cursor has no element"; |
| end if; |
| |
| if Checks and then Position.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Position cursor not in container"; |
| end if; |
| |
| if Checks and then Is_Root (Position) then |
| raise Program_Error with "Position cursor designates root"; |
| end if; |
| |
| 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 |
| TC_Check (Target.TC); |
| TC_Check (Source.TC); |
| |
| if Checks and then Target_Parent = No_Element then |
| raise Constraint_Error with "Target_Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Target_Parent.Container /= Target'Unrestricted_Access |
| then |
| raise Program_Error |
| with "Target_Parent cursor not in Target container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Target'Unrestricted_Access then |
| raise Program_Error |
| with "Before cursor not in Target container"; |
| end if; |
| |
| if Checks and then |
| 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; |
| |
| 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; |
| |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Target_Parent = No_Element then |
| raise Constraint_Error with "Target_Parent cursor has no element"; |
| end if; |
| |
| if Checks and then |
| Target_Parent.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error |
| with "Target_Parent cursor not in container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error |
| with "Before cursor not in container"; |
| end if; |
| |
| if Checks and then |
| 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); |
| |
| 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 |
| TC_Check (Target.TC); |
| TC_Check (Source.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Target'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in Target container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Target'Unrestricted_Access then |
| raise Program_Error with "Before cursor not in Target container"; |
| end if; |
| |
| if Checks and then 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; |
| |
| 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; |
| |
| 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 |
| TC_Check (Container.TC); |
| |
| if Checks and then Parent = No_Element then |
| raise Constraint_Error with "Parent cursor has no element"; |
| end if; |
| |
| if Checks and then Parent.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "Parent cursor not in container"; |
| end if; |
| |
| if Before /= No_Element then |
| if Checks and then Before.Container /= Container'Unrestricted_Access |
| then |
| raise Program_Error with "Before cursor not in container"; |
| end if; |
| |
| if Checks and then 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; |
| |
| 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 |
| TE_Check (Container.TC); |
| |
| if Checks and then I = No_Element then |
| raise Constraint_Error with "I cursor has no element"; |
| end if; |
| |
| if Checks and then I.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "I cursor not in container"; |
| end if; |
| |
| if Checks and then Is_Root (I) then |
| raise Program_Error with "I cursor designates root"; |
| end if; |
| |
| if I = J then -- make this test sooner??? |
| return; |
| end if; |
| |
| if Checks and then J = No_Element then |
| raise Constraint_Error with "J cursor has no element"; |
| end if; |
| |
| if Checks and then J.Container /= Container'Unrestricted_Access then |
| raise Program_Error with "J cursor not in container"; |
| end if; |
| |
| if Checks and then Is_Root (J) then |
| raise Program_Error with "J cursor designates root"; |
| end if; |
| |
| declare |
| 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; |