[svn:parrot] r47430 - in branches/gsoc_past_optimization: . config/gen/makefiles runtime/parrot/library/PAST runtime/parrot/library/PAST/Pattern t/library
tcurtis at svn.parrot.org
tcurtis at svn.parrot.org
Sun Jun 6 22:27:44 UTC 2010
Author: tcurtis
Date: Sun Jun 6 22:27:43 2010
New Revision: 47430
URL: https://trac.parrot.org/parrot/changeset/47430
Log:
Matching PAST::Pattern::Node subclasses returns a PAST::Pattern::Match object.
Added:
branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Match.nqp (contents, props changed)
Modified:
branches/gsoc_past_optimization/MANIFEST
branches/gsoc_past_optimization/config/gen/makefiles/root.in
branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/ (props changed)
branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Node.nqp
branches/gsoc_past_optimization/t/library/pastpattern.t
Modified: branches/gsoc_past_optimization/MANIFEST
==============================================================================
--- branches/gsoc_past_optimization/MANIFEST Sun Jun 6 16:09:33 2010 (r47429)
+++ branches/gsoc_past_optimization/MANIFEST Sun Jun 6 22:27:43 2010 (r47430)
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Jun 5 22:12:05 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sun Jun 6 20:17:59 2010 UT
#
# See below for documentation on the format of this file.
#
@@ -1160,6 +1160,7 @@
runtime/parrot/library/PAST/Pattern.nqp [library]
runtime/parrot/library/PAST/Pattern/Closure.nqp [library]
runtime/parrot/library/PAST/Pattern/Constant.nqp [library]
+runtime/parrot/library/PAST/Pattern/Match.nqp [library]
runtime/parrot/library/PAST/Pattern/Node.nqp [library]
runtime/parrot/library/PAST/Transformer.pir [library]
runtime/parrot/library/PAST/Transformer/Dynamic.pir [library]
Modified: branches/gsoc_past_optimization/config/gen/makefiles/root.in
==============================================================================
--- branches/gsoc_past_optimization/config/gen/makefiles/root.in Sun Jun 6 16:09:33 2010 (r47429)
+++ branches/gsoc_past_optimization/config/gen/makefiles/root.in Sun Jun 6 22:27:43 2010 (r47430)
@@ -288,6 +288,7 @@
$(LIBRARY_DIR)/PAST/Pattern.pbc \
$(LIBRARY_DIR)/PAST/Pattern/Closure.pbc \
$(LIBRARY_DIR)/PAST/Pattern/Constant.pbc \
+ $(LIBRARY_DIR)/PAST/Pattern/Match.pbc \
$(LIBRARY_DIR)/PAST/Pattern/Node.pbc \
$(LIBRARY_DIR)/PAST/Transformer.pbc \
$(LIBRARY_DIR)/PAST/Transformer/Dynamic.pbc \
@@ -1082,6 +1083,15 @@
$(NQP_RX) --target=pir $(LIBRARY_DIR)/PAST/Pattern/Closure.nqp\
> $@
+$(LIBRARY_DIR)/PAST/Pattern/Match.pbc: \
+ $(LIBRARY_DIR)/PAST/Pattern/Match.pir
+ $(PARROT) -o $@ $(LIBRARY_DIR)/PAST/Pattern/Match.pir
+
+$(LIBRARY_DIR)/PAST/Pattern/Match.pir: \
+ $(LIBRARY_DIR)/PAST/Pattern/Match.nqp $(NQP_RX)
+ $(NQP_RX) --target=pir $(LIBRARY_DIR)/PAST/Pattern/Match.nqp \
+ > $@
+
$(LIBRARY_DIR)/PAST/Pattern/Node.pbc: \
$(LIBRARY_DIR)/PAST/Pattern/Node.pir
$(PARROT) -o $@ $(LIBRARY_DIR)/PAST/Pattern/Node.pir
Modified: branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp Sun Jun 6 16:09:33 2010 (r47429)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp Sun Jun 6 22:27:43 2010 (r47430)
@@ -2,10 +2,6 @@
# Copyright (C) 2010, Parrot Foundation.
# $Id$
-INIT {
- pir::load_bytecode("PCT.pbc");
-}
-
class PAST::Pattern is Capture {
sub patternize ($value) {
unless (pir::can__IPS($value, 'ACCEPTS')) {
@@ -30,6 +26,8 @@
}
INIT {
+ pir::load_bytecode('PAST/Pattern/Match.pbc');
+
pir::load_bytecode('PAST/Pattern/Closure.pbc');
pir::load_bytecode('PAST/Pattern/Constant.pbc');
pir::load_bytecode('PAST/Pattern/Node.pbc');
Added: branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Match.nqp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Match.nqp Sun Jun 6 22:27:43 2010 (r47430)
@@ -0,0 +1,70 @@
+#!./parrot-nqp
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+class PAST::Pattern::Match is Capture {
+ has $!success;
+ has $!ast;
+ has $!from;
+
+ method new ($success?, $from?) {
+ my $self := Q:PIR {
+ $P0 = self.'HOW'()
+ $P0 = getattribute $P0, 'parrotclass'
+ %r = new $P0
+ };
+ $self.success($success);
+ $self.from($from);
+ $self;
+ }
+
+ method Bool () {
+ pir::getattribute__PPS(self, '$!success');
+ }
+
+ method ast () {
+ pir::getattribute__PPS(self, '$!ast');
+ }
+
+ method from ($from?) {
+ my $result;
+ if pir::defined__IP($from) {
+ pir::setattribute(self, ~'$!from', $from);
+ } else {
+ $result := pir::getattribute__PPS(self, '$!from');
+ }
+ $result;
+ }
+
+ method success ($success?) {
+ my $result;
+ if pir::defined__IP($success) {
+ pir::setattribute(self, ~'$!success', $success);
+ }
+ else {
+ $result := pir::getattribute__PPS(self, '$!success');
+ }
+ $result;
+ }
+}
+
+INIT {
+ my $parrotclass :=
+ pir::getattribute__PPS(PAST::Pattern::Match.HOW(), "parrotclass");
+ $parrotclass.add_vtable_override("get_bool",
+ sub ($self) {
+ $self.Bool();
+ });
+
+ $parrotclass.add_method("!make",
+ method ($ast) {
+ pir::setattribute(self, ~'$!ast', $ast);
+ });
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Modified: branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Node.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Node.nqp Sun Jun 6 16:09:33 2010 (r47429)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern/Node.nqp Sun Jun 6 22:27:43 2010 (r47430)
@@ -2,6 +2,10 @@
# Copyright (C) 2010, Parrot Foundation.
# $Id$
+INIT {
+ pir::load_bytecode('PCT.pbc');
+}
+
class PAST::Pattern::Node is PAST::Pattern {
method attr ($name, $value, $has_value) {
my $result;
@@ -113,13 +117,20 @@
method ACCEPTS ($node) {
my $result := self.ACCEPTSEXACTLY($node);
- if (!$result && $node ~~ PAST::Node) {
+ if ($result) {
+ $result := PAST::Pattern::Match.new(1, $node);
+ }
+ elsif ($node ~~ PAST::Node) {
my $index := 0;
my $max := pir::elements__IP($node);
- until ($result || $index == $max) {
+ until ($index == $max) {
$result := $node[$index] ~~ self;
+ return $result if $result;
$index++;
}
+ $result := PAST::Pattern::Match.new(0);
+ } else {
+ $result := PAST::Pattern::Match.new(0);
}
$result;
}
@@ -183,21 +194,34 @@
}
sub check_block_attributes($pattern, $node) {
- (PAST::Pattern::Node::check_attribute($pattern, $node, "blocktype")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "closure")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "control")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "loadinit")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "namespace")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "multi")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "hll")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "nsentry")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "symtable")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "lexical")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "compiler")
+ (PAST::Pattern::Node::check_attribute($pattern, $node,
+ "blocktype")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "closure")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "control")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "loadinit")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "namespace")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "multi")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "hll")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "nsentry")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "symtable")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "lexical")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "compiler")
&& PAST::Pattern::Node::check_attribute($pattern, $node,
- "compiler_args")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "subid")
- && PAST::Pattern::Node::check_attribute($pattern, $node, "pirflags"));
+ "compiler_args")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "subid")
+ && PAST::Pattern::Node::check_attribute($pattern, $node,
+ "pirflags"));
}
method ACCEPTSEXACTLY ($node) {
Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t Sun Jun 6 16:09:33 2010 (r47429)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t Sun Jun 6 22:27:43 2010 (r47430)
@@ -5,7 +5,7 @@
pir::load_bytecode('PCT.pbc');
pir::load_bytecode('PAST/Pattern.pbc');
-plan(1994);
+plan(2024);
test_type_matching();
test_attribute_exact_matching();
@@ -15,8 +15,9 @@
test_deep_matching_in_children();
+test_match_result();
+
sub node_with_attr_set ($class, $attr, $val) {
- say("Node of type $class with $attr set to $val made.");
my $node := $class.new();
if (($attr eq "source" || $attr eq "pos")
&& pir::isa__IPP($class, PAST::Node)) {
@@ -542,6 +543,44 @@
}
+sub test_match_result () {
+ test_match_result_from_top_node();
+# test_match_result_from_sub_node();
+}
+
+sub test_match_result_from_top_node () {
+ 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];
+
+ my $begin := "Match result from $patternClass:";
+
+ my $pattern := $patternClass.new();
+ my $node := $class.new();
+ my $/ := $node ~~ $pattern;
+ ok($/ ~~ PAST::Pattern::Match,
+ "$begin $patternClass 1, returns a PAST::Pattern::Match");
+ ok(?$/, "$begin $patternClass 1, Bool conversion");
+ ok($/.from() =:= $node,
+ "$begin $patternClass 1, .from");
+
+ $node := ($class =:= PAST::Block
+ ?? PAST::Op !! PAST::Block).new();
+ $/ := $node ~~ $pattern;
+ ok($/ ~~ PAST::Pattern::Match,
+ "$begin $patternClass 0, returns PAST::Pattern::Match");
+ ok(!?$/, "$begin $patternClass 0, Bool conversion.");
+ }
+}
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
More information about the parrot-commits
mailing list