Add default %_ for methods. It's rather smarter than master, and does…

…n't allocate if it's never used.

src/Perl6/Actions.pm

@@ -834,7 +834,7 @@ class Perl6::Actions is HLL::Actions {
             }
         }
         elsif $name eq '%_' {
-            unless $*ST.nearest_signatured_block_declares('%_') {
+            unless $*ST.nearest_signatured_block_declares('%_') || $*METHODTYPE {
                 $past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1));
             }
         }
@@ -1189,7 +1189,7 @@ class Perl6::Actions is HLL::Actions {
         }
         $past.name(~$<longname>);
 
-        # Get signature and ensure it has an invocant.
+        # Get signature and ensure it has an invocant and *%_.
         if $past<placeholder_sig> {
             $/.CURSOR.panic('Placeholder variables cannot be used in a method');
         }
@@ -1201,6 +1201,15 @@ class Perl6::Actions is HLL::Actions {
                 is_multi_invocant => 1
             ));
         }
+        unless @params[+@params - 1]<named_slurpy> {
+            @params.push(hash(
+                variable_name => '%_',
+                nominal_type => $*ST.find_symbol(['Mu']),
+                named_slurpy => 1,
+                is_multi_invocant => 1,
+                is_method_named_slurpy => 1
+            ));
+        }
         set_default_parameter_type(@params, 'Any');
         my $signature := create_signature_object(@params, $past);
         add_signature_binding_code($past, $signature, @params);

src/Perl6/Grammar.pm

@@ -178,6 +178,7 @@ grammar Perl6::Grammar is HLL::Grammar {
         :my $*MONKEY_TYPING := 0;                  # whether augment/supersede are allowed
         :my $*begin_compunit := 1;                 # whether we're at start of a compilation unit
         :my $*DECLARAND;                           # the current thingy we're declaring, and subject of traits
+        :my $*METHODTYPE;                          # the current type of method we're in, if any
 
         # Extras.
         :my %*METAOPGEN;                           # hash of generated metaops
@@ -1110,6 +1111,7 @@ grammar Perl6::Grammar is HLL::Grammar {
 
     rule routine_def($d) {
         :my $*IN_DECL := $d;
+        :my $*METHODTYPE;
         <deflongname>?
         <.newpad>
         [ '(' <multisig> ')' ]?

src/Perl6/Metamodel/BOOTSTRAP.pm

@@ -590,7 +590,7 @@ my $error_cd := Perl6::Metamodel::ContainerDescriptor.new(
 my $match_cd := Perl6::Metamodel::ContainerDescriptor.new(
     :of(Mu), :rw(1), :name('$/'));
 pir::new__PsP('Perl6LexPad', hash()).configure_magicals(
-    $topic_cd, $error_cd, $match_cd, Scalar, Any);
+    $topic_cd, $error_cd, $match_cd, Scalar, Any, EnumMap, Hash);
 
 # Build up EXPORT::DEFAULT.
 my module EXPORT {

src/Perl6/SymbolTable.pm

@@ -3,24 +3,25 @@ use Perl6::ModuleLoader;
 
 # Binder constants.
 # XXX Want constant syntax in NQP really.
-my $SIG_ELEM_BIND_CAPTURE       := 1;
-my $SIG_ELEM_BIND_PRIVATE_ATTR  := 2;
-my $SIG_ELEM_BIND_PUBLIC_ATTR   := 4;
-my $SIG_ELEM_SLURPY_POS         := 8;
-my $SIG_ELEM_SLURPY_NAMED       := 16;
-my $SIG_ELEM_SLURPY_LOL         := 32;
-my $SIG_ELEM_INVOCANT           := 64;
-my $SIG_ELEM_MULTI_INVOCANT     := 128;
-my $SIG_ELEM_IS_RW              := 256;
-my $SIG_ELEM_IS_COPY            := 512;
-my $SIG_ELEM_IS_PARCEL          := 1024;
-my $SIG_ELEM_IS_OPTIONAL        := 2048;
-my $SIG_ELEM_ARRAY_SIGIL        := 4096;
-my $SIG_ELEM_HASH_SIGIL         := 8192;
-my $SIG_ELEM_DEFAULT_FROM_OUTER := 16384;
-my $SIG_ELEM_IS_CAPTURE         := 32768;
-my $SIG_ELEM_UNDEFINED_ONLY     := 65536;
-my $SIG_ELEM_DEFINED_ONLY       := 131072;
+my $SIG_ELEM_BIND_CAPTURE        := 1;
+my $SIG_ELEM_BIND_PRIVATE_ATTR   := 2;
+my $SIG_ELEM_BIND_PUBLIC_ATTR    := 4;
+my $SIG_ELEM_SLURPY_POS          := 8;
+my $SIG_ELEM_SLURPY_NAMED        := 16;
+my $SIG_ELEM_SLURPY_LOL          := 32;
+my $SIG_ELEM_INVOCANT            := 64;
+my $SIG_ELEM_MULTI_INVOCANT      := 128;
+my $SIG_ELEM_IS_RW               := 256;
+my $SIG_ELEM_IS_COPY             := 512;
+my $SIG_ELEM_IS_PARCEL           := 1024;
+my $SIG_ELEM_IS_OPTIONAL         := 2048;
+my $SIG_ELEM_ARRAY_SIGIL         := 4096;
+my $SIG_ELEM_HASH_SIGIL          := 8192;
+my $SIG_ELEM_DEFAULT_FROM_OUTER  := 16384;
+my $SIG_ELEM_IS_CAPTURE          := 32768;
+my $SIG_ELEM_UNDEFINED_ONLY      := 65536;
+my $SIG_ELEM_DEFINED_ONLY        := 131072;
+my $SIG_ELEM_METHOD_SLURPY_NAMED := 262144;
 
 # This builds upon the SerializationContextBuilder to add the specifics
 # needed by Rakudo Perl 6.
@@ -393,6 +394,9 @@ class Perl6::SymbolTable is HLL::Compiler::SerializationContextBuilder {
         if %param_info<named_slurpy> {
             $flags := $flags + $SIG_ELEM_SLURPY_NAMED;
         }
+        if %param_info<is_method_named_slurpy> {
+            $flags := $flags + $SIG_ELEM_METHOD_SLURPY_NAMED;
+        }
         if %param_info<pos_lol> {
             $flags := $flags + $SIG_ELEM_SLURPY_LOL;
         }

src/binder/bind.c

@@ -7,6 +7,7 @@ Copyright (C) 2009-2011, The Perl Foundation.
 #include "parrot/parrot.h"
 #include "parrot/extend.h"
 #include "pmc_callcontext.h"
+#include "../pmc/pmc_perl6lexpad.h"
 #include "bind.h"
 #include "container.h"
 #include "types.h"
@@ -607,17 +608,25 @@ Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
 
         /* Could it be a named slurpy? */
         else if (param->flags & SIG_ELEM_SLURPY_NAMED) {
-            /* We'll either take the current named arguments copy hash which
-             * will by definition contain all unbound named parameters and use
-             * that, or just create an empty one. */
-            PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
-                    pmc_new(interp, enum_class_Hash) :
-                    named_args_copy;
-            bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
-                    Rakudo_binding_create_hash(interp, slurpy), no_nom_type_check, error);
-            if (bind_fail)
-                return bind_fail;
-
+            /* Can cheat a bit if it's the default method %_.
+             * We give the hash to the lexpad. */
+            if (param->flags & SIG_ELEM_METHOD_SLURPY_NAMED) {
+                SETATTR_Perl6LexPad_default_named_slurpy(interp, lexpad, named_args_copy);
+                PARROT_GC_WRITE_BARRIER(interp, lexpad);
+            }
+            else {
+                /* We'll either take the current named arguments copy hash which
+                 * will by definition contain all unbound named parameters and use
+                 * that, or just create an empty one. */
+                PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
+                        pmc_new(interp, enum_class_Hash) :
+                        named_args_copy;
+                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
+                        Rakudo_binding_create_hash(interp, slurpy), no_nom_type_check, error);
+                if (bind_fail)
+                    return bind_fail;
+            }
+
             /* Nullify named arguments hash now we've consumed it, to mark all
              * is well. */
             named_args_copy = PMCNULL;

src/binder/bind.h

@@ -1,25 +1,26 @@
 /* Flags that can be set on a signature element. */
-#define SIG_ELEM_BIND_CAPTURE       1
-#define SIG_ELEM_BIND_PRIVATE_ATTR  2
-#define SIG_ELEM_BIND_PUBLIC_ATTR   4
-#define SIG_ELEM_BIND_ATTRIBUTIVE   (SIG_ELEM_BIND_PRIVATE_ATTR | SIG_ELEM_BIND_PUBLIC_ATTR)
-#define SIG_ELEM_SLURPY_POS         8
-#define SIG_ELEM_SLURPY_NAMED       16
-#define SIG_ELEM_SLURPY_LOL         32
-#define SIG_ELEM_SLURPY             (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED | SIG_ELEM_SLURPY_LOL)
-#define SIG_ELEM_INVOCANT           64
-#define SIG_ELEM_MULTI_INVOCANT     128
-#define SIG_ELEM_IS_RW              256
-#define SIG_ELEM_IS_COPY            512
-#define SIG_ELEM_IS_PARCEL          1024
-#define SIG_ELEM_IS_OPTIONAL        2048
-#define SIG_ELEM_ARRAY_SIGIL        4096
-#define SIG_ELEM_HASH_SIGIL         8192
-#define SIG_ELEM_DEFAULT_FROM_OUTER 16384
-#define SIG_ELEM_IS_CAPTURE         32768
-#define SIG_ELEM_UNDEFINED_ONLY     65536
-#define SIG_ELEM_DEFINED_ONLY       131072
-#define SIG_ELEM_DEFINEDNES_CHECK   (SIG_ELEM_UNDEFINED_ONLY | SIG_ELEM_DEFINED_ONLY)
+#define SIG_ELEM_BIND_CAPTURE        1
+#define SIG_ELEM_BIND_PRIVATE_ATTR   2
+#define SIG_ELEM_BIND_PUBLIC_ATTR    4
+#define SIG_ELEM_BIND_ATTRIBUTIVE    (SIG_ELEM_BIND_PRIVATE_ATTR | SIG_ELEM_BIND_PUBLIC_ATTR)
+#define SIG_ELEM_SLURPY_POS          8
+#define SIG_ELEM_SLURPY_NAMED        16
+#define SIG_ELEM_SLURPY_LOL          32
+#define SIG_ELEM_SLURPY              (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED | SIG_ELEM_SLURPY_LOL)
+#define SIG_ELEM_INVOCANT            64
+#define SIG_ELEM_MULTI_INVOCANT      128
+#define SIG_ELEM_IS_RW               256
+#define SIG_ELEM_IS_COPY             512
+#define SIG_ELEM_IS_PARCEL           1024
+#define SIG_ELEM_IS_OPTIONAL         2048
+#define SIG_ELEM_ARRAY_SIGIL         4096
+#define SIG_ELEM_HASH_SIGIL          8192
+#define SIG_ELEM_DEFAULT_FROM_OUTER  16384
+#define SIG_ELEM_IS_CAPTURE          32768
+#define SIG_ELEM_UNDEFINED_ONLY      65536
+#define SIG_ELEM_DEFINED_ONLY        131072
+#define SIG_ELEM_DEFINEDNES_CHECK    (SIG_ELEM_UNDEFINED_ONLY | SIG_ELEM_DEFINED_ONLY)
+#define SIG_ELEM_METHOD_SLURPY_NAMED 262144
 
 /* This is how a parameter looks on the inside. Actually, this is a C struct
  * that should match the computed object layout by P6opaque for the type

src/pmc/perl6lexpad.pmc

@@ -8,6 +8,8 @@ static PMC *error_cd = NULL;
 static PMC *match_cd = NULL;
 static PMC *Scalar   = NULL;
 static PMC *Any      = NULL;
+static PMC *EnumMap  = NULL;
+static PMC *_Hash    = NULL;
 
 /* Creates a fresh scalar container with the specified descriptor. */
 static PMC * fresh_scalar(PARROT_INTERP, PMC *cont_desc) {
@@ -153,11 +155,13 @@ Return the LexInfo PMC, if any or a Null PMC.
     }
 
     VTABLE void mark() {
-        PMC *lexinfo, *ctx;
+        PMC *lexinfo, *ctx, *default_named_slurpy;
         GET_ATTR_lexinfo(INTERP, SELF, lexinfo);
         GET_ATTR_ctx(INTERP, SELF, ctx);
+        GET_ATTR_default_named_slurpy(INTERP, SELF, default_named_slurpy);
         Parrot_gc_mark_PMC_alive(INTERP, lexinfo);
         Parrot_gc_mark_PMC_alive(INTERP, ctx);
+        Parrot_gc_mark_PMC_alive(INTERP, default_named_slurpy);
     }
 
     VTABLE void set_pointer(void *ctx) {
@@ -246,6 +250,13 @@ Return the LexInfo PMC, if any or a Null PMC.
                 result = fresh_magicals ? fresh_scalar(interp, match_cd)
                                         : steal_outer(interp, ctx, name);
             }
+            else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "%_"))) {
+                PMC *storage;
+                GET_ATTR_default_named_slurpy(INTERP, SELF, storage);
+                result = REPR(_Hash)->instance_of(interp, _Hash);
+                if (!PMC_IS_NULL(storage))
+                    VTABLE_set_attr_keyed(interp, result, EnumMap, CONST_STRING(interp, "%_"), storage);
+            }
             VTABLE_set_pmc_keyed_str(interp, SELF, name, result);
         }
 
@@ -399,12 +410,14 @@ Get iterator for declared lexicals.
     }
 
     METHOD configure_magicals(PMC *_topic_cd, PMC *_error_cd, PMC *_match_cd,
-                              PMC *_Scalar, PMC *_Any) {
+                              PMC *_Scalar, PMC *_Any, PMC *_EnumMap, PMC *__Hash) {
         topic_cd = _topic_cd;
         error_cd = _error_cd;
         match_cd = _match_cd;
         Scalar   = _Scalar;
         Any      = _Any;
+        EnumMap  = _EnumMap;
+        _Hash    = __Hash;
     }
 
 }