[svn:parrot] r47780 - in branches/gsoc_past_optimization/runtime/parrot/library: PAST PCT

tcurtis at svn.parrot.org tcurtis at svn.parrot.org
Wed Jun 23 08:00:36 UTC 2010


Author: tcurtis
Date: Wed Jun 23 08:00:36 2010
New Revision: 47780
URL: https://trac.parrot.org/parrot/changeset/47780

Log:
Move check_attribute, check_children into methods on PCT::Pattern. Rename check_node_attributes to
check_past_node_attributes now that PCT::Pattern exists.
Add check_pct_node_attributes.

Modified:
   branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
   branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp

Modified: branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Wed Jun 23 07:39:38 2010	(r47779)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Wed Jun 23 08:00:36 2010	(r47780)
@@ -43,70 +43,13 @@
         $result;
     }
 
-    sub check_attribute ($pattern, $node, $attribute, $/) {
-        my $pAttr := $pattern.attr($attribute, null, 0);
-        unless pir::defined__IP($pAttr) {
-            return 1;
-        }
-        my $nAttr := $node.attr($attribute, null, 0);
-        my $result := 
-          ($pAttr ~~ Tree::Pattern
-           ?? $pAttr.ACCEPTS($nAttr, :p($nAttr))
-           !! $nAttr ~~ $pAttr);
-        if ($result) {
-            $/{$attribute} := $result;
-        }
-        else {
-            $/.success(0);
-        }
-        $result;
-    }
-
-    sub check_children ($pattern, $node, $/) {
-        my $pLen := pir::elements($pattern);
-        my $nLen := pir::elements($node);
-        my $pChild;
-        my $nChild;
-        my $result;
-        my $index;
-        if $pLen == 0 {
-            $result := 1;
-        }
-        elsif ($pLen == $nLen) {
-            $index := 0;
-            while ($index < $pLen) {
-                $nChild := $node[$index];
-                $pChild := $pattern[$index];
-                if ($result := 
-                    ($pChild ~~ Tree::Pattern
-                     ?? $pChild.ACCEPTS($nChild, :p($nChild))
-                     !! $nChild ~~ $pChild)) {
-                    $/[$index] := $result;
-                }
-                else {
-                    $/.success(0);
-                    return 0;
-                }
-                $index++;
-            }
-            $result := 1;
-        }
-        else {
-            $/.success(0);
-            $result := 0;
-        }
-        $result;
-    }
-
-    sub check_node_attributes ($pattern, $node, $/) {
-        (check_attribute($pattern, $node, "name", $/)
-         && check_attribute($pattern, $node, "source", $/)
-         && check_attribute($pattern, $node, "pos", $/)
-         && check_attribute($pattern, $node, "returns", $/)
-         && check_attribute($pattern, $node, "arity", $/)
-         && check_attribute($pattern, $node, "named", $/)
-         && check_attribute($pattern, $node, "flat", $/)
-         && check_attribute($pattern, $node, "lvalue", $/));
+    method check_past_node_attributes ($node, $/) {
+        (self.check_pct_node_attributes($node, $/)
+         && self.check_attribute($node, "returns", $/)
+         && self.check_attribute($node, "arity", $/)
+         && self.check_attribute($node, "named", $/)
+         && self.check_attribute($node, "flat", $/)
+         && self.check_attribute($node, "lvalue", $/));
     }
 }
 
@@ -170,36 +113,22 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::Block;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_attribute(self, $node,
-                                              "blocktype", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "closure", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "control", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "loadinit", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "namespace", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "multi", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "hll", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "nsentry", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "symtable", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "lexical", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "compiler", $/)
-         && PAST::Pattern::check_attribute(self, $node, 
-                                                 "compiler_args", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "subid", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "pirflags", $/)
-         && PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/));
+        (self.check_attribute($node, "blocktype", $/)
+         && self.check_attribute($node, "closure", $/)
+         && self.check_attribute($node, "control", $/)
+         && self.check_attribute($node, "loadinit", $/)
+         && self.check_attribute($node, "namespace", $/)
+         && self.check_attribute($node, "multi", $/)
+         && self.check_attribute($node, "hll", $/)
+         && self.check_attribute($node, "nsentry", $/)
+         && self.check_attribute($node, "symtable", $/)
+         && self.check_attribute($node, "lexical", $/)
+         && self.check_attribute($node, "compiler", $/)
+         && self.check_attribute($node, "compiler_args", $/)
+         && self.check_attribute($node, "subid", $/)
+         && self.check_attribute($node, "pirflags", $/)
+         && self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/));
         $/.from($node) if $/;
         $/;
     }
@@ -223,14 +152,11 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::Op;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_attribute(self, $node,
-                                              "pasttype", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "pirop", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "inline", $/)
-         && PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/));
+        (self.check_attribute($node, "pasttype", $/)
+         && self.check_attribute($node, "pirop", $/)
+         && self.check_attribute($node, "inline", $/)
+         && self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/));
         $/.from($node) if $/;
         $/;
     }
@@ -240,8 +166,8 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::Stmts;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/));
+        (self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/));
         $/.from($node) if $/;
         $/;
     }
@@ -255,10 +181,9 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::Val;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/)
-         && PAST::Pattern::check_attribute(self, $node, 
-                                                 "value", $/));
+        (self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/)
+         && self.check_attribute($node, "value", $/));
         $/.from($node) if $/;
         $/;
     }
@@ -300,24 +225,16 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::Var;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_attribute(self, $node,
-                                              "scope", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "isdecl", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "namespace", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "slurpy", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "call_sig", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "viviself", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "vivibase", $/)
-         && PAST::Pattern::check_attribute(self, $node,
-                                                 "multitype", $/)
-         && PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/));
+        (self.check_attribute($node, "scope", $/)
+         && self.check_attribute($node, "isdecl", $/)
+         && self.check_attribute($node, "namespace", $/)
+         && self.check_attribute($node, "slurpy", $/)
+         && self.check_attribute($node, "call_sig", $/)
+         && self.check_attribute($node, "viviself", $/)
+         && self.check_attribute($node, "vivibase", $/)
+         && self.check_attribute($node, "multitype", $/)
+         && self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/));
         $/.from($node) if $/;
         $/;
     }
@@ -327,8 +244,8 @@
     method ACCEPTSEXACTLY ($node) {
         return Tree::Pattern::Match.new(0) unless $node ~~ PAST::VarList;
         my $/ := Tree::Pattern::Match.new(1);
-        (PAST::Pattern::check_children(self, $node, $/)
-         && PAST::Pattern::check_node_attributes(self, $node, $/));
+        (self.check_children($node, $/)
+         && self.check_past_node_attributes($node, $/));
         $/.from($node) if $/;
         $/;
     }

Modified: branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp	Wed Jun 23 07:39:38 2010	(r47779)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp	Wed Jun 23 08:00:36 2010	(r47780)
@@ -39,6 +39,68 @@
     method pos ($val?) {
         self.attr("pos", $val, !pir::isnull__iP($val));
     }
+
+    method check_attribute ($node, $attribute, $/) {
+        my $pAttr := self.attr($attribute, null, 0);
+        unless pir::defined__IP($pAttr) {
+            return 1;
+        }
+        my $nAttr := $node.attr($attribute, null, 0);
+        my $result := 
+          ($pAttr ~~ Tree::Pattern
+           ?? $pAttr.ACCEPTS($nAttr, :p($nAttr))
+           !! $nAttr ~~ $pAttr);
+        if ($result) {
+            $/{$attribute} := $result;
+        }
+        else {
+            $/.success(0);
+        }
+        $result;
+    }
+
+    method check_children ($node, $/) {
+        my $pLen := pir::elements(self);
+        my $nLen := pir::elements($node);
+        my $pChild;
+        my $nChild;
+        my $result;
+        my $index;
+        if $pLen == 0 {
+            $result := 1;
+        }
+        elsif ($pLen == $nLen) {
+            $index := 0;
+            while ($index < $pLen) {
+                $nChild := $node[$index];
+                $pChild := self[$index];
+                if ($result := 
+                    ($pChild ~~ Tree::Pattern
+                     ?? $pChild.ACCEPTS($nChild, :p($nChild))
+                     !! $nChild ~~ $pChild)) {
+                    $/[$index] := $result;
+                }
+                else {
+                    $/.success(0);
+                    return 0;
+                }
+                $index++;
+            }
+            $result := 1;
+        }
+        else {
+            $/.success(0);
+            $result := 0;
+        }
+        $result;
+    }
+
+    method check_pct_node_attributes ($node, $/) {
+        (self.check_attribute($node, "name", $/)
+         && self.check_attribute($node, "source", $/)
+         && self.check_attribute($node, "pos", $/));
+
+    }
 }
 
 # Local Variables:


More information about the parrot-commits mailing list