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

tcurtis at svn.parrot.org tcurtis at svn.parrot.org
Wed Jun 2 07:49:24 UTC 2010


Author: tcurtis
Date: Wed Jun  2 07:49:24 2010
New Revision: 47285
URL: https://trac.parrot.org/parrot/changeset/47285

Log:
All tests pass. More attributes tomorrow(fortunately, should be easy). Also, make codetest happy.

Modified:
   branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp   (contents, props changed)
   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	Wed Jun  2 06:18:21 2010	(r47284)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Wed Jun  2 07:49:24 2010	(r47285)
@@ -16,8 +16,44 @@
     has $flat;
     has $lvalue;
 
+    method new (*@children, *%attrs) {
+        my $result := Q:PIR {
+            $P0 = self.'HOW'()
+            $P0 = getattribute $P0, 'parrotclass'
+            %r = new $P0
+        };
+
+        for %attrs {
+            $result{$_} := %attrs{$_};
+        }
+        for @children {
+            pir::push($result, $_);
+        }
+        $result;
+    }
+
+    sub check_attribute ($pattern, $node, $attribute) {
+        my $pVal := $pattern{$attribute};
+        my $nVal := $node{$attribute};
+        my $result;
+        if $pVal {
+            if pir::iseq__i_p_p($pVal, $nVal) {
+                $result := ?1;
+            } else {
+                $result := ?0;
+            }
+        } else {
+            $result := ?1;
+        }
+        $result;
+    }
+
+    sub check_node_attributes ($pattern, $node) {
+        check_attribute($pattern, $node, "name");
+    }
+
     method ACCEPTS ($node) {
-        0;
+        ?0;
     }
 }
 
@@ -38,35 +74,40 @@
     has $pirflags;
 
     method ACCEPTS ($node) {
-        $node ~~ PAST::Block;
+        (($node ~~ PAST::Block)
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 
-class PAST::Pattern::Op {
+
+class PAST::Pattern::Op is PAST::Pattern {
     has $pasttype;
     has $pirop;
     has $inline;
 
     method ACCEPTS ($node) {
-        $node ~~ PAST::Op;
+        ($node ~~ PAST::Op
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 
-class PAST::Pattern::Stmts {
+class PAST::Pattern::Stmts is PAST::Pattern {
     method ACCEPTS ($node) {
-        $node ~~ PAST::Stmts;
+        ($node ~~ PAST::Stmts
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 
-class PAST::Pattern::Val {
+class PAST::Pattern::Val is PAST::Pattern {
     has $value;
 
     method ACCEPTS ($node) {
-        $node ~~ PAST::Val;
+        ($node ~~ PAST::Val
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 
-class PAST::Pattern::Var {
+class PAST::Pattern::Var is PAST::Pattern {
     has $scope;
     has $isdecl;
     has $namespace;
@@ -77,13 +118,15 @@
     has $multitype;
 
     method ACCEPTS ($node) {
-        $node ~~ PAST::Var;
+        ($node ~~ PAST::Var
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 
-class PAST::Pattern::VarList {
+class PAST::Pattern::VarList is PAST::Pattern {
     method ACCEPTS ($node) {
-        $node ~~ PAST::VarList;
+        ($node ~~ PAST::VarList
+         && PAST::Pattern::check_node_attributes(self, $node));
     }
 }
 

Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t	Wed Jun  2 06:18:21 2010	(r47284)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Wed Jun  2 07:49:24 2010	(r47285)
@@ -104,6 +104,7 @@
            "Non-matching PAST::Pattern::Block.name " ~ ($iota++) );
     }
 
+    $right := PAST::Op.new(:name("foo"));
     $pattern := PAST::Pattern::Op.new(:name("foo"));
     ok($right ~~ $pattern, "Matching PAST::Pattern::Op.name.");
 
@@ -122,6 +123,7 @@
            "Non-matching PAST::Pattern::Op.name " ~ ($iota++) );
     }
 
+    $right := PAST::Stmts.new(:name("foo"));
     $pattern := PAST::Pattern::Stmts.new(:name("foo"));
     ok($right ~~ $pattern, "Matching PAST::Pattern::Stmts.name.");
 
@@ -139,6 +141,7 @@
            "Non-matching PAST::Pattern::Stmts.name " ~ ($iota++) );
     }
 
+    $right := PAST::Val.new(:name("foo"));
     $pattern := PAST::Pattern::Val.new(:name("foo"));
     ok($right ~~ $pattern, "Matching PAST::Pattern::Val.name.");
 
@@ -157,6 +160,7 @@
            "Non-matching PAST::Pattern::Val.name " ~ ($iota++) );
     }
 
+    $right := PAST::Var.new(:name("foo"));
     $pattern := PAST::Pattern::Var.new(:name("foo"));
     ok($right ~~ $pattern, "Matching PAST::Pattern::Var.name.");
 
@@ -175,6 +179,7 @@
            "Non-matching PAST::Pattern::Var.name " ~ ($iota++) );
     }
 
+    $right := PAST::VarList.new(:name("foo"));
     $pattern := PAST::Pattern::VarList.new(:name("foo"));
     ok($right ~~ $pattern, "Matching PAST::Pattern::VarList.name.");
 


More information about the parrot-commits mailing list