[svn:parrot] r47383 - in branches/gsoc_past_optimization: runtime/parrot/library/PAST t/library

[tcurtis at svn.parrot.org]

Author: tcurtis
Date: Sat Jun  5 19:33:27 2010
New Revision: 47383
URL: https://trac.parrot.org/parrot/changeset/47383

Log:
Traverse children when looking for matches.

Modified:
   branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
   branches/gsoc_past_optimization/t/library/pastpattern.t

Modified: branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Sat Jun  5 16:50:53 2010	(r47382)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Sat Jun  5 19:33:27 2010	(r47383)
@@ -124,7 +124,16 @@
     }
 
     method ACCEPTS ($node) {
-        ?0;
+        my $result := self.ACCEPTSEXACTLY($node);
+        if (!$result && $node ~~ PAST::Node) {
+            my $index := 0;
+            my $max := pir::elements__IP($node);
+            until ($result || $index == $max) {
+                $result := $node[$index] ~~ self;
+                $index++;
+            }
+        }
+        $result;
     }
 }
 
@@ -202,9 +211,9 @@
          && PAST::Pattern::check_attribute($pattern, $node, "subid")
          && PAST::Pattern::check_attribute($pattern, $node, "pirflags"));
     }
-
-    method ACCEPTS ($node) {
-        (($node ~~ PAST::Block)
+    
+    method ACCEPTSEXACTLY ($node) {
+        ($node ~~ PAST::Block
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
          && check_block_attributes(self, $node));
@@ -231,7 +240,7 @@
          && PAST::Pattern::check_attribute($pattern, $node, "inline"));          
     }
 
-    method ACCEPTS ($node) {
+    method ACCEPTSEXACTLY ($node) {
         (($node ~~ PAST::Op)
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
@@ -240,7 +249,7 @@
 }
 
 class PAST::Pattern::Stmts is PAST::Pattern {
-    method ACCEPTS ($node) {
+    method ACCEPTSEXACTLY ($node) {
         ($node ~~ PAST::Stmts
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node));
@@ -252,7 +261,7 @@
         self.attr("value", $val, !pir::isnull__iP($val));
     }
 
-    method ACCEPTS ($node) {
+    method ACCEPTSEXACTLY ($node) {
         ($node ~~ PAST::Val
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
@@ -293,7 +302,7 @@
         self.attr("multitype", $val, !pir::isnull__iP($val));
     }
 
-    method ACCEPTS ($node) {
+    method ACCEPTSEXACTLY ($node) {
         ($node ~~ PAST::Var
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
@@ -309,7 +318,7 @@
 }
 
 class PAST::Pattern::VarList is PAST::Pattern {
-    method ACCEPTS ($node) {
+    method ACCEPTSEXACTLY ($node) {
         my $result := ($node ~~ PAST::VarList
          && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node));

Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t	Sat Jun  5 16:50:53 2010	(r47382)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Sat Jun  5 19:33:27 2010	(r47383)
@@ -5,7 +5,7 @@
 pir::load_bytecode('PCT.pbc');
 pir::load_bytecode('PAST/Pattern.pbc');
 
-plan(1970);
+plan(1994);
 
 test_type_matching();
 test_attribute_exact_matching();
@@ -13,6 +13,8 @@
 test_attribute_smart_matching();
 test_child_smart_matching();
 
+test_deep_matching_in_children();
+
 sub node_with_attr_set ($class, $attr, $val) {
     my $node := $class.new();
     if ($attr eq "source" || $attr eq "pos") {
@@ -507,6 +509,37 @@
     }
 }
 
+sub test_deep_matching_in_children () {
+    my @classes := [ PAST::Block, PAST::Op, PAST::Stmts,
+                     PAST::Val, PAST::Var, PAST::VarList ];
+
+    my $pattern := PAST::Pattern::Val.new(:returns('Integer'));
+    my $node, my $class;
+    my $childNode := PAST::Val.new(:returns('Integer'));
+
+    for @classes {
+        $class := $_;
+
+        $node := $class.new($childNode);
+        ok($node ~~ $pattern, 
+           "Deep matching $class: Matching subtree as first child.");
+
+        $node := $class.new(PAST::Block.new(),
+                            $childNode);
+        ok($node ~~ $pattern,
+           "Deep matching $class: Matching subtree as second child.");
+
+        $node := $class.new();
+        ok(!($node ~~ $pattern),
+           "Deep matching $class: no children.");
+
+        $node := $class.new(PAST::Var.new());
+        ok(!($node ~~ $pattern),
+           "Deep matching $class: wrong type of child.");
+    }
+
+}
+
 # Local Variables:
 #   mode: cperl
 #   cperl-indent-level: 4