working implementation of parameter defaults

2 files changed, 99 insertions, 5 deletions

diff --git a/Fun.xs b/Fun.xs
index a7b1d45..a9119b6 100644
--- a/Fun.xs
+++ b/Fun.xs
@@ -117,10 +117,44 @@ static SV *THX_parse_varname(pTHX_ const char *sigil)
 
 /* end stolen from Scope::Escape::Sugar */
 
+#define parse_parameter_default(i, padoffset) THX_parse_parameter_default(aTHX_ i, padoffset)
+static OP *THX_parse_parameter_default(pTHX_ IV i, PADOFFSET padoffset)
+{
+    SV *name;
+    OP *default_expr, *check_args, *get_var, *assign_default;
+    char sigil;
+
+    lex_read_space(0);
+
+    default_expr = parse_arithexpr(0);
+
+    check_args = newBINOP(OP_LE, 0, newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, gv_fetchpv("_", 0, SVt_PVAV))), newSVOP(OP_CONST, 0, newSViv(i)));
+
+    name = newSVsv(*av_fetch(PL_comppad_name, padoffset, 0));
+    sigil = SvPVX(name)[0];
+    if (sigil == '$') {
+        get_var = newOP(OP_PADSV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
+    }
+    else if (sigil == '@') {
+        get_var = newOP(OP_PADAV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
+    }
+    else if (sigil == '%') {
+        get_var = newOP(OP_PADHV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
+    }
+    else {
+        croak("weird pad entry %"SVf, name);
+    }
+    get_var->op_targ = padoffset;
+    assign_default = newASSIGNOP(OPf_STACKED, get_var, 0, default_expr);
+
+    return newLOGOP(OP_AND, 0, check_args, assign_default);
+}
+
 #define parse_function_prototype() THX_parse_function_prototype(aTHX)
 static OP *THX_parse_function_prototype(pTHX)
 {
-    OP *myvars, *get_args;
+    OP *myvars, *defaults, *get_args, *arg_assign;
+    IV i = 0;
 
     demand_unichar('(', DEMAND_IMMEDIATE);
 
@@ -133,24 +167,30 @@ static OP *THX_parse_function_prototype(pTHX)
     myvars = newLISTOP(OP_LIST, 0, NULL, NULL);
     myvars->op_private |= OPpLVAL_INTRO;
 
+    defaults = newLISTOP(OP_LINESEQ, 0, NULL, NULL);
+
     for (;;) {
         OP *pad_op;
         char next;
         I32 type;
+        SV *name;
 
         lex_read_space(0);
         next = lex_peek_unichar(0);
         if (next == '$') {
             pad_op = newOP(OP_PADSV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
-            pad_op->op_targ = pad_add_my_scalar_sv(parse_scalar_varname());
+            name = parse_scalar_varname();
+            pad_op->op_targ = pad_add_my_scalar_sv(name);
         }
         else if (next == '@') {
             pad_op = newOP(OP_PADAV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
-            pad_op->op_targ = pad_add_my_array_sv(parse_array_varname());
+            name = parse_array_varname();
+            pad_op->op_targ = pad_add_my_array_sv(name);
         }
         else if (next == '%') {
             pad_op = newOP(OP_PADHV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST);
-            pad_op->op_targ = pad_add_my_hash_sv(parse_hash_varname());
+            name = parse_hash_varname();
+            pad_op->op_targ = pad_add_my_hash_sv(name);
         }
         else {
             croak("syntax error");
@@ -160,6 +200,22 @@ static OP *THX_parse_function_prototype(pTHX)
 
         lex_read_space(0);
         next = lex_peek_unichar(0);
+
+        if (next == '=') {
+            OP *set_default;
+
+            lex_read_unichar(0);
+            set_default = parse_parameter_default(i, pad_op->op_targ);
+            op_append_elem(OP_LINESEQ,
+                           defaults,
+                           newSTATEOP(0, NULL, set_default));
+
+            lex_read_space(0);
+            next = lex_peek_unichar(0);
+        }
+
+        i++;
+
         if (next == ',') {
             lex_read_unichar(0);
         }
@@ -175,8 +231,11 @@ static OP *THX_parse_function_prototype(pTHX)
     myvars->op_flags |= OPf_PARENS;
 
     get_args = newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, gv_fetchpv("_", 0, SVt_PVAV)));
+    arg_assign = newASSIGNOP(OPf_STACKED, myvars, 0, get_args);
 
-    return newASSIGNOP(OPf_STACKED, myvars, 0, get_args);
+    return op_prepend_elem(OP_LINESEQ,
+                           newSTATEOP(0, NULL, arg_assign),
+                           defaults);
 }
 
 static OP *parse_fun(pTHX_ GV *namegv, SV *psobj, U32 *flagsp)
diff --git a/t/defaults.t b/t/defaults.t
new file mode 100644
index 0000000..0780f50
--- /dev/null
+++ b/t/defaults.t
@@ -0,0 +1,35 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Fun;
+
+fun foo ($x, $y = 5) {
+    return $x + $y;
+}
+
+is(foo(3, 4), 7);
+is(foo(3), 8);
+{
+    my $warning;
+    local $SIG{__WARN__} = sub { $warning = $_[0] };
+    is(foo, 5);
+    like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/);
+}
+
+fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) {
+    $blorg->($baz + $quux);
+}
+
+is(bar(3, 4, sub { $_[0] }), 7);
+is(bar(5, 6), "ran sub, got 11");
+is(bar(7), "ran sub, got 19");
+{
+    my $warning;
+    local $SIG{__WARN__} = sub { $warning = $_[0] };
+    is(bar, "ran sub, got 12");
+    like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/);
+}
+
+done_testing;