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

[tcurtis at svn.parrot.org]

Author: tcurtis
Date: Fri Jun  4 02:46:29 2010
New Revision: 47348
URL: https://trac.parrot.org/parrot/changeset/47348

Log:
Children matching works!

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	Thu Jun  3 23:53:42 2010	(r47347)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Fri Jun  4 02:46:29 2010	(r47348)
@@ -64,13 +64,18 @@
         }
         $result;
     }
+    
+    sub check ($patt, $val) {
+        pir::iseq__i_p_p($patt, $val);
+    }
+
 
     sub check_attribute ($pattern, $node, $attribute) {
         my $pVal := $pattern.attr($attribute, null, 0);
         my $nVal := $node.attr($attribute, null, 0);
         my $result;
         if $pVal {
-            if pir::iseq__i_p_p($pVal, $nVal) {
+            if check($pVal, $nVal) {
                 $result := 1;
             } else {
                 $result := 0;
@@ -81,6 +86,26 @@
         $result;
     }
 
+    sub check_children ($pattern, $node) {
+        my $pLen := pir::elements($pattern);
+        my $nLen := pir::elements($node);
+        my $result;
+        my $index;
+        if ($pLen == $nLen) {
+            $index := 0;
+            while ($index < $pLen) {
+                unless (check($pattern[$index], $node[$index])) {
+                    return 0;
+                }
+                $index++;
+            }
+            $result := 1;
+        } else {
+            $result := 0;
+        }
+        $result;
+    }
+
     sub check_node_attributes ($pattern, $node) {
         (check_attribute($pattern, $node, "name")
          && check_attribute($pattern, $node, "source")
@@ -173,6 +198,7 @@
 
     method ACCEPTS ($node) {
         (($node ~~ PAST::Block)
+         && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
          && check_block_attributes(self, $node));
     }
@@ -200,6 +226,7 @@
 
     method ACCEPTS ($node) {
         (($node ~~ PAST::Op)
+         && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
          && check_op_attributes(self, $node));
     }
@@ -208,6 +235,7 @@
 class PAST::Pattern::Stmts is PAST::Pattern {
     method ACCEPTS ($node) {
         ($node ~~ PAST::Stmts
+         && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
@@ -219,6 +247,7 @@
 
     method ACCEPTS ($node) {
         ($node ~~ PAST::Val
+         && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
          && PAST::Pattern::check_attribute(self, $node, "value"));
     }
@@ -259,6 +288,7 @@
 
     method ACCEPTS ($node) {
         ($node ~~ PAST::Var
+         && PAST::Pattern::check_children(self, $node)
          && PAST::Pattern::check_node_attributes(self, $node)
          && PAST::Pattern::check_attribute(self, $node, "scope")
          && PAST::Pattern::check_attribute(self, $node, "isdecl")
@@ -274,6 +304,7 @@
 class PAST::Pattern::VarList is PAST::Pattern {
     method ACCEPTS ($node) {
         ($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	Thu Jun  3 23:53:42 2010	(r47347)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Fri Jun  4 02:46:29 2010	(r47348)
@@ -5,10 +5,11 @@
 pir::load_bytecode('PCT.pbc');
 pir::load_bytecode('PAST/Pattern.pbc');
 
-plan(701);
+plan(767);
 
 test_type_matching();
 test_attribute_exact_matching();
+test_child_exact_matching();
 
 sub node_with_attr_set ($class, $attr, $val) {
     my $node := $class.new();
@@ -270,6 +271,48 @@
                                                   $attr);
 }
 
+sub test_child_exact_matching () {
+    my @classes := [ [ PAST::Block, PAST::Pattern::Block ],
+                     [ PAST::Op, PAST::Pattern::Op ],
+                     [ PAST::Stmts, PAST::Pattern::Stmts ],
+                     [ PAST::Val, PAST::Pattern::Val ],
+                     [ PAST::Var, PAST::Pattern::Var ],
+                     [ PAST::VarList, PAST::Pattern::VarList]
+                   ];
+
+    for @classes {
+        my $nodeClass := $_[0];
+        my $patternClass := $_[1];
+        
+
+        sub right ($node, $pattern, $msg) {
+            ok($node ~~ $pattern, "Matching $patternClass: $msg.");
+        }
+
+        sub wrong ($node, $pattern, $msg) {
+            ok(!($node ~~ $pattern),
+               "Matching $patternClass: $msg.");
+        }
+
+        my $pattern := $patternClass.new(1);
+
+        right($nodeClass.new(1), $pattern, "(1) ~~ (1)");
+        wrong($nodeClass.new(), $pattern, "() !~~ (1)");
+        wrong($nodeClass.new(0), $pattern, "(0) !~~ (1)");
+        wrong($nodeClass.new(1, 2), $pattern, "(1, 2) !~~ (1)");
+        wrong($nodeClass.new(2, 1), $pattern, "(2, 1) !~~ (1)");
+
+        $pattern := $patternClass.new(1, 2);
+
+        right($nodeClass.new(1, 2), $pattern, "(1, 2) == (1, 2)");
+        wrong($nodeClass.new(), $pattern, "() !~~ (1, 2)");
+        wrong($nodeClass.new(1), $pattern, "(1) !~~ (1, 2)");
+        wrong($nodeClass.new(0, 2), $pattern, "(0, 2) !~~ (1, 2)");
+        wrong($nodeClass.new(1, 3), $pattern, "(1, 3) !~~ (1, 2)");
+        wrong($nodeClass.new(1, 2, 3), $pattern, "(1, 2, 3) !~~ (1, 2)");        
+    }
+}
+
 # Local Variables:
 #   mode: cperl
 #   cperl-indent-level: 4