From ffd8b3a5ecc3dd7d1a7c3e1938b6caa1ff221ded Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 5 Aug 2011 15:17:37 +0000 Subject: 2011-08-05 Thomas Quinot * sem_ch11.adb: Add comment. 2011-08-05 Robert Dewar * exp_util.adb: Minor comment fix. 2011-08-05 Robert Dewar * scng.adb (Error_Unterminated_String): Improve flag position when comma present. 2011-08-05 Matthew Heaney * Makefile.rtl, impunit.adb: Added a-cbmutr.ad[sb] (bounded multiway tree containers). * a-cbmutr.ads, a-cbmutr.adb: This is the new Ada 2012 unit for bounded multiway tree containers. 2011-08-05 Robert Dewar * styleg.adb (Check_Comment): Implement comment spacing of 1 or 2 * stylesw.adb: Implement -gnatyC to control comment spacing * stylesw.ads (Style_Check_Comments_Spacing): New switch (set by -gnatyc/C). * usage.adb: Add line for -gnatyC. 2011-08-05 Robert Dewar * gnat_ugn.texi: Document -gnatyC for J505-006 * vms_data.ads: Implement COMMENTS1/COMMENTS2 (retaining COMMENTS as a synonym for COMMENTS2). git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177453 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 34 + gcc/ada/Makefile.rtl | 1 + gcc/ada/a-cbmutr.adb | 3042 +++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-cbmutr.ads | 321 ++++++ gcc/ada/exp_util.adb | 10 +- gcc/ada/gnat_ugn.texi | 9 +- gcc/ada/impunit.adb | 1 + gcc/ada/scng.adb | 29 + gcc/ada/sem_ch11.adb | 5 +- gcc/ada/styleg.adb | 19 +- gcc/ada/stylesw.adb | 17 +- gcc/ada/stylesw.ads | 8 +- gcc/ada/usage.adb | 5 +- gcc/ada/vms_data.ads | 15 +- 14 files changed, 3488 insertions(+), 28 deletions(-) create mode 100644 gcc/ada/a-cbmutr.adb create mode 100644 gcc/ada/a-cbmutr.ads (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c686c29da1b..3ca2a71c1df 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2011-08-05 Thomas Quinot + + * sem_ch11.adb: Add comment. + +2011-08-05 Robert Dewar + + * exp_util.adb: Minor comment fix. + +2011-08-05 Robert Dewar + + * scng.adb (Error_Unterminated_String): Improve flag position when + comma present. + +2011-08-05 Matthew Heaney + + * Makefile.rtl, impunit.adb: Added a-cbmutr.ad[sb] (bounded multiway + tree containers). + * a-cbmutr.ads, a-cbmutr.adb: This is the new Ada 2012 unit for bounded + multiway tree containers. + +2011-08-05 Robert Dewar + + * styleg.adb (Check_Comment): Implement comment spacing of 1 or 2 + * stylesw.adb: Implement -gnatyC to control comment spacing + * stylesw.ads (Style_Check_Comments_Spacing): New switch (set by + -gnatyc/C). + * usage.adb: Add line for -gnatyC. + +2011-08-05 Robert Dewar + + * gnat_ugn.texi: Document -gnatyC for J505-006 + * vms_data.ads: Implement COMMENTS1/COMMENTS2 (retaining COMMENTS as a + synonym for COMMENTS2). + 2011-08-05 Robert Dewar * par_sco.adb, sem_ch3.adb, scos.ads, a-iteint.ads, sem_ch12.adb, diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index cc94f4fd44d..22eb02f18ef 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -90,6 +90,7 @@ GNATRTL_NONTASKING_OBJS= \ a-cbhase$(objext) \ a-cborse$(objext) \ a-cbdlli$(objext) \ + a-cbmutr$(objext) \ a-cborma$(objext) \ a-cdlili$(objext) \ a-cfdlli$(objext) \ diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb new file mode 100644 index 00000000000..6e22e0e8756 --- /dev/null +++ b/gcc/ada/a-cbmutr.adb @@ -0,0 +1,3042 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2011, 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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Multiway_Trees is + + ----------------------- + -- 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; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate_Node + (Container : in out Tree; + 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'Address = Right'Address then + return True; + end if; + + 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; + New_Item : Element_Type; + New_Node : out Count_Type) + is + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we change container + -- state, in order to defend against exceptions duration assignment. + + Container.Elements (New_Node) := New_Item; + 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; + + -- As above, we perform this assignment first, before modifying any + -- container state. + + Container.Elements (New_Node) := New_Item; + Container.Free := Container.Free - 1; + end if; + + Initialize_Node (Container, 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 + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we change container + -- state, in order to defend against exceptions duration assignment. + + Element_Type'Read (Stream, Container.Elements (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; + + -- As above, we perform this assignment first, before modifying any + -- container state. + + Element_Type'Read (Stream, Container.Elements (New_Node)); + Container.Free := Container.Free - 1; + end if; + + Initialize_Node (Container, New_Node); + end Allocate_Node; + + procedure Allocate_Node + (Container : in out Tree; + New_Node : out Count_Type) + is + begin + if Container.Free >= 0 then + New_Node := Container.Free; + 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; + Container.Free := Container.Free - 1; + end if; + + Initialize_Node (Container, New_Node); + end Allocate_Node; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + R : constant Count_Type := Root_Node (Container); + N : Count_Type; + + begin + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + -- AI-0136 says to raise PE if Position equals the root node. This does + -- not seem correct, as this value is just the limiting condition of the + -- search. For now we omit this check, pending a ruling from the ARG. + -- ??? + -- + -- if Is_Root (Position) then + -- raise Program_Error with "Position cursor designates root"; + -- end if; + + N := Position.Node; + while N /= R loop + if Container.Elements (N) = Item then + return Cursor'(Container'Unrestricted_Access, N); + end if; + + N := 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if 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 Container.Count > Container.Capacity - Count then + raise Constraint_Error + with "requested count exceeds available storage"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + 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 => -1); -- 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 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; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count : constant Count_Type := Container.Count; + Count : Count_Type; + + begin + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + 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; + + -------------- + -- 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; + + else + 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; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + if Parent = No_Element then + return 0; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return 0; + end if; + + return Child_Count (Parent.Container.all, Parent.Node); + 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Child = No_Element then + raise Constraint_Error with "Child cursor has no element"; + end if; + + if 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 N < 0 then + raise Program_Error with "Parent is not ancestor of Child"; + end if; + end loop; + + return Result; + end Child_Depth; + + ------------------ + -- 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if 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 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 -1 means + -- that this is the last free node. + -- + -- 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). The time when we need to actually + -- initialize the nodes in the free store is if 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 Prev component to a negative value, 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 := -1; -- 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 as 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 := -1; + 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + 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 + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if not Is_Leaf (Position) then + raise Constraint_Error with "Position cursor does not designate leaf"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + 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 + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + 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 Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if 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 Left_Position = No_Element then + raise Constraint_Error with "Left cursor has no element"; + end if; + + if 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; + + ---------- + -- 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_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Count_Type'Base; + + begin + if 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 + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + Result : Count_Type; + + begin + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if 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.Node, Item); + + else + Result := Find_In_Subtree (Container, Position.Node, Item); + end if; + + if Result = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, 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; + + ----------------- + -- 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 => -1, + 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; + Last : Count_Type; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if 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 Container.Count > Container.Capacity - Count then + raise Constraint_Error + with "requested count exceeds available storage"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + Allocate_Node (Container, New_Item, Position.Node); + Nodes (Position.Node).Parent := Parent.Node; + + Last := Position.Node; + 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 => Position.Node, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + Container.Count := Container.Count + Count; + + Position.Container := Parent.Container; + 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; + Last : Count_Type; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if 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 Container.Count > Container.Capacity - Count then + raise Constraint_Error + with "requested count exceeds available storage"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + Allocate_Node (Container, Position.Node); + Nodes (Position.Node).Parent := Parent.Node; + + Last := Position.Node; + for J in Count_Type'(2) .. Count loop + Allocate_Node (Container, 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 => Position.Node, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + Container.Count := Container.Count + Count; + + Position.Container := Parent.Container; + 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 the 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 + if Position.Container = null then + return False; + end if; + + return Position.Node = Root_Node (Position.Container.all); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + T : Tree renames Container'Unrestricted_Access.all; + B : Integer renames T.Busy; + + begin + if Container.Count = 0 then + return; + end if; + + B := B + 1; + + Iterate_Children + (Container => Container, + Subtree => Root_Node (Container), + Process => Process); + + B := B - 1; + + exception + when others => + B := B - 1; + raise; + end Iterate; + + ---------------------- + -- Iterate_Children -- + ---------------------- + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if 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; + B : Integer renames Parent.Container.Busy; + C : Count_Type; + + begin + B := B + 1; + + C := NN (Parent.Node).Children.First; + while C > 0 loop + Process (Cursor'(Parent.Container, Node => C)); + C := NN (C).Next; + end loop; + + B := B - 1; + + exception + when others => + B := B - 1; + raise; + 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; + + --------------------- + -- Iterate_Subtree -- + --------------------- + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if 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; + B : Integer renames T.Busy; + + begin + B := B + 1; + + if Is_Root (Position) then + Iterate_Children (T, Position.Node, Process); + + else + Iterate_Subtree (T, Position.Node, Process); + end if; + + B := B - 1; + + exception + when others => + B := B - 1; + raise; + 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_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Count_Type'Base; + + begin + if 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; + + if Source.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors of Source (tree is busy)"; + end if; + + Target.Assign (Source); + Source.Clear; + end Move; + + ------------------ + -- 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if 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 Container.Count > Container.Capacity - Count then + raise Constraint_Error + with "requested count exceeds available storage"; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + 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_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; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + declare + T : Tree renames Position.Container.all'Unrestricted_Access.all; + B : Integer renames T.Busy; + L : Integer renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + Process (Element => T.Elements (Position.Node)); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + 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, Read_Count : Count_Type; + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Count_Type) is + Count : Count_Type; -- number of child subtrees + CC : Children_Type; + + begin + Count_Type'Read (Stream, Count); + + if not Count'Valid then -- Is this check necessary??? + 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 not Total_Count'Valid then -- Is this check necessary??? + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Total_Count = 0 then + return; + end if; + + if 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 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; + + -------------------- + -- 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 Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Container.Lock > 0 then + raise Program_Error + with "attempt to tamper with elements (tree is locked)"; + 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 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; + B : Integer renames Parent.Container.Busy; + C : Count_Type; + + begin + B := B + 1; + + C := NN (Parent.Node).Children.Last; + while C > 0 loop + Process (Cursor'(Parent.Container, Node => C)); + C := NN (C).Prev; + end loop; + + B := B - 1; + + exception + when others => + B := B - 1; + raise; + 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 Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if 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 Before.Container /= Target'Unrestricted_Access then + raise Program_Error + with "Before cursor not in Target container"; + end if; + + if 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 Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if 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 Target.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Target tree is busy)"; + end if; + + if 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Target tree is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Source tree is busy)"; + 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 + if Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if 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 Before.Container /= Container'Unrestricted_Access then + raise Program_Error + with "Before cursor not in container"; + end if; + + if 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 Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if 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 Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if 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 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 Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in Target container"; + end if; + + if Target.Nodes (Before.Node).Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Source'Unrestricted_Access then + raise Program_Error with "Position cursor not in Source container"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Target'Address = Source'Address 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; + end if; + + if Target.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Target tree is busy)"; + end if; + + if 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Target tree is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (Source tree is busy)"; + 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 + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if Container.Nodes (Before.Node).Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if Is_Root (Position) then + -- Should this be PE instead? Need ARG confirmation. ??? + raise Constraint_Error with "Position cursor designates root"; + end if; + + 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; + end if; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if 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 + if 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); + + Insert_Subtree_Node + (Container => Target, + Subtree => Target_Subtree, + Parent => Parent, + Before => Before); + + Target.Count := Target.Count + Target_Count; + + -- 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_Children (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 I = No_Element then + raise Constraint_Error with "I cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor not in container"; + end if; + + if 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 J = No_Element then + raise Constraint_Error with "J cursor has no element"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor not in container"; + end if; + + if Is_Root (J) then + raise Program_Error with "J cursor designates root"; + end if; + + if Container.Lock > 0 then + raise Program_Error + with "attempt to tamper with elements (tree is locked)"; + 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 Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor not in container"; + end if; + + if Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + declare + T : Tree renames Position.Container.all'Unrestricted_Access.all; + B : Integer renames T.Busy; + L : Integer renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + Process (Element => T.Elements (Position.Node)); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + 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; + +end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads new file mode 100644 index 00000000000..bc6de38b0ae --- /dev/null +++ b/gcc/ada/a-cbmutr.ads @@ -0,0 +1,321 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Multiway_Trees is + pragma Pure; + pragma Remote_Types; + + type Tree (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Tree); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Tree : constant Tree; + + No_Element : constant Cursor; + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean; + + function "=" (Left, Right : Tree) return Boolean; + + function Is_Empty (Container : Tree) return Boolean; + + function Node_Count (Container : Tree) return Count_Type; + + function Subtree_Node_Count (Position : Cursor) return Count_Type; + + function Depth (Position : Cursor) return Count_Type; + + function Is_Root (Position : Cursor) return Boolean; + + function Is_Leaf (Position : Cursor) return Boolean; + + function Root (Container : Tree) return Cursor; + + procedure Clear (Container : in out Tree); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Assign (Target : in out Tree; Source : Tree); + + function Copy (Source : Tree; Capacity : Count_Type := 0) return Tree; + + procedure Move (Target : in out Tree; Source : in out Tree); + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor); + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor); + + procedure Swap + (Container : in out Tree; + I, J : Cursor); + + function Find + (Container : Tree; + Item : Element_Type) return Cursor; + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Find_In_Subtree with a Container parameter, + -- but this seems incorrect. We need a ruling from the + -- ARG about whether this really was intended. ??? + + function Find_In_Subtree + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor; + + function Ancestor_Find + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor; + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)); + + function Child_Count (Parent : Cursor) return Count_Type; + + function Child_Depth (Parent, Child : Cursor) return Count_Type; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor); + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor); + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor); + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor); + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor); + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor); + + function Parent (Position : Cursor) return Cursor; + + function First_Child (Parent : Cursor) return Cursor; + + function First_Child_Element (Parent : Cursor) return Element_Type; + + function Last_Child (Parent : Cursor) return Cursor; + + function Last_Child_Element (Parent : Cursor) return Element_Type; + + function Next_Sibling (Position : Cursor) return Cursor; + + function Previous_Sibling (Position : Cursor) return Cursor; + + procedure Next_Sibling (Position : in out Cursor); + + procedure Previous_Sibling (Position : in out Cursor); + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Iterate_Children this way: + -- + -- procedure Iterate_Children + -- (Container : Tree; + -- Parent : Cursor; + -- Process : not null access procedure (Position : Cursor)); + -- + -- It seems that the Container parameter is there by mistake, but + -- we need an official ruling from the ARG. ??? + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + +private + + type Children_Type is record + First : Count_Type'Base; + Last : Count_Type'Base; + end record; + + type Tree_Node_Type is record + Parent : Count_Type'Base; + Prev : Count_Type'Base; + Next : Count_Type'Base; + Children : Children_Type; + end record; + + type Tree_Node_Array is array (Count_Type range <>) of Tree_Node_Type; + type Element_Array is array (Count_Type range <>) of Element_Type; + + type Tree (Capacity : Count_Type) is tagged record + Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); + Elements : Element_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + Busy : Integer := 0; + Lock : Integer := 0; + Count : Count_Type := 0; + end record; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree); + + for Tree'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree); + + for Tree'Read use Read; + + type Tree_Access is access all Tree; + for Tree_Access'Storage_Size use 0; + + type Cursor is record + Container : Tree_Access; + Node : Count_Type'Base := -1; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + Empty_Tree : constant Tree := Tree'(Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(others => <>); + +end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 07cc44c8d48..55090e72de3 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -176,14 +176,8 @@ package body Exp_Util is Ti : Entity_Id; begin - -- For now, we simply ignore a call where the argument has no type - -- (probably case of unanalyzed condition), or has a type that is not - -- Boolean. This is because this is a pretty marginal piece of - -- functionality, and violations of these rules are likely to be - -- truly marginal (how much code uses Fortran Logical as the barrier - -- to a protected entry?) and we do not want to blow up existing - -- programs. We can change this to an assertion after 3.12a is - -- released ??? + -- Defend against a call where the argument has no type, or has a + -- type that is not Boolean. This can occur because of prior errors. if No (T) or else not Is_Boolean_Type (T) then return; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 26f3085653b..48725cff908 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -6258,8 +6258,8 @@ The use of AND/OR operators is not permitted except in the cases of modular operands, array operands, and simple stand-alone boolean variables or boolean constants. In all other cases AND THEN/OR ELSE are required. -@item ^c^COMMENTS^ -@emph{Check comments.} +@item ^c^COMMENTS^ (double space) +@emph{Check comments, double space.} Comments must meet the following set of rules: @itemize @bullet @@ -6310,6 +6310,11 @@ example: @end smallexample @end itemize +@item ^C^COMMENTS1^ (single space) +@emph{Check comments, single space.} +This is identical to @code{^c^COMMENTS} except that only one space +is required following the @code{--} of a comment instead of two. + @item ^d^DOS_LINE_ENDINGS^ @emph{Check no DOS line terminators present.} All lines must be terminated by a single ASCII.LF diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index e0b738b831f..1fdf36adff9 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -517,6 +517,7 @@ package body Impunit is "a-coinho", -- Ada.Containers.Indefinite_Holders "a-comutr", -- Ada.Containers.Multiway_Trees "a-cimutr", -- Ada.Containers.Indefinite_Multiway_Trees + "a-cbmutr", -- Ada.Containers.Bounded_Multiway_Trees "a-extiin", -- Ada.Execution_Time.Interrupts "a-iteint", -- Ada.Iterator_Interfaces diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index f0bc9de8b27..2935bdbe6fb 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -919,6 +919,9 @@ package body Scng is Err : Boolean; -- Error flag for Scan_Wide call + String_Start : Source_Ptr; + -- Point to first character of string + procedure Error_Bad_String_Char; -- Signal bad character in string/character literal. On entry -- Scan_Ptr points to the improper character encountered during the @@ -966,6 +969,8 @@ package body Scng is ------------------------------- procedure Error_Unterminated_String is + S : Source_Ptr; + begin -- An interesting little refinement. Consider the following -- examples: @@ -973,6 +978,7 @@ package body Scng is -- A := "this is an unterminated string; -- A := "this is an unterminated string & -- P(A, "this is a parameter that didn't get terminated); + -- P("this is a parameter that didn't get terminated, A); -- We fiddle a little to do slightly better placement in these -- cases also if there is white space at the end of the line we @@ -1012,6 +1018,8 @@ package body Scng is return; end if; + -- Backup over semicolon or right-paren/semicolon sequence + if Source (Scan_Ptr - 1) = ';' then Scan_Ptr := Scan_Ptr - 1; Unstore_String_Char; @@ -1022,6 +1030,25 @@ package body Scng is end if; end if; + -- See if there is a comma in the string, if so, guess that + -- the first comma terminates the string. + + S := String_Start; + while S < Scan_Ptr loop + if Source (S) = ',' then + while Scan_Ptr > S loop + Scan_Ptr := Scan_Ptr - 1; + Unstore_String_Char; + end loop; + + exit; + end if; + + S := S + 1; + end loop; + + -- Now we have adjusted the scan pointer, give message + Error_Msg_S -- CODEFIX ("missing string quote"); end Error_Unterminated_String; @@ -1161,6 +1188,8 @@ package body Scng is -- quote). The latter case is an error detected by the character -- literal circuit. + String_Start := Scan_Ptr; + Delimiter := Source (Scan_Ptr); Accumulate_Checksum (Delimiter); diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index a393680094e..d3d8528c872 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -481,7 +481,10 @@ package body Sem_Ch11 is -- handler, since this may result in false positives, since -- the handler may handle the exception and return normally. - -- First find enclosing sequence of statements + -- First find the enclosing handled sequence of statements + -- (note, we could also look for a handler in an outer block + -- but currently we don't, and in that case we'll emit the + -- warning). Par := N; loop diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index fd6cbae7ead..7cb4d823a75 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -507,7 +507,9 @@ package body Styleg is S := Scan_Ptr + 2; while Source (S) >= ' ' loop if Source (S) /= '-' then - if Is_Box_Comment then + if Is_Box_Comment + or else Style_Check_Comments_Spacing = 1 + then Error_Space_Required (Scan_Ptr + 2); else Error_Msg -- CODEFIX @@ -522,14 +524,17 @@ package body Styleg is -- If we are followed by a blank, then the comment is OK if the -- character following this blank is another blank or a format - -- effector. + -- effector, or if the required comment spacing is 1. - elsif Source (Scan_Ptr + 3) <= ' ' then + elsif Source (Scan_Ptr + 3) <= ' ' + or else Style_Check_Comments_Spacing = 1 + then return; - -- Here is the case where we only have one blank after the two - -- minus signs, which is an error unless the line ends with two - -- minus signs, the case of a box comment. + -- Here is the case where we only have one blank after the two minus + -- signs, with Style_Check_Comments_Spacing set to 2, which is an + -- error unless the line ends with two minus signs, the case of a + -- box comment. elsif not Is_Box_Comment then Error_Space_Required (Scan_Ptr + 3); diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 7c9d462cc23..cce2b8ff745 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -160,7 +160,13 @@ package body Stylesw is Add ('A', Style_Check_Array_Attribute_Index); Add ('b', Style_Check_Blanks_At_End); Add ('B', Style_Check_Boolean_And_Or); - Add ('c', Style_Check_Comments); + + if Style_Check_Comments_Spacing = 2 then + Add ('c', Style_Check_Comments); + elsif Style_Check_Comments_Spacing = 1 then + Add ('C', Style_Check_Comments); + end if; + Add ('d', Style_Check_DOS_Line_Terminator); Add ('e', Style_Check_End_Labels); Add ('f', Style_Check_Form_Feeds); @@ -322,6 +328,11 @@ package body Stylesw is when 'c' => Style_Check_Comments := True; + Style_Check_Comments_Spacing := 2; + + when 'C' => + Style_Check_Comments := True; + Style_Check_Comments_Spacing := 1; when 'd' => Style_Check_DOS_Line_Terminator := True; @@ -484,7 +495,7 @@ package body Stylesw is when 'B' => Style_Check_Boolean_And_Or := False; - when 'c' => + when 'c' | 'C' => Style_Check_Comments := False; when 'd' => diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 22270491492..fc6f5ef13ba 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -94,7 +94,8 @@ package Stylesw is -- The comment characters are followed by an exclamation point (the -- sequence --! is used by gnatprep for marking deleted lines). -- - -- The comment characters are followed by two space characters + -- The comment characters are followed by two space characters if + -- Comment_Spacing = 2, else by one character if Comment_Spacing = 1. -- -- The line consists entirely of minus signs -- @@ -104,6 +105,9 @@ package Stylesw is -- Note: the reason for the last two conditions is to allow "boxed" -- comments where only a single space separates the comment characters. + Style_Check_Comments_Spacing : Nat range 1 .. 2; + -- Spacing required for comments, valid only if Style_Check_Comments true. + Style_Check_DOS_Line_Terminator : Boolean := False; -- This can be set true by using the -gnatyd switch. If it is True, then -- the line terminator must be a single LF, without an associated CR (e.g. diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 5b0f6056a43..6c9839ddd14 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -548,7 +548,8 @@ begin Write_Line (" A check array attribute indexes"); Write_Line (" b check no blanks at end of lines"); Write_Line (" B check no use of AND/OR for boolean expressions"); - Write_Line (" c check comment format"); + Write_Line (" c check comment format (two spaces)"); + Write_Line (" C check comment format (one space)"); Write_Line (" d check no DOS line terminators"); Write_Line (" e check end/exit labels present"); Write_Line (" f check no form feeds/vertical tabs in source"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 573cc515155..b742c69265b 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -2319,6 +2319,10 @@ package VMS_Data is "-gnaty-B " & "COMMENTS " & "-gnatyc " & + "COMMENTS1 " & + "-gnatyC " & + "COMMENTS2 " & + "-gnatyc " & "NOCOMMENTS " & "-gnaty-c " & "DOS_LINE_ENDINGS " & @@ -2409,7 +2413,7 @@ package VMS_Data is -- input source code. The following keywords are supported: -- -- ALL_BUILTIN (D) Equivalent to the following list of options: - -- 3, ATTRIBUTE, BLANKS, COMMENTS, END, VTABS, + -- 3, ATTRIBUTE, BLANKS, COMMENTS2, END, VTABS, -- HTABS, IF_THEN, KEYWORD, LAYOUT, LINE_LENGTH, -- PRAGMA, REFERENCES, SPECS, TOKEN. -- @@ -2441,8 +2445,8 @@ package VMS_Data is -- enforce a canonical format for the use of -- blanks to separate source tokens. -- - -- COMMENTS Check comments. - -- Comments must meet the following set of rules: + -- COMMENTS2 Check comments. + -- COMMENTS Comments must meet the following set of rules: -- -- * The "--" that starts the column must either -- start in column one, or else at least one @@ -2488,6 +2492,11 @@ package VMS_Data is -- -- This is a box comment -- -- --------------------------- -- + -- COMMENTS1 Check comments (single space). + -- Like COMMENTS2, but the -- of a comment only + -- requires one or more spaces following, instead + -- of two or more spaces. + -- -- DOS_LINE_ENDINGS Check that no DOS line terminators are present -- All lines must be terminated by a single -- ASCII.LF character. In particular the DOS line -- cgit v1.2.1