From patchwork Fri Dec 2 15:00:54 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 128887 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 5A96FB6F64 for ; Sat, 3 Dec 2011 02:01:18 +1100 (EST) Received: (qmail 28831 invoked by alias); 2 Dec 2011 15:01:15 -0000 Received: (qmail 28798 invoked by uid 22791); 2 Dec 2011 15:01:10 -0000 X-SWARE-Spam-Status: No, hits=1.0 required=5.0 tests=AWL, BAYES_50, FILL_THIS_FORM, FILL_THIS_FORM_LOAN X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 02 Dec 2011 15:00:55 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 55D122BAC39; Fri, 2 Dec 2011 10:00:54 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id jtj4Whbr8RPQ; Fri, 2 Dec 2011 10:00:54 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 206B82BAB8E; Fri, 2 Dec 2011 10:00:54 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 1FA643FEE8; Fri, 2 Dec 2011 10:00:54 -0500 (EST) Date: Fri, 2 Dec 2011 10:00:54 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Matthew Heaney Subject: [Ada] Implement concrete iterators as a type hierarchy for multiway trees Message-ID: <20111202150054.GA29890@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org The iterators for the multiway trees are now implemented as a type hierarchy. Iterating over a tree is the same as iterating over a subtree starting from the root, and so the tree iterator forwards the request to the subtree iterator. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-12-02 Matthew Heaney * a-cbmutr.ads (No_Node): Moved declaration from body to spec * a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Iterator): Derives from Root_Iterator. (Child_Iterator): Derives from Root_Iterator. (Finalize): Implemented as an override operation for Root_Iterator. (First): Return value depends on Subtree component. (Last): Component was renamed from Parent to Subtree. (Next): Checks parameter value, and uses simplified loop. (Iterate): Forwards to Iterate_Subtree. (Iterate_Children): Component was renamed from Parent to Subtree. (Iterate_Subtree): Checks parameter value Index: a-cimutr.adb =================================================================== --- a-cimutr.adb (revision 181914) +++ a-cimutr.adb (working copy) @@ -33,41 +33,50 @@ package body Ada.Containers.Indefinite_Multiway_Trees is - type Iterator is new Limited_Controlled and + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Tree_Node_Access; end record; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Tree_Node_Access; - end record; + overriding procedure Finalize (Object : in out Root_Iterator); - overriding procedure Finalize (Object : in out Iterator); + ----------------------- + -- Subtree_Iterator -- + ----------------------- - overriding function First (Object : Iterator) return Cursor; + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - overriding procedure Finalize (Object : in out Child_Iterator); + --------------------- + -- Child_Iterator -- + --------------------- + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; + overriding function First (Object : Child_Iterator) return Cursor; + overriding function Next (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -936,18 +945,12 @@ -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; end Finalize; - procedure Finalize (Object : in out Child_Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - ---------- -- Find -- ---------- @@ -971,14 +974,18 @@ -- First -- ----------- - function First (Object : Iterator) return Cursor is + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1348,18 +1355,8 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1438,7 +1435,7 @@ return It : constant Child_Iterator := Child_Iterator'(Limited_Controlled with Container => C, - Parent => Parent.Node) + Subtree => Parent.Node) do B := B + 1; end return; @@ -1452,17 +1449,25 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container'Unrestricted_Access.all.Busy; - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1515,7 +1520,7 @@ overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -1585,63 +1590,36 @@ ---------- function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - N : constant Tree_Node_Access := Position.Node; + Node : Tree_Node_Access; begin - if Is_Leaf (Position) then + if Position.Container = null then + return No_Element; + end if; - -- If sibling is present, return it + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - if N.Next /= null then - return (Object.Container, N.Next); + Node := Position.Node; - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; - else - declare - Par : Tree_Node_Access := N.Parent; - - begin - while Par.Next = null loop - - -- If we are back at the root the iteration is complete - - if Par = Root_Node (T) then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. - - elsif Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - - else - Par := Par.Parent; - end if; - end loop; - - if Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; - - return (Object.Container, Par.Next); - end; + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); end if; - -- If an internal node, return its first child + Node := Node.Parent; + end loop; - else - return (Object.Container, N.Children.First); - end if; + return No_Element; end Next; function Next Index: a-comutr.adb =================================================================== --- a-comutr.adb (revision 181914) +++ a-comutr.adb (working copy) @@ -34,41 +34,50 @@ package body Ada.Containers.Multiway_Trees is - type Iterator is new Limited_Controlled and + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Tree_Node_Access; end record; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Tree_Node_Access; - end record; + overriding procedure Finalize (Object : in out Root_Iterator); - overriding procedure Finalize (Object : in out Iterator); + ----------------------- + -- Subtree_Iterator -- + ----------------------- - overriding function First (Object : Iterator) return Cursor; + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - overriding procedure Finalize (Object : in out Child_Iterator); + --------------------- + -- Child_Iterator -- + --------------------- + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; + overriding function First (Object : Child_Iterator) return Cursor; + overriding function Next (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -909,18 +918,12 @@ -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; end Finalize; - procedure Finalize (Object : in out Child_Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - ---------- -- Find -- ---------- @@ -943,14 +946,18 @@ -- First -- ----------- - function First (Object : Iterator) return Cursor is + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1376,18 +1383,8 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1464,9 +1461,9 @@ end if; return It : constant Child_Iterator := - Child_Iterator'(Limited_Controlled with - Container => C, - Parent => Parent.Node) + (Limited_Controlled with + Container => C, + Subtree => Parent.Node) do B := B + 1; end return; @@ -1480,16 +1477,25 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container'Unrestricted_Access.all.Busy; begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1542,7 +1548,7 @@ overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -1612,63 +1618,36 @@ ---------- function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - N : constant Tree_Node_Access := Position.Node; + Node : Tree_Node_Access; begin - if Is_Leaf (Position) then + if Position.Container = null then + return No_Element; + end if; - -- If sibling is present, return it + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - if N.Next /= null then - return (Object.Container, N.Next); + Node := Position.Node; - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; - else - declare - Par : Tree_Node_Access := N.Parent; - - begin - while Par.Next = null loop - - -- If we are back at the root the iteration is complete - - if Par = Root_Node (T) then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. - - elsif Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - - else - Par := Par.Parent; - end if; - end loop; - - if Par = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; - - return (Object.Container, Par.Next); - end; + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); end if; - else - -- If an internal node, return its first child + Node := Node.Parent; + end loop; - return (Object.Container, N.Children.First); - end if; + return No_Element; end Next; function Next Index: a-cbmutr.adb =================================================================== --- a-cbmutr.adb (revision 181914) +++ a-cbmutr.adb (working copy) @@ -33,32 +33,37 @@ package body Ada.Containers.Bounded_Multiway_Trees is - No_Node : constant Count_Type'Base := -1; + -------------------- + -- Root_Iterator -- + -------------------- - type Iterator is new Limited_Controlled and + type Root_Iterator is abstract new Limited_Controlled and Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; - Position : Cursor; - From_Root : Boolean; + Subtree : Count_Type; end record; - overriding procedure Finalize (Object : in out Iterator); + overriding procedure Finalize (Object : in out Root_Iterator); - overriding function First (Object : Iterator) return Cursor; + ----------------------- + -- Subtree_Iterator -- + ----------------------- + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + overriding function Next - (Object : Iterator; + (Object : Subtree_Iterator; Position : Cursor) return Cursor; - type Child_Iterator is new Limited_Controlled and - Tree_Iterator_Interfaces.Reversible_Iterator with - record - Container : Tree_Access; - Parent : Count_Type; - end record; + --------------------- + -- Child_Iterator -- + --------------------- - overriding procedure Finalize (Object : in out Child_Iterator); + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; overriding function First (Object : Child_Iterator) return Cursor; @@ -66,12 +71,12 @@ (Object : Child_Iterator; Position : Cursor) return Cursor; + overriding function Last (Object : Child_Iterator) return Cursor; + overriding function Previous (Object : Child_Iterator; Position : Cursor) return Cursor; - overriding function Last (Object : Child_Iterator) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -1242,18 +1247,12 @@ -- Finalize -- -------------- - procedure Finalize (Object : in out Iterator) is + procedure Finalize (Object : in out Root_Iterator) is B : Natural renames Object.Container.Busy; begin B := B - 1; end Finalize; - procedure Finalize (Object : in out Child_Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - ---------- -- Find -- ---------- @@ -1278,14 +1277,22 @@ return Cursor'(Container'Unrestricted_Access, Node); end Find; - function First (Object : Iterator) return Cursor is + ----------- + -- First -- + ----------- + + overriding function First (Object : Subtree_Iterator) return Cursor is begin - return Object.Position; + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; end First; - function First (Object : Child_Iterator) return Cursor is + overriding function First (Object : Child_Iterator) return Cursor is begin - return First_Child (Cursor'(Object.Container, Object.Parent)); + return First_Child (Cursor'(Object.Container, Object.Subtree)); end First; ----------------- @@ -1780,19 +1787,8 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - RC : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Position => First_Child (RC), - From_Root => True) - do - B := B + 1; - end return; + return Iterate_Subtree (Root (Container)); end Iterate; ---------------------- @@ -1879,7 +1875,7 @@ return It : constant Child_Iterator := Child_Iterator'(Limited_Controlled with Container => C, - Parent => Parent.Node) + Subtree => Parent.Node) do B := B + 1; end return; @@ -1893,17 +1889,25 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Position.Container.all.Busy; - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Position.Container, - Position => Position, - From_Root => False) - do - B := B + 1; - end return; + if Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + declare + B : Natural renames Position.Container.Busy; + begin + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + B := B + 1; + end return; + end; end Iterate_Subtree; procedure Iterate_Subtree @@ -1962,7 +1966,7 @@ overriding function Last (Object : Child_Iterator) return Cursor is begin - return Last_Child (Cursor'(Object.Container, Object.Parent)); + return Last_Child (Cursor'(Object.Container, Object.Subtree)); end Last; ---------------- @@ -2023,67 +2027,43 @@ -- Next -- ---------- - function Next - (Object : Iterator; + overriding function Next + (Object : Subtree_Iterator; Position : Cursor) return Cursor is - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - begin - if Is_Leaf (Position) then + if Position.Container = null then + return No_Element; + end if; - -- If sibling is present, return it + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; - if N.Next /= 0 then - return (Object.Container, N.Next); + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - -- If this is the last sibling, go to sibling of first ancestor that - -- has a sibling, or terminate. + declare + Nodes : Tree_Node_Array renames Object.Container.Nodes; + Node : Count_Type; + begin + Node := Position.Node; - else - declare - Pos : Count_Type := N.Parent; - Par : Tree_Node_Type := NN (Pos); - - begin - while Par.Next = 0 loop - Pos := Par.Parent; - - -- If we are back at the root the iteration is complete - - if Pos = No_Node then - return No_Element; - - -- If this is a subtree iterator and we are back at the - -- starting node, iteration is complete. - - elsif Pos = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - - else - Par := NN (Pos); - end if; - end loop; - - if Pos = Object.Position.Node - and then not Object.From_Root - then - return No_Element; - end if; - - return (Object.Container, Par.Next); - end; + if Nodes (Node).Children.First > 0 then + return Cursor'(Object.Container, Nodes (Node).Children.First); end if; - -- If an internal node, return its first child + while Node /= Object.Subtree loop + if Nodes (Node).Next > 0 then + return Cursor'(Object.Container, Nodes (Node).Next); + end if; - else - return (Object.Container, N.Children.First); - end if; + Node := Nodes (Node).Parent; + end loop; + + return No_Element; + end; end Next; overriding function Next @@ -2100,6 +2080,9 @@ "Position cursor of Next designates wrong tree"; end if; + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); + return Next_Sibling (Position); end Next; Index: a-cbmutr.ads =================================================================== --- a-cbmutr.ads (revision 181910) +++ a-cbmutr.ads (working copy) @@ -301,6 +301,8 @@ private use Ada.Streams; + No_Node : constant Count_Type'Base := -1; + type Children_Type is record First : Count_Type'Base; Last : Count_Type'Base; @@ -319,7 +321,7 @@ type Tree (Capacity : Count_Type) is tagged record Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); Elements : Element_Array (1 .. Capacity) := (others => <>); - Free : Count_Type'Base := -1; + Free : Count_Type'Base := No_Node; Busy : Integer := 0; Lock : Integer := 0; Count : Count_Type := 0; @@ -342,7 +344,7 @@ type Cursor is record Container : Tree_Access; - Node : Count_Type'Base := -1; + Node : Count_Type'Base := No_Node; end record; procedure Read