[svn:parrot] r35542 - in trunk/languages/perl6/src: builtins parser

Author: jonathan
Date: Wed Jan 14 10:55:09 2009
New Revision: 35542

Modified:
   trunk/languages/perl6/src/builtins/guts.pir
   trunk/languages/perl6/src/parser/actions.pm

Log:
[rakudo] Parametric roles now clone methods, meaning that we get them attached to the right parameters.

Modified: trunk/languages/perl6/src/builtins/guts.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/guts.pir	(original)
+++ trunk/languages/perl6/src/builtins/guts.pir	Wed Jan 14 10:55:09 2009
@@ -438,7 +438,9 @@
   role:
     # This is a little fun. We only want to create the Parrot role and suck
     # in the methods once per role definition. We do this and it is attached to
-    # the namespace. Next time, we will find and clone it.
+    # the namespace. Then we attach this "master role" to a new one we create
+    # per invocation, so the methods can be newclosure'd and added into it in
+    # the body.
     .local pmc info, metarole
     ns = get_hll_namespace nsarray
     metarole = get_class ns
@@ -449,12 +451,22 @@
     info['name'] = $P0
     info['namespace'] = nsarray
     metarole = new 'Role', info
-  
   have_role:
-    # XXX At this point, we need to create a clone of the role, but it's a bit
-    # more special than that; we also need to clone and lexically capture the
-    # methods of the role so they will get the parameters captured.
-    .return (metarole)
+    
+    # Copy list of roles done by the metarole.
+    .local pmc result, tmp, it
+    result = new 'Role'
+    setprop result, '$!orig_role', metarole
+    tmp = metarole.'roles'()
+    it = iter tmp
+  roles_loop:
+    unless it goto roles_loop_end
+    tmp = shift it
+    result.'add_role'(tmp)
+    goto roles_loop
+  roles_loop_end:
+
+    .return (result)
 .end
 
 

Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm	(original)
+++ trunk/languages/perl6/src/parser/actions.pm	Wed Jan 14 10:55:09 2009
@@ -1544,23 +1544,41 @@
     );
 
     #  ...and at the end of the block's initializer (after any other
-    #  items added by the block), we finalize the composition. This
-    # returns a proto, which we need to keep around and also return at
-    # the end of initialization for anonymous classes. We always need to
-    # return it for roles, since we do a role by invoking the multi-sub
-    # it produces (but those don't want to be immediate).
-    if $<module_name> eq "" && ($?PKGDECL eq 'class' || $?PKGDECL eq 'grammar')
-            || $?PKGDECL eq 'role' {
+    #  items added by the block), we finalize the composition. 
+    if $?PKGDECL eq 'role' {
+        #  For a role, we now need to produce a new one which clones the original,
+        #  but without the methods. Then we need to add back the methods. We emit
+        #  PIR here to do it rather than doing a call, since we need to call
+        #  new_closure from the correct scope.
+        $block[0].push(PAST::Op.new(:inline(
+                '    .local pmc orig_role, meths, meth_iter',
+                '    orig_role = getprop "$!orig_role", %0',
+                '    meths = orig_role."methods"()',
+                '    meth_iter = iter meths',
+                '  it_loop:',
+                '    unless meth_iter goto it_loop_end',
+                '    $S0 = shift meth_iter',
+                '    $P0 = meths[$S0]',
+                '    $P0 = newclosure $P0',
+                '    %0."add_method"($S0, $P0)',
+                '    goto it_loop',
+                '  it_loop_end:',
+                '    .return (%0)'
+            ),
+            $?METACLASS
+        ));
+    }
+    elsif $<module_name> eq "" && ($?PKGDECL eq 'class' || $?PKGDECL eq 'grammar') {
+        #  We need to keep the proto around and return it at the end of
+        #  initialization for anonymous classes.
         $block[0].push(PAST::Op.new(
             :pasttype('bind'),
             PAST::Var.new(:name('proto_store'), :scope('register'), :isdecl(1)),
             PAST::Op.new( :name('!meta_compose'), $?METACLASS)
         ));
         $block.push(PAST::Var.new(:name('proto_store'), :scope('register')));
-        if $?PKGDECL ne 'role' {
-            $block.blocktype('immediate');
-            $block.pirflags('');
-        }
+        $block.blocktype('immediate');
+        $block.pirflags('');
     }
     else {
         $block[0].push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) );

• [svn:parrot] r35542 - in trunk/languages/perl6/src: builtins parser by jonathan