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

[tcurtis at svn.parrot.org]

Author: tcurtis
Date: Fri Jun  4 19:28:12 2010
New Revision: 47356
URL: https://trac.parrot.org/parrot/changeset/47356

Log:
Begin implementing smart matching PAST::Pattern children & tests for smart matching of children that are also PAST::Patterns.

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	Fri Jun  4 18:52:18 2010	(r47355)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Fri Jun  4 19:28:12 2010	(r47356)
@@ -67,10 +67,13 @@
     
     sub check ($patt, $val) {
         my $result := 0;
-        if (pir::does__IPs($val, "ACCEPTS")) {
+        if (pir::can__IPs($patt, "ACCEPTS")) {
             $result := $val ~~ $patt;
         } else {
             $result := pir::iseq__IPP($patt, $val);
+            CATCH {
+                $result := 0;
+            }
         }
         $result;
     }

Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t	Fri Jun  4 18:52:18 2010	(r47355)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Fri Jun  4 19:28:12 2010	(r47356)
@@ -5,11 +5,12 @@
 pir::load_bytecode('PCT.pbc');
 pir::load_bytecode('PAST/Pattern.pbc');
 
-plan(767);
+plan(803);
 
 test_type_matching();
 test_attribute_exact_matching();
 test_child_exact_matching();
+test_child_smart_matching();
 
 sub node_with_attr_set ($class, $attr, $val) {
     my $node := $class.new();
@@ -313,6 +314,46 @@
     }
 }
 
+sub test_child_smart_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 $class := $_[0];
+        my $patternClass := $_[1];
+
+        sub right ($node, $pattern, $msg) {
+            ok($node ~~ $pattern,
+               "Smart-matching children of $patternClass: $msg.");
+        }
+        sub wrong ($node, $pattern, $msg) {
+            ok(!($node ~~ $pattern),
+               "Non-smart-matching children of $patternClass: $msg.");
+        }
+
+        my $pattern := $patternClass.new(PAST::Pattern::Val.new());
+
+        right($class.new(PAST::Val.new()), $pattern,
+              "Single PAST::Pattern child");
+        wrong($class.new(), $pattern,
+              "Single PAST::Pattern, no corresponding child.");
+        wrong($class.new(PAST::Block.new()), $pattern,
+              "Single PAST::Pattern, wrong node type.");
+        wrong($class.new(PAST::Val.new(), PAST::Val.new()), $pattern,
+              "Single PAST::Pattern, extra child of right type.");
+        wrong($class.new(PAST::Val.new(), PAST::Block.new()), $pattern,
+              "Single PAST::Pattern, extra child of wrong type.");
+        wrong($class.new(PAST::Block.new(), PAST::Val.new()), $pattern,
+              "Single PAST::Pattern, extra child of wrong type first.");
+        
+    }
+}
+
 # Local Variables:
 #   mode: cperl
 #   cperl-indent-level: 4