[svn:parrot] r47373 - in branches/gsoc_past_optimization: runtime/parrot/library/PAST t/library
tcurtis at svn.parrot.org
tcurtis at svn.parrot.org
Sat Jun 5 02:27:21 UTC 2010
Author: tcurtis
Date: Sat Jun 5 02:27:21 2010
New Revision: 47373
URL: https://trac.parrot.org/parrot/changeset/47373
Log:
Boolean matching based on node type, exact attribute/children values, .ACCEPTS(attr/child), or result of a closure invoked with an attribute/child, implemented and tested.
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 01:40:12 2010 (r47372)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp Sat Jun 5 02:27:21 2010 (r47373)
@@ -66,36 +66,36 @@
}
sub check ($patt, $val) {
- my $result := 0;
- if (pir::can__IPs($patt, "ACCEPTS")) {
- $result := $val ~~ $patt;
- } elsif (pir::does($patt, "invokable")) {
- $result := ?$patt($val);
- }
- else {
- $result := pir::iseq__IPP($patt, $val);
- CATCH {
+ pir::load_bytecode('Data/Dumper.pbc');
+ my $dumper := pir::new__PP(Data::Dumper);
+ my $result := 1;
+ if (pir::defined__IP($patt)) {
+ if (!pir::defined__IP($val)) {
+ say("bar");
$result := 0;
}
+ elsif (pir::can__IPs($patt, "ACCEPTS")) {
+ $result := ?($val ~~ $patt);
+ } elsif (pir::does($patt, "invokable")) {
+ $result := ?$patt($val);
+ }
+ else {
+ $result := pir::iseq__IPP($patt, $val);
+ CATCH {
+ $result := 0;
+ }
+ }
}
+ $dumper.dumper($patt);
+ $dumper.dumper($val);
+ say($result);
$result;
}
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 check($pVal, $nVal) {
- $result := 1;
- } else {
- $result := 0;
- }
- } else {
- $result := 1;
- }
- $result;
+ check($pattern.attr($attribute, null, 0),
+ $node.attr($attribute, null, 0));
}
sub check_children ($pattern, $node) {
@@ -200,6 +200,7 @@
&& PAST::Pattern::check_attribute($pattern, $node, "multi")
&& PAST::Pattern::check_attribute($pattern, $node, "hll")
&& PAST::Pattern::check_attribute($pattern, $node, "nsentry")
+ && PAST::Pattern::check_attribute($pattern, $node, "symtable")
&& PAST::Pattern::check_attribute($pattern, $node, "lexical")
&& PAST::Pattern::check_attribute($pattern, $node, "compiler")
&& PAST::Pattern::check_attribute($pattern, $node,
@@ -315,9 +316,10 @@
class PAST::Pattern::VarList is PAST::Pattern {
method ACCEPTS ($node) {
- ($node ~~ PAST::VarList
+ my $result := ($node ~~ PAST::VarList
&& PAST::Pattern::check_children(self, $node)
&& PAST::Pattern::check_node_attributes(self, $node));
+ $result;
}
}
Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t Sat Jun 5 01:40:12 2010 (r47372)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t Sat Jun 5 02:27:21 2010 (r47373)
@@ -5,11 +5,12 @@
pir::load_bytecode('PCT.pbc');
pir::load_bytecode('PAST/Pattern.pbc');
-plan(875);
+plan(1970);
test_type_matching();
test_attribute_exact_matching();
test_child_exact_matching();
+test_attribute_smart_matching();
test_child_smart_matching();
sub node_with_attr_set ($class, $attr, $val) {
@@ -314,6 +315,129 @@
}
}
+sub test_attribute_smart_matching () {
+ my $nodeattrs := "name source pos returns arity named flat ";
+ my @classes :=
+ [ [ PAST::Block, PAST::Pattern::Block,
+ pir::split(" ", $nodeattrs ~
+ "lvalue blocktype closure control loadinit " ~
+ "namespace multi hll nsentry symtable " ~
+ "lexical compiler compiler_args subid pirflags")
+ ],
+ [ PAST::Op, PAST::Pattern::Op,
+ pir::split(" ", $nodeattrs ~ "lvalue pirop pasttype inline")
+ ],
+ [ PAST::Stmts, PAST::Pattern::Stmts,
+ pir::split(" ", $nodeattrs ~ "lvalue")
+ ],
+ [ PAST::Val, PAST::Pattern::Val,
+ pir::split(" ", $nodeattrs ~ "value")
+ ],
+ [ PAST::Var, PAST::Pattern::Var,
+ pir::split(" ", $nodeattrs ~ "lvalue scope isdecl " ~
+ "namespace slurpy call_sig viviself vivibase " ~
+ "multitype")
+ ],
+ [ PAST::VarList, PAST::Pattern::VarList,
+ pir::split(" ", $nodeattrs ~ "lvalue")
+ ]
+ ];
+
+ for @classes {
+ my $class := $_[0];
+ my $patternClass := $_[1];
+ my @attrs := $_[2];
+
+ sub right ($node, $pattern, $msg) {
+ ok($node ~~ $pattern,
+ "Smart-matching attrs of $patternClass: $msg.");
+ }
+ sub wrong ($node, $pattern, $msg) {
+ ok(!($node ~~ $pattern),
+ "Non-smart-matching attrs of $patternClass: $msg.");
+ }
+
+ for @attrs {
+ my $attr := $_;
+
+ my $pattern :=
+ node_with_attr_set($patternClass,
+ $attr,
+ PAST::Pattern::Val.new());
+
+ right(node_with_attr_set($class,
+ $attr,
+ PAST::Val.new()),
+ $pattern,
+ "PAST::Pattern $attr");
+ wrong($class.new(), $pattern,
+ "PAST::Pattern $attr, no corresponding attr");
+ wrong(node_with_attr_set($class,
+ $attr,
+ PAST::Block.new()),
+ $pattern,
+ "PAST::Pattern $attr, wrong node type");
+ wrong(node_with_attr_set($class,
+ $attr eq "name"
+ ?? "pos"
+ !! "name",
+ PAST::Val.new()),
+ $pattern,
+ "PAST::Pattern $attr, wrong attribute");
+ wrong($class.new(PAST::Val.new()),
+ $pattern,
+ "PAST::Pattern $attr, in child instead");
+
+ $pattern := node_with_attr_set($patternClass,
+ $attr,
+ /foo/);
+
+ right(node_with_attr_set($class, $attr, "foo"),
+ $pattern,
+ "Regex $attr");
+ wrong($class.new(), $pattern,
+ "Regex $attr, no corresponding attr");
+ wrong(node_with_attr_set($class, $attr, "fop"),
+ $pattern,
+ "Regex $attr, wrong string");
+ wrong(node_with_attr_set($class,
+ $attr eq "name"
+ ?? "pos"
+ !! "name",
+ "foo"),
+ $pattern,
+ "Regex $attr, wrong attribute");
+ wrong($class.new("foo"),
+ $pattern,
+ "Regex $attr, in child instead");
+
+ $pattern := node_with_attr_set($patternClass,
+ $attr,
+ sub ($_) { +$_ % 2; });
+
+ right(node_with_attr_set($class, $attr, 1),
+ $pattern,
+ "Closure $attr");
+ wrong($class.new(), $pattern,
+ "Closure $attr, no corresponding attr");
+ wrong(node_with_attr_set($class, $attr, 2),
+ $pattern,
+ "Closure $attr, wrong result");
+ wrong(node_with_attr_set($class,
+ $attr eq "name"
+ ?? "pos"
+ !! "name",
+ "foo"),
+ $pattern,
+ "Closure $attr, wrong attribute");
+ wrong($class.new(1),
+ $pattern,
+ "Closure $attr, in child instead");
+
+ }
+ }
+}
+
sub test_child_smart_matching () {
my @classes := [ [ PAST::Block, PAST::Pattern::Block ],
[ PAST::Op, PAST::Pattern::Op ],
More information about the parrot-commits
mailing list