Mercurial > hg > CbC > CbC_gcc
view gcc/ada/libgnat/a-cbmutr.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line source
------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.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; pragma Warnings (Off); Default_Initialized_Item : Element_Type; pragma Unmodified (Default_Initialized_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, 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; 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;