Implement declaration of methods on the metaclass (e.g. method ^foo($…

…obj, ... ) { ... }). Also we toss the use of Parrot's MMD in calling !meta_compose; it's less code to not use it anyway.

src/builtins/guts.pir

@@ -583,11 +583,17 @@ and creating the protoobjects.
 
 =cut
 
-.sub '!meta_compose' :multi(['ClassHOW'])
+.sub '!meta_compose' 
     .param pmc metaclass
     .local pmc p6meta
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 
+    # If it's a RoleHOW or otherwise just not a ClassHOW, nothing to do.
+    $I0 = isa metaclass, 'RoleHOW'
+    if $I0 goto no_pkgtype
+    $I0 = isa metaclass, 'ClassHOW'
+    unless $I0 goto no_pkgtype
+
     # Extract the parrotclass form the metaclass.
     .local pmc parrotclass
     parrotclass = getattribute metaclass, 'parrotclass'
@@ -624,6 +630,7 @@ and creating the protoobjects.
   register_parent_set:
     .tailcall p6meta.'register'(parrotclass, 'how'=>metaclass)
   no_pkgtype:
+    .return (metaclass)
 .end
 
 
@@ -660,32 +667,6 @@ Flattens out the list of roles.
 .end
 
 
-=item !meta_compose(Role)
-
-Role meta composer -- does nothing.
-
-=cut
-
-.sub '!meta_compose' :multi(['RoleHOW'])
-    .param pmc metaclass
-    # Currently, nothing to do.
-    .return (metaclass)
-.end
-
-
-=item !meta_compose()
-
-Default meta composer -- does nothing.
-
-=cut
-
-.sub '!meta_compose' :multi()
-    .param pmc metaclass
-    # Currently, nothing to do.
-    .return (metaclass)
-.end
-
-
 =item !meta_attribute(metaclass, name, itypename [, 'type'=>type] )
 
 Add attribute C<name> to C<metaclass> with the given C<itypename>
@@ -954,6 +935,39 @@ Helper method to compose the attributes of a role into a class.
   fixup_iter_loop_end:
 .end
 
+
+=item !add_metaclass_method
+
+=cut
+
+.sub '!add_metaclass_method'
+    .param pmc metaclass
+    .param pmc name
+    .param pmc method
+
+    # Create role for the method and mix it into the meta-class.
+    $P0 = root_new ['parrot';'P6role']
+    $S0 = name
+    addmethod $P0, $S0, method
+    'infix:does'(metaclass, $P0)
+
+    # Add forward method to the class itself.
+    .lex '$meth_name', name
+    .const 'Sub' $P1 = '!metaclass_method_forwarder'
+    $P1 = newclosure $P1
+    $P0 = getattribute metaclass, 'parrotclass'
+    $P0.'add_method'(name, $P1)
+.end
+.sub '!metaclass_method_forwarder' :outer('!add_metaclass_method') :method :anon
+    .param pmc pos_args    :slurpy
+    .param pmc named_args  :slurpy :named
+    $P0 = self.'HOW'()
+    $P1 = find_lex '$meth_name'
+    $S0 = $P1
+    .tailcall $P0.$S0(self, pos_args :flat, named_args :flat :named)
+.end
+
+
 =item !create_parametric_role
 
 Helper method for creating parametric roles.

src/parser/actions.pm

@@ -1,4 +1,4 @@
-# Copyright (C) 2007-2008, The Perl Foundation.
+# Copyright (C) 2007-2009, The Perl Foundation.
 # $Id$
 
 class Perl6::Grammar::Actions ;
@@ -826,6 +826,7 @@ method method_def($/) {
 
     if $<deflongname> {
         my $name := ~$<deflongname>;
+        if $<meth_mod> eq '!' { $name := '!' ~ $name }
         my $match := Perl6::Grammar::opname($name, :grammar('Perl6::Grammar') );
         if $match { $name := add_optoken($block, $match); }
         $block.name( $name );
@@ -882,6 +883,21 @@ method method_def($/) {
         emit_traits($<trait>, $loadinit, $blockreg);
     }
 
+    # If it's a metaclass method, make it anonymous and then push a call to
+    # !add_metaclass_method onto the current class definition.
+    if $<meth_mod> eq '^' {
+        our $?METACLASS;
+        our @?BLOCK;
+        $block.pirflags(~$block.pirflags() ~ ' :anon ');
+        @?BLOCK[0][0].push(PAST::Op.new(
+            :pasttype('call'),
+            :name('!add_metaclass_method'),
+            $?METACLASS,
+            $block.name,
+            PAST::Op.new( :inline('    .const "Sub" %r = "' ~ $block.subid ~ '"') )
+        ));
+    }
+
     make $block;
 }
 

src/parser/grammar.pg

@@ -426,7 +426,7 @@ rule routine_def {
 
 rule method_def {
     [
-    | $<deflongname>=[<[ ! ]>?<longname>] [ <multisig> | <trait> ]*
+    | $<meth_mod>=[<[ ! ^ ]>?]$<deflongname>=[<longname>?] [ <multisig> | <trait> ]*
     | <multisig> <trait>*
     | ::
     ]