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

[tcurtis at svn.parrot.org]

Author: tcurtis
Date: Wed Jun 23 19:56:40 2010
New Revision: 47788
URL: https://trac.parrot.org/parrot/changeset/47788

Log:
Add a helper function for more conveniently defining subclasses of PCT::Pattern anduse it to define PAST::Pattern::Control.

Modified:
   branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp
   branches/gsoc_past_optimization/runtime/parrot/library/PCT/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	Wed Jun 23 19:17:36 2010	(r47787)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PAST/Pattern.nqp	Wed Jun 23 19:56:40 2010	(r47788)
@@ -251,6 +251,11 @@
     }
 }
 
+INIT {
+    PAST::Pattern.new_subtype('PAST::Pattern::Control',
+                              PAST::Control,
+                              :attr(<handle_types handle_types_except>));
+}
 
 # Local Variables:
 #   mode: cperl

Modified: branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp
==============================================================================
--- branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp	Wed Jun 23 19:17:36 2010	(r47787)
+++ branches/gsoc_past_optimization/runtime/parrot/library/PCT/Pattern.nqp	Wed Jun 23 19:56:40 2010	(r47788)
@@ -18,6 +18,41 @@
 }
 
 class PCT::Pattern is Tree::Pattern {
+    method new_subtype ($name, $targetClass, *%adverbs) {
+        my $parent := %adverbs<parent> || self;
+        my $class := P6metaclass.new().new_class($name, :parent($parent));
+        
+        my @attributes := %adverbs<attr> || [];
+
+        for (@attributes) {
+            $class.HOW().add_method($class, $_,
+                                    sub ($value?) {
+                                        self.attr($_, $value,
+                                                  pir::defined__iP($value));
+                                    });
+        }
+
+        my &ACCEPTSEXACTLY := method ($node) {
+            return Tree::Pattern::Match.new(0)
+              unless $node ~~ $targetClass;
+            my $/ := Tree::Pattern::Match.new(1);
+            self.check_children($node, $/);
+            for @attributes {
+                last unless self.check_attribute($node, $_, $/);
+            }
+            if self ~~ PAST::Pattern {
+                self.check_past_node_attributes($node, $/);
+            }
+            else {
+                self.check_pct_node_attributes($node, $/);
+            }
+            $/.from($node) if $/;
+            $/;
+        }
+
+        $class.HOW().add_method($class, 'ACCEPTSEXACTLY', &ACCEPTSEXACTLY);
+    }
+
     method attr ($name, $value, $has_value) {
         my $result;
         if ($has_value) {

Modified: branches/gsoc_past_optimization/t/library/pastpattern.t
==============================================================================
--- branches/gsoc_past_optimization/t/library/pastpattern.t	Wed Jun 23 19:17:36 2010	(r47787)
+++ branches/gsoc_past_optimization/t/library/pastpattern.t	Wed Jun 23 19:56:40 2010	(r47788)
@@ -5,7 +5,7 @@
 pir::load_bytecode('PCT.pbc');
 pir::load_bytecode('PAST/Pattern.pbc');
 
-plan(2109);
+plan(2124);
 
 test_type_matching();
 test_attribute_exact_matching();
@@ -38,6 +38,7 @@
 
 sub test_type_matching() {
     my @classes := [ [ PAST::Block, PAST::Pattern::Block ],
+                     [ PAST::Control, PAST::Pattern::Control ],
                      [ PAST::Op, PAST::Pattern::Op ],
                      [ PAST::Stmts, PAST::Pattern::Stmts ],
                      [ PAST::Val, PAST::Pattern::Val ],