[svn:parrot] r47345 - in branches/gsoc_past_optimization: runtime/parrot/library/PAST t/library
tcurtis at svn.parrot.org
tcurtis at svn.parrot.org
Thu Jun 3 23:32:29 UTC 2010
Author: tcurtis
Date: Thu Jun 3 23:32:29 2010
New Revision: 47345
URL: https://trac.parrot.org/parrot/changeset/47345
Log:
Added PAST::Pattern::Op attribute exact matching.
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 21:44:12 2010 (r47344)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp Thu Jun 3 23:32:29 2010 (r47345)
@@ -192,9 +192,16 @@
self.attr("inline", $val, !pir::isnull__i_p($val));
}
+ sub check_op_attributes ($pattern, $node) {
+ (PAST::Pattern::check_attribute($pattern, $node, "pasttype")
+ && PAST::Pattern::check_attribute($pattern, $node, "pirop")
+ && PAST::Pattern::check_attribute($pattern, $node, "inline"));
+ }
+
method ACCEPTS ($node) {
- ($node ~~ PAST::Op
- && PAST::Pattern::check_node_attributes(self, $node));
+ (($node ~~ PAST::Op)
+ && PAST::Pattern::check_node_attributes(self, $node)
+ && check_op_attributes(self, $node));
}
}
Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t Thu Jun 3 21:44:12 2010 (r47344)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t Thu Jun 3 23:32:29 2010 (r47345)
@@ -5,7 +5,7 @@
pir::load_bytecode('PCT.pbc');
pir::load_bytecode('PAST/Pattern.pbc');
-plan(605);
+plan(629);
test_type_matching();
test_attribute_exact_matching();
@@ -93,6 +93,7 @@
sub test_attribute_exact_matching () {
test_attribute_exact_matching_node_attributes();
test_attribute_exact_matching_block_attributes();
+ test_attribute_exact_matching_op_attributes();
}
sub test_attribute_exact_matching_node_attributes () {
@@ -156,51 +157,35 @@
}
}
-sub test_attribute_exact_matching_block_attributes () {
- test_attribute_exact_matching_on_block_attr("blocktype");
- test_attribute_exact_matching_on_block_attr("closure");
- test_attribute_exact_matching_on_block_attr("control");
- test_attribute_exact_matching_on_block_attr("loadinit");
- test_attribute_exact_matching_on_block_attr("namespace");
- test_attribute_exact_matching_on_block_attr("multi");
- test_attribute_exact_matching_on_block_attr("hll");
- test_attribute_exact_matching_on_block_attr("nsentry");
- test_attribute_exact_matching_on_block_attr("lexical");
- test_attribute_exact_matching_on_block_attr("compiler");
- test_attribute_exact_matching_on_block_attr("compiler_args");
- test_attribute_exact_matching_on_block_attr("subid");
- test_attribute_exact_matching_on_block_attr("pirflags");
-}
-
-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:";
+sub test_attribute_exact_matching_on_subtype_attr ($class,
+ $pattClass,
+ $attr) {
+ my $pattern := node_with_attr_set($pattClass, $attr, "foo");
+ my $rightBegin := "Matching $pattClass.$attr:";
+ my $wrongBegin := "Non-matching $pattClass.$attr:";
- my @right := [ node_with_attr_set(PAST::Block,
- $attr, "foo") ];
+ my @right := [ node_with_attr_set($class, $attr, "foo") ];
my @rightMessages :=
[ "$rightBegin simple case." ];
- my $node := node_with_attr_set(PAST::Block, $attr, "foo");
+ my $node := node_with_attr_set($class, $attr, "foo");
$node.name("bar");
pir::push(@right, $node);
pir::push(@rightMessages,
"$rightBegin with different :name.");
- $node := PAST::Block.new(:name("bar"));
+ $node := $class.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 := node_with_attr_set($class, $attr, "foo");
$node.name("foo");
pir::push(@right, $node);
pir::push(@rightMessages,
"$rightBegin with same name.");
- $node := PAST::Block.new(:name("foo"));
+ $node := $class.new(:name("foo"));
$node.attr($attr, "foo", 1);
pir::push(@right, $node);
pir::push(@rightMessages,
@@ -210,11 +195,11 @@
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 @wrong := [ $class.new(),
+ $class.new("foo"),
+ node_with_attr_set($class, $attr, "bar")
];
- my @wrongMessages := [ "$wrongBegin plain Block.",
+ my @wrongMessages := [ "$wrongBegin plain $class.",
"$wrongBegin with child.",
"$wrongBegin with wrong value."
];
@@ -225,6 +210,41 @@
}
}
+
+sub test_attribute_exact_matching_block_attributes () {
+ test_attribute_exact_matching_on_block_attr("blocktype");
+ test_attribute_exact_matching_on_block_attr("closure");
+ test_attribute_exact_matching_on_block_attr("control");
+ test_attribute_exact_matching_on_block_attr("loadinit");
+ test_attribute_exact_matching_on_block_attr("namespace");
+ test_attribute_exact_matching_on_block_attr("multi");
+ test_attribute_exact_matching_on_block_attr("hll");
+ test_attribute_exact_matching_on_block_attr("nsentry");
+ test_attribute_exact_matching_on_block_attr("lexical");
+ test_attribute_exact_matching_on_block_attr("compiler");
+ test_attribute_exact_matching_on_block_attr("compiler_args");
+ test_attribute_exact_matching_on_block_attr("subid");
+ test_attribute_exact_matching_on_block_attr("pirflags");
+}
+
+sub test_attribute_exact_matching_on_block_attr ($attr) {
+ test_attribute_exact_matching_on_subtype_attr(PAST::Block,
+ PAST::Pattern::Block,
+ $attr);
+}
+
+sub test_attribute_exact_matching_op_attributes () {
+ test_attribute_exact_matching_on_op_attr("pasttype");
+ test_attribute_exact_matching_on_op_attr("pirop");
+ test_attribute_exact_matching_on_op_attr("inline");
+}
+
+sub test_attribute_exact_matching_on_op_attr ($attr) {
+ test_attribute_exact_matching_on_subtype_attr(PAST::Op,
+ PAST::Pattern::Op,
+ $attr);
+}
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
More information about the parrot-commits
mailing list