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

[tcurtis at svn.parrot.org]

Author: tcurtis
Date: Thu Jun  3 02:34:26 2010
New Revision: 47320
URL: https://trac.parrot.org/parrot/changeset/47320

Log:
PAST::Pattern.blocktype 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 01:37:34 2010	(r47319)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Thu Jun  3 02:34:26 2010	(r47320)
@@ -154,9 +154,14 @@
         self.attr("pirflags", $val, !pir::isnull__i_p($val));
     }
 
+    sub check_block_attributes($pattern, $node) {
+        PAST::Pattern::check_attribute($pattern, $node, "blocktype");
+    }
+
     method ACCEPTS ($node) {
         (($node ~~ PAST::Block)
-         && PAST::Pattern::check_node_attributes(self, $node));
+         && PAST::Pattern::check_node_attributes(self, $node)
+         && check_block_attributes(self, $node));
     }
 }
 

Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t	Thu Jun  3 01:37:34 2010	(r47319)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Thu Jun  3 02:34:26 2010	(r47320)
@@ -5,11 +5,22 @@
 pir::load_bytecode('PCT.pbc');
 pir::load_bytecode('PAST/Pattern.pbc');
 
-plan(501);
+plan(509);
 
 test_type_matching();
 test_attribute_exact_matching();
 
+sub node_with_attr_set ($class, $attr, $val) {
+    my $node := $class.new();
+    if ($attr eq "source" || $attr eq "pos") {
+        $node{$attr} := $val;
+    }
+    else {
+        $node.attr($attr, $val, 1);
+    }
+    $node;
+}
+
 sub test_type_matching() {
     my $blockPat := PAST::Pattern::Block.new();
     my $opPat := PAST::Pattern::Op.new();
@@ -80,6 +91,11 @@
 }
 
 sub test_attribute_exact_matching () {
+    test_attribute_exact_matching_node_attributes();
+    test_attribute_exact_matching_block_attributes();
+}
+
+sub test_attribute_exact_matching_node_attributes () {
     test_attribute_exact_matching_on_node_attr("name");
     test_attribute_exact_matching_on_node_attr("source");
     test_attribute_exact_matching_on_node_attr("pos");
@@ -90,17 +106,6 @@
     test_attribute_exact_matching_on_node_attr("lvalue");
 }
 
-sub node_with_attr_set ($class, $attr, $val) {
-    my $node := $class.new();
-    if ($attr eq "source" || $attr eq "pos") {
-        $node{$attr} := $val;
-    }
-    else {
-        $node.attr($attr, $val, 1);
-    }
-    $node;
-}
-
 sub test_attribute_exact_matching_on_node_attr($attr) {
     my @classes :=
       $attr eq "lvalue" ??
@@ -151,6 +156,63 @@
     }
 }
 
+sub test_attribute_exact_matching_block_attributes () {
+    test_attribute_exact_matching_on_block_attr("blocktype");
+}
+
+sub test_attribute_exact_matching_on_block_attr($attr) {
+    my $pattern := node_with_attr_set(PAST::Pattern::Block, 
+                                      $attr, "foo");
+    my $rightBegin := "Matching PAST::Pattern::Block.$attr:";
+    my $wrongBegin := "Non-matching PAST::Pattern::Block.$attr:";
+
+    my @right := [ node_with_attr_set(PAST::Block,
+                                      $attr, "foo") ];
+    my @rightMessages := 
+      [ "$rightBegin simple case." ];
+    my $node := node_with_attr_set(PAST::Block, $attr, "foo");
+    $node.name("bar");
+    pir::push(@right, $node);
+    pir::push(@rightMessages,
+              "$rightBegin with different :name.");
+
+    $node := PAST::Block.new(:name("bar"));
+    $node.attr($attr, "foo", 1);
+    pir::push(@right, $node);
+    pir::push(@rightMessages,
+              "$rightBegin with different name first.");
+
+    $node := node_with_attr_set(PAST::Block, $attr, "foo");
+    $node.name("foo");
+    pir::push(@right, $node);
+    pir::push(@rightMessages,
+              "$rightBegin with same name.");
+    
+    $node := PAST::Block.new(:name("foo"));
+    $node.attr($attr, "foo", 1);
+    pir::push(@right, $node);
+    pir::push(@rightMessages,
+              "$rightBegin with same name first.");
+
+    for @right {
+        ok($_ ~~ $pattern, pir::shift__s_p(@rightMessages));
+    }
+
+    my @wrong := [ PAST::Block.new(),
+                   PAST::Block.new("foo"),
+                   node_with_attr_set(PAST::Block, $attr, "bar")
+                 ];
+    my @wrongMessages := [ "$wrongBegin plain Block.",
+                           "$wrongBegin with child.",
+                           "$wrongBegin with wrong value."
+                         ];
+
+    for @wrong {
+        ok(!($_ ~~ $pattern),
+           pir::shift__p_p(@wrongMessages));
+    }
+}
+
 # Local Variables:
 #   mode: cperl
 #   cperl-indent-level: 4