From e49208a9cb1d63270a57c501eb94cce668d2c750 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 5 Aug 2011 16:59:54 +0200 Subject: [PATCH] [multiple changes] 2011-08-05 Thomas Quinot * g-expect.adb: Minor reformatting. 2011-08-05 Bob Duff * a-fihema.adb: Comment out OS_Lib. 2011-08-05 Matthew Heaney * Makefile.rtl, impunit.adb: Added a-c[oi]mutr.ad[sb] (unbounded multiway tree containers) and a-iteint.ads. * a-comutr.ads, a-comutr.adb: This is the new Ada 2012 unit for unbounded multiway tree containers * a-cimutr.ads, a-cimutr.adb This is the new Ada 2012 unit for indefinite multiway tree containers * a-iteint.ads: New file. From-SVN: r177449 --- gcc/ada/ChangeLog | 18 + gcc/ada/Makefile.rtl | 2 + gcc/ada/a-cimutr.adb | 2405 +++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-cimutr.ads | 330 ++++++ gcc/ada/a-comutr.adb | 2448 ++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-comutr.ads | 378 +++++++ gcc/ada/a-fihema.adb | 6 +- gcc/ada/a-iteint.ads | 46 + gcc/ada/g-expect.adb | 4 +- gcc/ada/impunit.adb | 3 + 10 files changed, 5636 insertions(+), 4 deletions(-) create mode 100644 gcc/ada/a-cimutr.adb create mode 100644 gcc/ada/a-cimutr.ads create mode 100644 gcc/ada/a-comutr.adb create mode 100644 gcc/ada/a-comutr.ads create mode 100644 gcc/ada/a-iteint.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 743fa0e57dc..24fdf5c84fe 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2011-08-05 Thomas Quinot + + * g-expect.adb: Minor reformatting. + +2011-08-05 Bob Duff + + * a-fihema.adb: Comment out OS_Lib. + +2011-08-05 Matthew Heaney + + * Makefile.rtl, impunit.adb: Added a-c[oi]mutr.ad[sb] + (unbounded multiway tree containers) and a-iteint.ads. + * a-comutr.ads, a-comutr.adb: + This is the new Ada 2012 unit for unbounded multiway tree containers + * a-cimutr.ads, a-cimutr.adb + This is the new Ada 2012 unit for indefinite multiway tree containers + * a-iteint.ads: New file. + 2011-08-05 Rainer Orth * gcc-interface/Makefile.in (raise-gcc.o): Search diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4f5cb48b13d..cc94f4fd44d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -139,6 +139,8 @@ GNATRTL_NONTASKING_OBJS= \ a-crbtgk$(objext) \ a-crbtgo$(objext) \ a-crdlli$(objext) \ + a-comutr$(objext) \ + a-cimutr$(objext) \ a-cwila1$(objext) \ a-cwila9$(objext) \ a-decima$(objext) \ diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb new file mode 100644 index 00000000000..4328296b942 --- /dev/null +++ b/gcc/ada/a-cimutr.adb @@ -0,0 +1,2405 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_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 Ada.Unchecked_Deallocation; +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Multiway_Trees is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Root_Node (Container : Tree) return Tree_Node_Access; + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Deallocate_Node (X : in out Tree_Node_Access); + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type); + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type); + + function Equal_Children + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + function Equal_Subtree + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type); + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type); + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Child_Count (Children : Children_Type) return Count_Type; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type; + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean; + + procedure Remove_Subtree (Subtree : Tree_Node_Access); + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Tree) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Equal_Children (Root_Node (Left), Root_Node (Right)); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Tree) is + Source : constant Children_Type := Container.Root.Children; + Source_Count : constant Count_Type := Container.Count; + Target_Count : Count_Type; + + begin + -- We first restore the target container to its + -- default-initialized state, before we attempt any + -- allocation, to ensure that invariants are preserved + -- in the event that the allocation fails. + + Container.Root.Children := Children_Type'(others => null); + Container.Busy := 0; + Container.Lock := 0; + Container.Count := 0; + + -- Copy_Children returns a count of the number of nodes + -- that it allocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Copy_Children. + + Target_Count := 0; + + -- Now we attempt the allocation of subtrees. The invariants + -- are satisfied even if the allocation fails. + + Copy_Children (Source, Root_Node (Container), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Container.Count := Source_Count; + end Adjust; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + R : constant Tree_Node_Access := Root_Node (Container); + N : Tree_Node_Access; + + 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 N.Element.all = Item then + return Cursor'(Container'Unrestricted_Access, N); + end if; + + N := N.Parent; + end loop; + + return No_Element; + end Ancestor_Find; + + ------------------ + -- Append_Child -- + ------------------ + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + Element : Element_Access; + + begin + if 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + Element := new Element_Type'(New_Item); + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => null); -- null means "insert at end of list" + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Append_Child; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree; Source : Tree) is + Source_Count : constant Count_Type := Source.Count; + Target_Count : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; -- checks busy bit + + -- Copy_Children returns the number of nodes that it allocates, + -- but it does this by incrementing the count value passed in, + -- so we must initialize the count before calling Copy_Children. + + Target_Count := 0; + + -- Note that Copy_Children inserts the newly-allocated children + -- into their parent list only after the allocation of all the + -- children has succeeded. This preserves invariants even if + -- the allocation fails. + + Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Target.Count := Source_Count; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count, Children_Count : Count_Type; + + begin + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + -- We first set the container count to 0, in order to + -- preserve invariants in case the deallocation fails. + -- (This works because Deallocate_Children immediately + -- removes the children from their parent, and then + -- does the actual deallocation.) + + Container_Count := Container.Count; + Container.Count := 0; + + -- Deallocate_Children returns the number of nodes that + -- it deallocates, but it does this by incrementing the + -- count value that is passed in, so we must first initialize + -- the count return value before calling it. + + Children_Count := 0; + + -- See comment above. Deallocate_Children immediately + -- removes the children list from their parent node (here, + -- the root of the tree), and only after that does it + -- attempt the actual deallocation. So even if the + -- deallocation fails, the representation invariants + -- for the tree are preserved. + + Deallocate_Children (Root_Node (Container), Children_Count); + pragma Assert (Children_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) return Tree is + begin + return Target : Tree do + Copy_Children + (Source => Source.Root.Children, + Parent => Root_Node (Target), + Count => Target.Count); + + pragma Assert (Target.Count = Source.Count); + end return; + end Copy; + + ------------------- + -- Copy_Children -- + ------------------- + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Parent /= null); + pragma Assert (Parent.Children.First = null); + pragma Assert (Parent.Children.Last = null); + + CC : Children_Type; + C : Tree_Node_Access; + + begin + -- We special-case the first allocation, in order + -- to establish the representation invariants + -- for type Children_Type. + + C := Source.First; + + if C = null then + return; + end if; + + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.First, + Count => Count); + + CC.Last := CC.First; + + -- The representation invariants for the Children_Type + -- list have been established, so we can now copy + -- the remaining children of Source. + + C := C.Next; + while C /= null loop + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.Last.Next, + Count => Count); + + CC.Last.Next.Prev := CC.Last; + CC.Last := CC.Last.Next; + + C := C.Next; + end loop; + + -- We add the newly-allocated children to their parent list + -- only after the allocation has succeeded, in order to + -- preserve invariants of the parent. + + Parent.Children := CC; + end Copy_Children; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + if Parent = No_Element then + return 0; + end if; + + return Child_Count (Parent.Node.Children); + end Child_Count; + + function Child_Count (Children : Children_Type) return Count_Type is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 0; + Node := Children.First; + while Node /= null loop + Result := Result + 1; + Node := Node.Next; + end loop; + return Result; + end Child_Count; + + ----------------- + -- Child_Depth -- + ----------------- + + function Child_Depth (Parent, Child : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + if 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; + + Result := 0; + N := Child.Node; + while N /= Parent.Node loop + Result := Result + 1; + N := N.Parent; + + if N = null 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 : Tree_Node_Access; + 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.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; + + -- Copy_Subtree returns a count of the number of nodes + -- that it allocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source.Node, + Parent => Parent.Node, + Target => Target_Subtree, + Count => Target_Count); + + pragma Assert (Target_Subtree /= null); + pragma Assert (Target_Subtree.Parent = Parent.Node); + pragma Assert (Target_Count >= 1); + + Insert_Subtree_Node + (Subtree => Target_Subtree, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Target.Count := Target.Count + Target_Count; + end Copy_Subtree; + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Target := new Tree_Node_Type'(Element => Source.Element, + Parent => Parent, + others => <>); + + Count := Count + 1; + + Copy_Children + (Source => Source.Children, + Parent => Target, + Count => Count); + end Copy_Subtree; + + ------------------------- + -- Deallocate_Children -- + ------------------------- + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Subtree /= null); + + CC : Children_Type := Subtree.Children; + C : Tree_Node_Access; + + begin + -- We immediately remove the children from their + -- parent, in order to preserve invariants in case + -- the deallocation fails. + + Subtree.Children := Children_Type'(others => null); + + while CC.First /= null loop + C := CC.First; + CC.First := C.Next; + + Deallocate_Subtree (C, Count); + end loop; + end Deallocate_Children; + + --------------------- + -- Deallocate_Node -- + --------------------- + + procedure Deallocate_Node (X : in out Tree_Node_Access) is + procedure Free_Node is + new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); + + -- Start of processing for Deallocate_Node + + begin + if X /= null then + Free_Element (X.Element); + Free_Node (X); + end if; + end Deallocate_Node; + + ------------------------ + -- Deallocate_Subtree -- + ------------------------ + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Deallocate_Children (Subtree, Count); + Deallocate_Node (Subtree); + Count := Count + 1; + end Deallocate_Subtree; + + --------------------- + -- Delete_Children -- + --------------------- + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor) + is + Count : Count_Type; + + begin + if 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; + + -- Deallocate_Children returns a count of the number of nodes + -- that it deallocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Deallocate_Children. + + Count := 0; + + Deallocate_Children (Parent.Node, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Children; + + ----------------- + -- Delete_Leaf -- + ----------------- + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + + begin + if 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; + + -- Restore represention invariants before attempting the + -- actual deallocation. + + Remove_Subtree (X); + Container.Count := Container.Count - 1; + + -- It is now safe to attempt the deallocation. This leaf + -- node has been disassociated from the tree, so even if + -- the deallocation fails, representation invariants + -- will remain satisfied. + + Deallocate_Node (X); + end Delete_Leaf; + + -------------------- + -- Delete_Subtree -- + -------------------- + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + Count : Count_Type; + + begin + if 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; + + -- Here is one case where a deallocation failure can + -- result in the violation of a representation invariant. + -- We disassociate the subtree from the tree now, but we + -- only decrement the total node count after we attempt + -- the deallocation. However, if the deallocation fails, + -- the total node count will not get decremented. + -- + -- One way around this dilemma is to count the nodes + -- in the subtree before attempt to delete the subtree, + -- but that is an O(n) operation, so it does not seem + -- worth it. + -- + -- Perhaps this is much ado about nothing, since the + -- only way deallocation can fail is if Controlled + -- Finalization fails: this propagates Program_Error + -- so all bets are off anyway. ??? + + Remove_Subtree (X); + + -- Deallocate_Subtree returns a count of the number of nodes + -- that it deallocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Deallocate_Subtree. + + Count := 0; + + Deallocate_Subtree (X, Count); + pragma Assert (Count <= Container.Count); + + -- See comments above. We would prefer to do this + -- sooner, but there's no way to satisfy that goal + -- without an potentially severe execution penalty. + + Container.Count := Container.Count - Count; + end Delete_Subtree; + + ----------- + -- Depth -- + ----------- + + function Depth (Position : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + Result := 0; + N := Position.Node; + while N /= null loop + N := N.Parent; + Result := Result + 1; + end loop; + return Result; + end Depth; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if 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.Node.Element.all; + end Element; + + -------------------- + -- Equal_Children -- + -------------------- + + function Equal_Children + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + Left_Children : Children_Type renames Left_Subtree.Children; + Right_Children : Children_Type renames Right_Subtree.Children; + + L, R : Tree_Node_Access; + + begin + if Child_Count (Left_Children) /= Child_Count (Right_Children) then + return False; + end if; + + L := Left_Children.First; + R := Right_Children.First; + while L /= null loop + if not Equal_Subtree (L, R) then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end Equal_Children; + + ------------------- + -- Equal_Subtree -- + ------------------- + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean + is + begin + if 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; + + return Equal_Children (Left_Position.Node, Right_Position.Node); + end if; + + if Is_Root (Right_Position) then + return False; + end if; + + return Equal_Subtree (Left_Position.Node, Right_Position.Node); + end Equal_Subtree; + + function Equal_Subtree + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + begin + if Left_Subtree.Element /= Right_Subtree.Element then + return False; + end if; + + return Equal_Children (Left_Subtree, Right_Subtree); + end Equal_Subtree; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Tree; + Item : Element_Type) return Cursor + is + N : constant Tree_Node_Access := + Find_In_Children (Root_Node (Container), Item); + + begin + if N = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, N); + end Find; + + ----------------- + -- First_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.First; + + if Node = null then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end First_Child; + + ------------------------- + -- First_Child_Element -- + ------------------------- + + function First_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (First_Child (Parent)); + end First_Child_Element; + + ---------------------- + -- Find_In_Children -- + ---------------------- + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + N, Result : Tree_Node_Access; + + begin + N := Subtree.Children.First; + while N /= null loop + Result := Find_In_Subtree (N, Item); + + if Result /= null then + return Result; + end if; + + N := N.Next; + end loop; + + return null; + end Find_In_Children; + + --------------------- + -- Find_In_Subtree -- + --------------------- + + function Find_In_Subtree + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + Result : Tree_Node_Access; + + 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 + Result := Find_In_Children (Position.Node, Item); + + else + Result := Find_In_Subtree (Position.Node, Item); + end if; + + if Result = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Result); + end Find_In_Subtree; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + begin + if Subtree.Element.all = Item then + return Subtree; + end if; + + return Find_In_Children (Subtree, Item); + end Find_In_Subtree; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node.Parent /= null; + end Has_Element; + + ------------------ + -- Insert_Child -- + ------------------ + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + + begin + Insert_Child (Container, Parent, Before, New_Item, Position, Count); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Last : Tree_Node_Access; + Element : Element_Access; + + 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.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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + Position.Container := Parent.Container; + + Element := new Element_Type'(New_Item); + Position.Node := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := Position.Node; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => Position.Node, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Insert_Child; + + ------------------------- + -- Insert_Subtree_List -- + ------------------------- + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + pragma Assert (Parent /= null); + C : Children_Type renames Parent.Children; + + begin + -- This is a simple utility operation to + -- insert a list of nodes (from First..Last) + -- as children of Parent. The Before node + -- specifies where the new children should be + -- inserted relative to the existing children. + + if First = null then + pragma Assert (Last = null); + return; + end if; + + pragma Assert (Last /= null); + pragma Assert (Before = null or else Before.Parent = Parent); + + if C.First = null then + C.First := First; + C.First.Prev := null; + C.Last := Last; + C.Last.Next := null; + + elsif Before = null then -- means "insert after existing nodes" + C.Last.Next := First; + First.Prev := C.Last; + C.Last := Last; + C.Last.Next := null; + + elsif Before = C.First then + Last.Next := C.First; + C.First.Prev := Last; + C.First := First; + C.First.Prev := null; + + else + Before.Prev.Next := First; + First.Prev := Before.Prev; + Last.Next := Before; + Before.Prev := Last; + end if; + end Insert_Subtree_List; + + ------------------------- + -- Insert_Subtree_Node -- + ------------------------- + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + begin + -- This is a simple wrapper operation to insert + -- a single child into the Parent's children list. + + Insert_Subtree_List + (First => Subtree, + Last => Subtree, + Parent => Parent, + Before => Before); + end Insert_Subtree_Node; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Tree) return Boolean is + begin + return Container.Root.Children.First = null; + end Is_Empty; + + ------------- + -- Is_Leaf -- + ------------- + + function Is_Leaf (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node.Children.First = null; + end Is_Leaf; + + ------------------ + -- Is_Reachable -- + ------------------ + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean is + pragma Assert (From /= null); + pragma Assert (To /= null); + + N : Tree_Node_Access; + + begin + N := From; + while N /= null loop + if N = To then + return True; + end if; + + N := N.Parent; + end loop; + + return False; + end Is_Reachable; + + ------------- + -- Is_Root -- + ------------- + + function Is_Root (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position = Root (Position.Container.all); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + T : Tree renames Container'Unrestricted_Access.all; + B : Integer renames T.Busy; + + begin + B := B + 1; + + Iterate_Children + (Container => Container'Unrestricted_Access, + 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; + + declare + B : Integer renames Parent.Container.Busy; + C : Tree_Node_Access; + + begin + B := B + 1; + + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; + + B := B - 1; + exception + when others => + B := B - 1; + raise; + end; + end Iterate_Children; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + Node : Tree_Node_Access; + + begin + -- This is a helper function to recursively iterate over + -- all the nodes in a subtree, in depth-first fashion. + -- This particular helper just visits the children of this + -- subtree, not the root of the subtree node itself. This + -- is useful when starting from the ultimate root of the + -- entire tree (see Iterate), as that root does not have + -- an element. + + Node := Subtree.Children.First; + while Node /= null loop + Iterate_Subtree (Container, Node, Process); + Node := Node.Next; + end loop; + end Iterate_Children; + + --------------------- + -- 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; + + declare + B : Integer renames Position.Container.Busy; + + begin + B := B + 1; + + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; + + B := B - 1; + exception + when others => + B := B - 1; + raise; + end; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + begin + -- This is a helper function to recursively iterate over + -- all the nodes in a subtree, in depth-first fashion. + -- It first visits the root of the subtree, then visits + -- its children. + + Process (Cursor'(Container, Subtree)); + Iterate_Children (Container, Subtree, Process); + end Iterate_Subtree; + + ---------------- + -- Last_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.Last; + + if Node = null then + return No_Element; + end if; + + return (Parent.Container, Node); + end Last_Child; + + ------------------------ + -- Last_Child_Element -- + ------------------------ + + function Last_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (Last_Child (Parent)); + end Last_Child_Element; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Tree; Source : in out Tree) is + Node : Tree_Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors of Source (tree is busy)"; + end if; + + Target.Clear; -- checks busy bit + + Target.Root.Children := Source.Root.Children; + Source.Root.Children := Children_Type'(others => null); + + Node := Target.Root.Children.First; + while Node /= null loop + Node.Parent := Root_Node (Target); + Node := Node.Next; + end loop; + + Target.Count := Source.Count; + Source.Count := 0; + end Move; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Next = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Next); + end Next_Sibling; + + procedure Next_Sibling (Position : in out Cursor) is + begin + Position := Next_Sibling (Position); + end Next_Sibling; + + ---------------- + -- Node_Count -- + ---------------- + + function Node_Count (Container : Tree) return Count_Type is + begin + -- Container.Count is the number of nodes we have actually + -- allocated. We cache the value specifically so this Node_Count + -- operation can execute in O(1) time, which makes it behave + -- similarly to how the Length selector function behaves + -- for other containers. + -- + -- The cached node count value only describes the nodes + -- we have allocated; the root node itself is not included + -- in that count. The Node_Count operation returns a value + -- that includes the root node (because the RM says so), so we + -- must add 1 to our cached value. + + return 1 + Container.Count; + end Node_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Parent = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Parent); + end Parent; + + ------------------- + -- Prepent_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + Element : Element_Access; + + begin + if 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + Element := new Element_Type'(New_Item); + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Parent.Node.Children.First); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Prepend_Child; + + ---------------------- + -- Previous_Sibling -- + ---------------------- + + function Previous_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Prev = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Prev); + end Previous_Sibling; + + procedure Previous_Sibling (Position : in out Cursor) is + begin + Position := Previous_Sibling (Position); + end Previous_Sibling; + + ------------------- + -- 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 (Position.Node.Element.all); + + 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 : Tree_Node_Access); + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access; + + Total_Count, Read_Count : Count_Type; + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Tree_Node_Access) is + pragma Assert (Subtree /= null); + pragma Assert (Subtree.Children.First = null); + pragma Assert (Subtree.Children.Last = null); + + Count : Count_Type; -- number of child subtrees + C : 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; + + C.First := Read_Subtree (Parent => Subtree); + C.Last := C.First; + + for J in Count_Type'(2) .. Count loop + C.Last.Next := Read_Subtree (Parent => Subtree); + C.Last.Next.Prev := C.Last; + C.Last := C.Last.Next; + end loop; + + -- Now that the allocation and reads have completed successfully, + -- it is safe to link the children to their parent. + + Subtree.Children := C; + end Read_Children; + + ------------------ + -- Read_Subtree -- + ------------------ + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access + is + Element : constant Element_Access := + new Element_Type'(Element_Type'Input (Stream)); + + Subtree : constant Tree_Node_Access := + new Tree_Node_Type' + (Parent => Parent, + Element => Element, + others => <>); + + begin + Read_Count := Read_Count + 1; + + Read_Children (Subtree); + + return Subtree; + end Read_Subtree; + + -- Start of processing for Read + + begin + Container.Clear; -- checks busy bit + + Count_Type'Read (Stream, Total_Count); + + if 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; + + 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 (Subtree : Tree_Node_Access) is + C : Children_Type renames Subtree.Parent.Children; + + begin + -- This is a utility operation to remove a subtree + -- node from its parent's list of children. + + if C.First = Subtree then + pragma Assert (Subtree.Prev = null); + + if C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.First := null; + C.Last := null; + + else + C.First := Subtree.Next; + C.First.Prev := null; + end if; + + elsif C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.Last := Subtree.Prev; + C.Last.Next := null; + + else + Subtree.Prev.Next := Subtree.Next; + Subtree.Next.Prev := Subtree.Prev; + end if; + end Remove_Subtree; + + ---------------------- + -- Replace_Element -- + ---------------------- + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type) + is + E, X : Element_Access; + + begin + if 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; + + E := new Element_Type'(New_Item); + + X := Position.Node.Element; + Position.Node.Element := E; + + Free_Element (X); + end Replace_Element; + + ------------------------------ + -- Reverse_Iterate_Children -- + ------------------------------ + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + declare + B : Integer renames Parent.Container.Busy; + C : Tree_Node_Access; + + begin + B := B + 1; + + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := 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 Tree_Node_Access is + begin + return Container.Root'Unrestricted_Access; + end Root_Node; + + --------------------- + -- Splice_Children -- + --------------------- + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor) + is + Count : Count_Type; + + begin + if 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 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 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 (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + return; + end if; + + 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; + + -- We cache the count of the nodes we have allocated, so that + -- operation Node_Count can execute in O(1) time. But that means + -- we must count the nodes in the subtree we remove from Source + -- and insert into Target, in order to keep the count accurate. + + Count := Subtree_Node_Count (Source_Parent.Node); + pragma Assert (Count >= 1); + + Count := Count - 1; -- because Source_Parent node does not move + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + Source.Count := Source.Count - Count; + Target.Count := Target.Count + Count; + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor) + is + begin + if 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 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; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access) + is + CC : constant Children_Type := Source_Parent.Children; + C : Tree_Node_Access; + + begin + -- This is a utility operation to remove the children from + -- Source parent and insert them into Target parent. + + Source_Parent.Children := Children_Type'(others => null); + + -- Fix up the Parent pointers of each child to designate + -- its new Target parent. + + C := CC.First; + while C /= null loop + C.Parent := Target_Parent; + C := C.Next; + end loop; + + Insert_Subtree_List + (First => CC.First, + Last => CC.Last, + Parent => Target_Parent, + Before => Before); + end Splice_Children; + + -------------------- + -- Splice_Subtree -- + -------------------- + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor) + is + Subtree_Count : Count_Type; + + begin + if 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 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 Position.Node = Before.Node + or else Position.Node.Next = 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 (From => Parent.Node, To => Position.Node) then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + return; + end if; + + 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; + + -- This is an unfortunate feature of this API: we must count + -- the nodes in the subtree that we remove from the source tree, + -- which is an O(n) operation. It would have been better if + -- the Tree container did not have a Node_Count selector; a + -- user that wants the number of nodes in the tree could + -- simply call Subtree_Node_Count, with the understanding that + -- such an operation is O(n). + -- + -- Of course, we could choose to implement the Node_Count selector + -- as an O(n) operation, which would turn this splice operation + -- into an O(1) operation. ??? + + Subtree_Count := Subtree_Node_Count (Position.Node); + pragma Assert (Subtree_Count <= Source.Count); + + Remove_Subtree (Position.Node); + Source.Count := Source.Count - Subtree_Count; + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + Target.Count := Target.Count + Subtree_Count; + + Position.Container := Target'Unrestricted_Access; + end Splice_Subtree; + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor) + is + begin + if 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.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 Position.Node = Before.Node + or else Position.Node.Next = 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 (From => Parent.Node, To => Position.Node) then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + end Splice_Subtree; + + ------------------------ + -- Subtree_Node_Count -- + ------------------------ + + function Subtree_Node_Count (Position : Cursor) return Count_Type is + begin + if Position = No_Element then + return 0; + end if; + + return Subtree_Node_Count (Position.Node); + end Subtree_Node_Count; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type + is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 1; + Node := Subtree.Children.First; + while Node /= null loop + Result := Result + Subtree_Node_Count (Node); + Node := Node.Next; + end loop; + return Result; + end Subtree_Node_Count; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Tree; + I, J : Cursor) + is + begin + if 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 + EI : constant Element_Access := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end; + end Swap; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + 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 (Position.Node.Element.all); + + 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 : Tree_Node_Access); + procedure Write_Subtree (Subtree : Tree_Node_Access); + + -------------------- + -- Write_Children -- + -------------------- + + procedure Write_Children (Subtree : Tree_Node_Access) is + CC : Children_Type renames Subtree.Children; + C : Tree_Node_Access; + + begin + Count_Type'Write (Stream, Child_Count (CC)); + + C := CC.First; + while C /= null loop + Write_Subtree (C); + C := C.Next; + end loop; + end Write_Children; + + ------------------- + -- Write_Subtree -- + ------------------- + + procedure Write_Subtree (Subtree : Tree_Node_Access) is + begin + Element_Type'Output (Stream, Subtree.Element.all); + Write_Children (Subtree); + end Write_Subtree; + + -- Start of processing for Write + + begin + Count_Type'Write (Stream, Container.Count); + 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.Indefinite_Multiway_Trees; diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads new file mode 100644 index 00000000000..609a8795766 --- /dev/null +++ b/gcc/ada/a-cimutr.ads @@ -0,0 +1,330 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_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.Finalization; +private with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Multiway_Trees is + pragma Preelaborate; + pragma Remote_Types; + + type Tree 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) 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; + + 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 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 Tree_Node_Type; + type Tree_Node_Access is access all Tree_Node_Type; + + type Children_Type is record + First : Tree_Node_Access; + Last : Tree_Node_Access; + end record; + + type Element_Access is access Element_Type; + + type Tree_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + Element : Element_Access; + end record; + + use Ada.Finalization; + + -- The Count component of type Tree represents the number of + -- nodes that have been (dynamically) allocated. It does not + -- include the root node itself. As implementors, we decide + -- to cache this value, so that the selector function Node_Count + -- can execute in O(1) time, in order to be consistent with + -- the behavior of the Length selector function for other + -- standard container library units. This does mean, however, + -- that the two-container forms for Splice_XXX (that move subtrees + -- across tree containers) will execute in O(n) time, because + -- we must count the number of nodes in the subtree(s) that + -- get moved. (We resolve the tension between Node_Count + -- and Splice_XXX in favor of Node_Count, under the assumption + -- that Node_Count is the more common operation). + + type Tree is new Controlled with record + Root : aliased Tree_Node_Type; + Busy : Integer := 0; + Lock : Integer := 0; + Count : Count_Type := 0; + end record; + + overriding procedure Adjust (Container : in out Tree); + + overriding procedure Finalize (Container : in out Tree) renames Clear; + + 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 : Tree_Node_Access; + 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 := (Controlled with others => <>); + + No_Element : constant Cursor := (others => <>); + +end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb new file mode 100644 index 00000000000..d2250dec5f1 --- /dev/null +++ b/gcc/ada/a-comutr.adb @@ -0,0 +1,2448 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- +-- -- +-- 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 Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System; use type System.Address; + +package body Ada.Containers.Multiway_Trees is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Root_Node (Container : Tree) return Tree_Node_Access; + + procedure Deallocate_Node is + new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type); + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type); + + function Equal_Children + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + function Equal_Subtree + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type); + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type); + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Child_Count (Children : Children_Type) return Count_Type; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type; + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean; + + procedure Remove_Subtree (Subtree : Tree_Node_Access); + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Tree) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Equal_Children (Root_Node (Left), Root_Node (Right)); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Tree) is + Source : constant Children_Type := Container.Root.Children; + Source_Count : constant Count_Type := Container.Count; + Target_Count : Count_Type; + + begin + -- We first restore the target container to its + -- default-initialized state, before we attempt any + -- allocation, to ensure that invariants are preserved + -- in the event that the allocation fails. + + Container.Root.Children := Children_Type'(others => null); + Container.Busy := 0; + Container.Lock := 0; + Container.Count := 0; + + -- Copy_Children returns a count of the number of nodes + -- that it allocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Copy_Children. + + Target_Count := 0; + + -- Now we attempt the allocation of subtrees. The invariants + -- are satisfied even if the allocation fails. + + Copy_Children (Source, Root_Node (Container), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Container.Count := Source_Count; + end Adjust; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + R : constant Tree_Node_Access := Root_Node (Container); + N : Tree_Node_Access; + + 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 N.Element = Item then + return Cursor'(Container'Unrestricted_Access, N); + end if; + + N := N.Parent; + end loop; + + return No_Element; + end Ancestor_Find; + + ------------------ + -- Append_Child -- + ------------------ + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + + 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => null); -- null means "insert at end of list" + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Append_Child; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree; Source : Tree) is + Source_Count : constant Count_Type := Source.Count; + Target_Count : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; -- checks busy bit + + -- Copy_Children returns the number of nodes that it allocates, + -- but it does this by incrementing the count value passed in, + -- so we must initialize the count before calling Copy_Children. + + Target_Count := 0; + + -- Note that Copy_Children inserts the newly-allocated children + -- into their parent list only after the allocation of all the + -- children has succeeded. This preserves invariants even if + -- the allocation fails. + + Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Target.Count := Source_Count; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count, Children_Count : Count_Type; + + begin + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + -- We first set the container count to 0, in order to + -- preserve invariants in case the deallocation fails. + -- (This works because Deallocate_Children immediately + -- removes the children from their parent, and then + -- does the actual deallocation.) + + Container_Count := Container.Count; + Container.Count := 0; + + -- Deallocate_Children returns the number of nodes that + -- it deallocates, but it does this by incrementing the + -- count value that is passed in, so we must first initialize + -- the count return value before calling it. + + Children_Count := 0; + + -- See comment above. Deallocate_Children immediately + -- removes the children list from their parent node (here, + -- the root of the tree), and only after that does it + -- attempt the actual deallocation. So even if the + -- deallocation fails, the representation invariants + -- for the tree are preserved. + + Deallocate_Children (Root_Node (Container), Children_Count); + pragma Assert (Children_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) return Tree is + begin + return Target : Tree do + Copy_Children + (Source => Source.Root.Children, + Parent => Root_Node (Target), + Count => Target.Count); + + pragma Assert (Target.Count = Source.Count); + end return; + end Copy; + + ------------------- + -- Copy_Children -- + ------------------- + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Parent /= null); + pragma Assert (Parent.Children.First = null); + pragma Assert (Parent.Children.Last = null); + + CC : Children_Type; + C : Tree_Node_Access; + + begin + -- We special-case the first allocation, in order + -- to establish the representation invariants + -- for type Children_Type. + + C := Source.First; + + if C = null then + return; + end if; + + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.First, + Count => Count); + + CC.Last := CC.First; + + -- The representation invariants for the Children_Type + -- list have been established, so we can now copy + -- the remaining children of Source. + + C := C.Next; + while C /= null loop + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.Last.Next, + Count => Count); + + CC.Last.Next.Prev := CC.Last; + CC.Last := CC.Last.Next; + + C := C.Next; + end loop; + + -- We add the newly-allocated children to their parent list + -- only after the allocation has succeeded, in order to + -- preserve invariants of the parent. + + Parent.Children := CC; + end Copy_Children; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + if Parent = No_Element then + return 0; + end if; + + return Child_Count (Parent.Node.Children); + end Child_Count; + + function Child_Count (Children : Children_Type) return Count_Type is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 0; + Node := Children.First; + while Node /= null loop + Result := Result + 1; + Node := Node.Next; + end loop; + return Result; + end Child_Count; + + ----------------- + -- Child_Depth -- + ----------------- + + function Child_Depth (Parent, Child : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + if 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; + + Result := 0; + N := Child.Node; + while N /= Parent.Node loop + Result := Result + 1; + N := N.Parent; + + if N = null 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 : Tree_Node_Access; + 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.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; + + -- Copy_Subtree returns a count of the number of nodes + -- that it allocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source.Node, + Parent => Parent.Node, + Target => Target_Subtree, + Count => Target_Count); + + pragma Assert (Target_Subtree /= null); + pragma Assert (Target_Subtree.Parent = Parent.Node); + pragma Assert (Target_Count >= 1); + + Insert_Subtree_Node + (Subtree => Target_Subtree, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Target.Count := Target.Count + Target_Count; + end Copy_Subtree; + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Target := new Tree_Node_Type'(Element => Source.Element, + Parent => Parent, + others => <>); + + Count := Count + 1; + + Copy_Children + (Source => Source.Children, + Parent => Target, + Count => Count); + end Copy_Subtree; + + ------------------------- + -- Deallocate_Children -- + ------------------------- + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Subtree /= null); + + CC : Children_Type := Subtree.Children; + C : Tree_Node_Access; + + begin + -- We immediately remove the children from their + -- parent, in order to preserve invariants in case + -- the deallocation fails. + + Subtree.Children := Children_Type'(others => null); + + while CC.First /= null loop + C := CC.First; + CC.First := C.Next; + + Deallocate_Subtree (C, Count); + end loop; + end Deallocate_Children; + + ------------------------ + -- Deallocate_Subtree -- + ------------------------ + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Deallocate_Children (Subtree, Count); + Deallocate_Node (Subtree); + Count := Count + 1; + end Deallocate_Subtree; + + --------------------- + -- Delete_Children -- + --------------------- + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor) + is + Count : Count_Type; + + begin + if 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; + + -- Deallocate_Children returns a count of the number of nodes + -- that it deallocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Deallocate_Children. + + Count := 0; + + Deallocate_Children (Parent.Node, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Children; + + ----------------- + -- Delete_Leaf -- + ----------------- + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + + begin + if 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; + + -- Restore represention invariants before attempting the + -- actual deallocation. + + Remove_Subtree (X); + Container.Count := Container.Count - 1; + + -- It is now safe to attempt the deallocation. This leaf + -- node has been disassociated from the tree, so even if + -- the deallocation fails, representation invariants + -- will remain satisfied. + + Deallocate_Node (X); + end Delete_Leaf; + + -------------------- + -- Delete_Subtree -- + -------------------- + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + Count : Count_Type; + + begin + if 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; + + -- Here is one case where a deallocation failure can + -- result in the violation of a representation invariant. + -- We disassociate the subtree from the tree now, but we + -- only decrement the total node count after we attempt + -- the deallocation. However, if the deallocation fails, + -- the total node count will not get decremented. + -- + -- One way around this dilemma is to count the nodes + -- in the subtree before attempt to delete the subtree, + -- but that is an O(n) operation, so it does not seem + -- worth it. + -- + -- Perhaps this is much ado about nothing, since the + -- only way deallocation can fail is if Controlled + -- Finalization fails: this propagates Program_Error + -- so all bets are off anyway. ??? + + Remove_Subtree (X); + + -- Deallocate_Subtree returns a count of the number of nodes + -- that it deallocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Deallocate_Subtree. + + Count := 0; + + Deallocate_Subtree (X, Count); + pragma Assert (Count <= Container.Count); + + -- See comments above. We would prefer to do this + -- sooner, but there's no way to satisfy that goal + -- without an potentially severe execution penalty. + + Container.Count := Container.Count - Count; + end Delete_Subtree; + + ----------- + -- Depth -- + ----------- + + function Depth (Position : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + Result := 0; + N := Position.Node; + while N /= null loop + N := N.Parent; + Result := Result + 1; + end loop; + return Result; + end Depth; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if 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.Node.Element; + end Element; + + -------------------- + -- Equal_Children -- + -------------------- + + function Equal_Children + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + Left_Children : Children_Type renames Left_Subtree.Children; + Right_Children : Children_Type renames Right_Subtree.Children; + + L, R : Tree_Node_Access; + + begin + if Child_Count (Left_Children) /= Child_Count (Right_Children) then + return False; + end if; + + L := Left_Children.First; + R := Right_Children.First; + while L /= null loop + if not Equal_Subtree (L, R) then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end Equal_Children; + + ------------------- + -- Equal_Subtree -- + ------------------- + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean + is + begin + if 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; + + return Equal_Children (Left_Position.Node, Right_Position.Node); + end if; + + if Is_Root (Right_Position) then + return False; + end if; + + return Equal_Subtree (Left_Position.Node, Right_Position.Node); + end Equal_Subtree; + + function Equal_Subtree + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + begin + if Left_Subtree.Element /= Right_Subtree.Element then + return False; + end if; + + return Equal_Children (Left_Subtree, Right_Subtree); + end Equal_Subtree; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Tree; + Item : Element_Type) return Cursor + is + N : constant Tree_Node_Access := + Find_In_Children (Root_Node (Container), Item); + + begin + if N = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, N); + end Find; + + ----------------- + -- First_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.First; + + if Node = null then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end First_Child; + + ------------------------- + -- First_Child_Element -- + ------------------------- + + function First_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (First_Child (Parent)); + end First_Child_Element; + + ---------------------- + -- Find_In_Children -- + ---------------------- + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + N, Result : Tree_Node_Access; + + begin + N := Subtree.Children.First; + while N /= null loop + Result := Find_In_Subtree (N, Item); + + if Result /= null then + return Result; + end if; + + N := N.Next; + end loop; + + return null; + end Find_In_Children; + + --------------------- + -- Find_In_Subtree -- + --------------------- + + function Find_In_Subtree + (Container : Tree; + Item : Element_Type; + Position : Cursor) return Cursor + is + Result : Tree_Node_Access; + + 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 + Result := Find_In_Children (Position.Node, Item); + + else + Result := Find_In_Subtree (Position.Node, Item); + end if; + + if Result = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Result); + end Find_In_Subtree; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + begin + if Subtree.Element = Item then + return Subtree; + end if; + + return Find_In_Children (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.Parent /= null; + end Has_Element; + + ------------------ + -- Insert_Child -- + ------------------ + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + + begin + Insert_Child (Container, Parent, Before, New_Item, Position, Count); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Last : Tree_Node_Access; + + 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.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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + Position.Container := Parent.Container; + Position.Node := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := Position.Node; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => Position.Node, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Last : Tree_Node_Access; + + 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.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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + Position.Container := Parent.Container; + Position.Node := new Tree_Node_Type'(Parent => Parent.Node, + Element => <>, + others => <>); + + Last := Position.Node; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => <>, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => Position.Node, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Insert_Child; + + ------------------------- + -- Insert_Subtree_List -- + ------------------------- + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + pragma Assert (Parent /= null); + C : Children_Type renames Parent.Children; + + begin + -- This is a simple utility operation to + -- insert a list of nodes (from First..Last) + -- as children of Parent. The Before node + -- specifies where the new children should be + -- inserted relative to the existing children. + + if First = null then + pragma Assert (Last = null); + return; + end if; + + pragma Assert (Last /= null); + pragma Assert (Before = null or else Before.Parent = Parent); + + if C.First = null then + C.First := First; + C.First.Prev := null; + C.Last := Last; + C.Last.Next := null; + + elsif Before = null then -- means "insert after existing nodes" + C.Last.Next := First; + First.Prev := C.Last; + C.Last := Last; + C.Last.Next := null; + + elsif Before = C.First then + Last.Next := C.First; + C.First.Prev := Last; + C.First := First; + C.First.Prev := null; + + else + Before.Prev.Next := First; + First.Prev := Before.Prev; + Last.Next := Before; + Before.Prev := Last; + end if; + end Insert_Subtree_List; + + ------------------------- + -- Insert_Subtree_Node -- + ------------------------- + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + begin + -- This is a simple wrapper operation to insert + -- a single child into the Parent's children list. + + Insert_Subtree_List + (First => Subtree, + Last => Subtree, + Parent => Parent, + Before => Before); + end Insert_Subtree_Node; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Tree) return Boolean is + begin + return Container.Root.Children.First = null; + end Is_Empty; + + ------------- + -- Is_Leaf -- + ------------- + + function Is_Leaf (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node.Children.First = null; + end Is_Leaf; + + ------------------ + -- Is_Reachable -- + ------------------ + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean is + pragma Assert (From /= null); + pragma Assert (To /= null); + + N : Tree_Node_Access; + + begin + N := From; + while N /= null loop + if N = To then + return True; + end if; + + N := N.Parent; + end loop; + + return False; + end Is_Reachable; + + ------------- + -- Is_Root -- + ------------- + + function Is_Root (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position = Root (Position.Container.all); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + T : Tree renames Container'Unrestricted_Access.all; + B : Integer renames T.Busy; + + begin + B := B + 1; + + Iterate_Children + (Container => Container'Unrestricted_Access, + 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; + + declare + B : Integer renames Parent.Container.Busy; + C : Tree_Node_Access; + + begin + B := B + 1; + + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; + + B := B - 1; + exception + when others => + B := B - 1; + raise; + end; + end Iterate_Children; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + Node : Tree_Node_Access; + + begin + -- This is a helper function to recursively iterate over + -- all the nodes in a subtree, in depth-first fashion. + -- This particular helper just visits the children of this + -- subtree, not the root of the subtree node itself. This + -- is useful when starting from the ultimate root of the + -- entire tree (see Iterate), as that root does not have + -- an element. + + Node := Subtree.Children.First; + while Node /= null loop + Iterate_Subtree (Container, Node, Process); + Node := Node.Next; + end loop; + end Iterate_Children; + + --------------------- + -- 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; + + declare + B : Integer renames Position.Container.Busy; + + begin + B := B + 1; + + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; + + B := B - 1; + exception + when others => + B := B - 1; + raise; + end; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + begin + -- This is a helper function to recursively iterate over + -- all the nodes in a subtree, in depth-first fashion. + -- It first visits the root of the subtree, then visits + -- its children. + + Process (Cursor'(Container, Subtree)); + Iterate_Children (Container, Subtree, Process); + end Iterate_Subtree; + + ---------------- + -- Last_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.Last; + + if Node = null then + return No_Element; + end if; + + return (Parent.Container, Node); + end Last_Child; + + ------------------------ + -- Last_Child_Element -- + ------------------------ + + function Last_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (Last_Child (Parent)); + end Last_Child_Element; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Tree; Source : in out Tree) is + Node : Tree_Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors of Source (tree is busy)"; + end if; + + Target.Clear; -- checks busy bit + + Target.Root.Children := Source.Root.Children; + Source.Root.Children := Children_Type'(others => null); + + Node := Target.Root.Children.First; + while Node /= null loop + Node.Parent := Root_Node (Target); + Node := Node.Next; + end loop; + + Target.Count := Source.Count; + Source.Count := 0; + end Move; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Next = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Next); + end Next_Sibling; + + procedure Next_Sibling (Position : in out Cursor) is + begin + Position := Next_Sibling (Position); + end Next_Sibling; + + ---------------- + -- Node_Count -- + ---------------- + + function Node_Count (Container : Tree) return Count_Type is + begin + -- Container.Count is the number of nodes we have actually + -- allocated. We cache the value specifically so this Node_Count + -- operation can execute in O(1) time, which makes it behave + -- similarly to how the Length selector function behaves + -- for other containers. + -- + -- The cached node count value only describes the nodes + -- we have allocated; the root node itself is not included + -- in that count. The Node_Count operation returns a value + -- that includes the root node (because the RM says so), so we + -- must add 1 to our cached value. + + return 1 + Container.Count; + end Node_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Parent = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Parent); + end Parent; + + ------------------- + -- Prepent_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + + 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.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + -- Reclaim other nodes if Storage_Error. ??? + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Parent.Node.Children.First); + + -- In order for operation Node_Count to complete + -- in O(1) time, we cache the count value. Here we + -- increment the total count by the number of nodes + -- we just inserted. + + Container.Count := Container.Count + Count; + end Prepend_Child; + + ---------------------- + -- Previous_Sibling -- + ---------------------- + + function Previous_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Prev = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Prev); + end Previous_Sibling; + + procedure Previous_Sibling (Position : in out Cursor) is + begin + Position := Previous_Sibling (Position); + end Previous_Sibling; + + ------------------- + -- 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 (Position.Node.Element); + + 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 : Tree_Node_Access); + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access; + + Total_Count, Read_Count : Count_Type; + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Tree_Node_Access) is + pragma Assert (Subtree /= null); + pragma Assert (Subtree.Children.First = null); + pragma Assert (Subtree.Children.Last = null); + + Count : Count_Type; -- number of child subtrees + C : 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; + + C.First := Read_Subtree (Parent => Subtree); + C.Last := C.First; + + for J in Count_Type'(2) .. Count loop + C.Last.Next := Read_Subtree (Parent => Subtree); + C.Last.Next.Prev := C.Last; + C.Last := C.Last.Next; + end loop; + + -- Now that the allocation and reads have completed successfully, + -- it is safe to link the children to their parent. + + Subtree.Children := C; + end Read_Children; + + ------------------ + -- Read_Subtree -- + ------------------ + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access + is + Subtree : constant Tree_Node_Access := + new Tree_Node_Type' + (Parent => Parent, + Element => Element_Type'Input (Stream), + others => <>); + + begin + Read_Count := Read_Count + 1; + + Read_Children (Subtree); + + return Subtree; + end Read_Subtree; + + -- Start of processing for Read + + begin + Container.Clear; -- checks busy bit + + Count_Type'Read (Stream, Total_Count); + + if 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; + + 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 (Subtree : Tree_Node_Access) is + C : Children_Type renames Subtree.Parent.Children; + + begin + -- This is a utility operation to remove a subtree + -- node from its parent's list of children. + + if C.First = Subtree then + pragma Assert (Subtree.Prev = null); + + if C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.First := null; + C.Last := null; + + else + C.First := Subtree.Next; + C.First.Prev := null; + end if; + + elsif C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.Last := Subtree.Prev; + C.Last.Next := null; + + else + Subtree.Prev.Next := Subtree.Next; + Subtree.Next.Prev := Subtree.Prev; + end if; + end Remove_Subtree; + + ---------------------- + -- Replace_Element -- + ---------------------- + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type) + is + 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; + + Position.Node.Element := 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; + + declare + B : Integer renames Parent.Container.Busy; + C : Tree_Node_Access; + + begin + B := B + 1; + + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := 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 Tree_Node_Access is + type Root_Node_Access is access all Root_Node_Type; + for Root_Node_Access'Storage_Size use 0; + pragma Convention (C, Root_Node_Access); + + function To_Tree_Node_Access is + new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access); + + -- Start of processing for Root_Node + + begin + -- This is a utility function for converting from an access type + -- that designates the distinguished root node to an access type + -- designating a non-root node. The representation of a root node + -- does not have an element, but is otherwise identical to a + -- non-root node, so the conversion itself is safe. + + return To_Tree_Node_Access (Container.Root'Unrestricted_Access); + end Root_Node; + + --------------------- + -- Splice_Children -- + --------------------- + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor) + is + Count : Count_Type; + + begin + if 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 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 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 (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + return; + end if; + + 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; + + -- We cache the count of the nodes we have allocated, so that + -- operation Node_Count can execute in O(1) time. But that means + -- we must count the nodes in the subtree we remove from Source + -- and insert into Target, in order to keep the count accurate. + + Count := Subtree_Node_Count (Source_Parent.Node); + pragma Assert (Count >= 1); + + Count := Count - 1; -- because Source_Parent node does not move + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + Source.Count := Source.Count - Count; + Target.Count := Target.Count + Count; + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor) + is + begin + if 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 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; + + if Container.Busy > 0 then + raise Program_Error + with "attempt to tamper with cursors (tree is busy)"; + end if; + + if Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access) + is + CC : constant Children_Type := Source_Parent.Children; + C : Tree_Node_Access; + + begin + -- This is a utility operation to remove the children from + -- Source parent and insert them into Target parent. + + Source_Parent.Children := Children_Type'(others => null); + + -- Fix up the Parent pointers of each child to designate + -- its new Target parent. + + C := CC.First; + while C /= null loop + C.Parent := Target_Parent; + C := C.Next; + end loop; + + Insert_Subtree_List + (First => CC.First, + Last => CC.Last, + Parent => Target_Parent, + Before => Before); + end Splice_Children; + + -------------------- + -- Splice_Subtree -- + -------------------- + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor) + is + Subtree_Count : Count_Type; + + begin + if 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 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 Position.Node = Before.Node + or else Position.Node.Next = 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 (From => Parent.Node, To => Position.Node) then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + return; + end if; + + 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; + + -- This is an unfortunate feature of this API: we must count + -- the nodes in the subtree that we remove from the source tree, + -- which is an O(n) operation. It would have been better if + -- the Tree container did not have a Node_Count selector; a + -- user that wants the number of nodes in the tree could + -- simply call Subtree_Node_Count, with the understanding that + -- such an operation is O(n). + -- + -- Of course, we could choose to implement the Node_Count selector + -- as an O(n) operation, which would turn this splice operation + -- into an O(1) operation. ??? + + Subtree_Count := Subtree_Node_Count (Position.Node); + pragma Assert (Subtree_Count <= Source.Count); + + Remove_Subtree (Position.Node); + Source.Count := Source.Count - Subtree_Count; + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + Target.Count := Target.Count + Subtree_Count; + + Position.Container := Target'Unrestricted_Access; + end Splice_Subtree; + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor) + is + begin + if 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.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 Position.Node = Before.Node + or else Position.Node.Next = 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 (From => Parent.Node, To => Position.Node) then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + end Splice_Subtree; + + ------------------------ + -- Subtree_Node_Count -- + ------------------------ + + function Subtree_Node_Count (Position : Cursor) return Count_Type is + begin + if Position = No_Element then + return 0; + end if; + + return Subtree_Node_Count (Position.Node); + end Subtree_Node_Count; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type + is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 1; + Node := Subtree.Children.First; + while Node /= null loop + Result := Result + Subtree_Node_Count (Node); + Node := Node.Next; + end loop; + return Result; + end Subtree_Node_Count; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Tree; + I, J : Cursor) + is + begin + if 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 + EI : constant Element_Type := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end; + end Swap; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + 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 (Position.Node.Element); + + 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 : Tree_Node_Access); + procedure Write_Subtree (Subtree : Tree_Node_Access); + + -------------------- + -- Write_Children -- + -------------------- + + procedure Write_Children (Subtree : Tree_Node_Access) is + CC : Children_Type renames Subtree.Children; + C : Tree_Node_Access; + + begin + Count_Type'Write (Stream, Child_Count (CC)); + + C := CC.First; + while C /= null loop + Write_Subtree (C); + C := C.Next; + end loop; + end Write_Children; + + ------------------- + -- Write_Subtree -- + ------------------- + + procedure Write_Subtree (Subtree : Tree_Node_Access) is + begin + Element_Type'Output (Stream, Subtree.Element); + Write_Children (Subtree); + end Write_Subtree; + + -- Start of processing for Write + + begin + Count_Type'Write (Stream, Container.Count); + 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.Multiway_Trees; diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads new file mode 100644 index 00000000000..4a7dde060f9 --- /dev/null +++ b/gcc/ada/a-comutr.ads @@ -0,0 +1,378 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- +-- -- +-- 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.Finalization; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Multiway_Trees is + pragma Preelaborate; + pragma Remote_Types; + + type Tree 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) 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; + + 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 + + -- A node of this multiway tree comprises an element and a list of + -- children (that are themselves trees). The root node is distinguished + -- because it contains only children: it does not have an element itself. + -- + -- This design feature puts two design goals in tension: + -- (1) treat the root node the same as any other node + -- (2) not declare any objects of type Element_Type unnecessarily + -- + -- To satisfy (1), we could simply declare the Root node of the tree + -- using the normal Tree_Node_Type, but that would mean that (2) is not + -- satisfied. To resolve the tension (in favor of (2)), we declare the + -- component Root as having a different node type, without an Element + -- component (thus satisfying goal (2)) but otherwise identical to a + -- normal node, and then use Unchecked_Conversion to convert an access + -- object designating the Root node component to the access type + -- designating a normal, non-root node (thus satisfying goal (1)). We make + -- an explicit check for Root when there is any attempt to manipulate the + -- Element component of the node (a check required by the RM anyway). + -- + -- In order to be explicit about node (and pointer) representation, we + -- specify that the respective node types have convention C, to ensure + -- that the layout of the components of the node records is the same, + -- thus guaranteeing that (unchecked) conversions between access types + -- designating each kind of node type is a meaningful conversion. + + type Tree_Node_Type; + type Tree_Node_Access is access all Tree_Node_Type; + pragma Convention (C, Tree_Node_Access); + + type Children_Type is record + First : Tree_Node_Access; + Last : Tree_Node_Access; + end record; + + -- See the comment above. This declaration must exactly + -- match the declaration of Root_Node_Type (except for + -- the Element component). + + type Tree_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + Element : Element_Type; + end record; + pragma Convention (C, Tree_Node_Type); + + -- See the comment above. This declaration must match + -- the declaration of Tree_Node_Type (except for the + -- Element component). + + type Root_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + end record; + pragma Convention (C, Root_Node_Type); + + use Ada.Finalization; + + -- The Count component of type Tree represents the number of + -- nodes that have been (dynamically) allocated. It does not + -- include the root node itself. As implementors, we decide + -- to cache this value, so that the selector function Node_Count + -- can execute in O(1) time, in order to be consistent with + -- the behavior of the Length selector function for other + -- standard container library units. This does mean, however, + -- that the two-container forms for Splice_XXX (that move subtrees + -- across tree containers) will execute in O(n) time, because + -- we must count the number of nodes in the subtree(s) that + -- get moved. (We resolve the tension between Node_Count + -- and Splice_XXX in favor of Node_Count, under the assumption + -- that Node_Count is the more common operation). + + type Tree is new Controlled with record + Root : aliased Root_Node_Type; + Busy : Integer := 0; + Lock : Integer := 0; + Count : Count_Type := 0; + end record; + + overriding procedure Adjust (Container : in out Tree); + + overriding procedure Finalize (Container : in out Tree) renames Clear; + + 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 : Tree_Node_Access; + 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 := (Controlled with others => <>); + + No_Element : constant Cursor := (others => <>); + +end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb index 1b8cd78a242..fbfebec1ac5 100644 --- a/gcc/ada/a-fihema.adb +++ b/gcc/ada/a-fihema.adb @@ -35,7 +35,8 @@ with Ada.Unchecked_Conversion; with System; use System; with System.Address_Image; with System.IO; use System.IO; -with System.OS_Lib; +-- ???with System.OS_Lib; +-- Breaks ravenscar runtimes with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; with System.Storage_Pools; use System.Storage_Pools; @@ -88,7 +89,8 @@ package body Ada.Finalization.Heap_Management is procedure Fail is begin Put_Line ("Heap_Management: Fin_Assert failed: " & Message); - OS_Lib.OS_Abort; + -- ???OS_Lib.OS_Abort; + -- Breaks ravenscar runtimes end Fail; -- Start of processing for Fin_Assert diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/a-iteint.ads new file mode 100644 index 00000000000..3e7e074cbb7 --- /dev/null +++ b/gcc/ada/a-iteint.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . I T E R A T O R . I N T E R F A C E S -- +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +generic + type Cursor is private; + No_Element : Cursor; + pragma Unreferenced (No_Element); +package Ada.Iterator_Interfaces is + type Forward_Iterator is limited interface; + function First (Object : Forward_Iterator) return Cursor is abstract; + function Next (Object : Forward_Iterator; Position : Cursor) return Cursor + is abstract; + type Reversible_Iterator is limited interface and Forward_Iterator; + function Last (Object : Reversible_Iterator) return Cursor is abstract; + function Previous (Object : Reversible_Iterator; Position : Cursor) + return Cursor is abstract; +end Ada.Iterator_Interfaces; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index 1386a14229d..c6e18efa5b7 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2010, AdaCore -- +-- Copyright (C) 2000-2011, AdaCore -- -- -- -- 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- -- @@ -926,7 +926,7 @@ package body GNAT.Expect is NOutput (Output'Range) := Output.all; Free (Output); - -- Here if current buffer size is OK + -- Here if current buffer size is OK else NOutput := Output; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 153c15913ae..e0b738b831f 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -515,7 +515,10 @@ package body Impunit is "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets "a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps "a-coinho", -- Ada.Containers.Indefinite_Holders + "a-comutr", -- Ada.Containers.Multiway_Trees + "a-cimutr", -- Ada.Containers.Indefinite_Multiway_Trees "a-extiin", -- Ada.Execution_Time.Interrupts + "a-iteint", -- Ada.Iterator_Interfaces ----------------------------------------- -- GNAT Defined Additions to Ada 20012 -- -- 2.30.2