Create new OP_MULTIPARAM to implement subroutine signatures

dump.c

@@ -1663,6 +1663,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
     case OP_ENTERWHEN:
     case OP_ENTERTRY:
     case OP_ONCE:
+    case OP_PARAMTEST:
         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
         S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
         break;
@@ -1780,6 +1781,35 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
         break;
     }
 
+    case OP_MULTIPARAM:
+    {
+        struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUXo->op_aux;
+        UV min_args = aux->min_args;
+        UV n_positional = aux->n_positional;
+        if(n_positional > min_args)
+            S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf " .. %" UVuf "\n",
+                    min_args, n_positional);
+        else
+            S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf "\n",
+                    min_args);
+
+        for(Size_t i = 0; i < n_positional; i++) {
+            PADOFFSET padix = aux->param_padix[i];
+            if(padix)
+                S_opdump_indent(aTHX_ o, level, bar, file, "  PARAM [%zd] PADIX = %" UVuf "%s\n",
+                        i, aux->param_padix[i], i >= min_args ? " OPT" : "");
+            else
+                S_opdump_indent(aTHX_ o, level, bar, file, "  PARAM [%zd] ANON\n",
+                        i);
+        }
+
+        if(aux->slurpy)
+            S_opdump_indent(aTHX_ o, level, bar, file, "SLURPY = '%c' PADIX = %" UVuf "\n",
+                    aux->slurpy, aux->slurpy_padix);
+
+        break;
+    }
+
     case OP_CUSTOM:
     {
         void (*custom_dumper)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx) =

ext/B/B.pm

@@ -20,7 +20,7 @@ sub import {
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.89';
+    $B::VERSION = '1.90';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.

ext/B/B.xs

@@ -1393,6 +1393,20 @@ aux_list(o, cv)
                 XSRETURN(len);
 
             } /* OP_MULTIDEREF */
+
+        case OP_MULTIPARAM:
+            {
+                struct op_multiparam_aux *p = (struct op_multiparam_aux *)aux;
+                UV nparams = p->n_positional;
+                EXTEND(SP, (IV)(3 + nparams + 1));
+                mPUSHu(p->min_args);
+                mPUSHu(p->n_positional);
+                PUSHs(sv_2mortal(p->slurpy ? newSVpvf("%c", p->slurpy) : &PL_sv_no));
+                for(UV parami = 0; parami < nparams; parami++)
+                    mPUSHu(p->param_padix[parami]);
+                mPUSHu(p->slurpy_padix);
+                XSRETURN(3 + nparams + 1);
+            }
         } /* switch */
 
 

ext/Opcode/Opcode.pm

@@ -1,4 +1,4 @@
-package Opcode 1.69;
+package Opcode 1.70;
 
 use strict;
 
@@ -309,6 +309,7 @@ invert_opset function.
 
     rv2hv helem hslice kvhslice each values keys exists delete
     aeach akeys avalues multideref argelem argdefelem argcheck
+    multiparam paramtest paramstore
 
     preinc i_preinc predec i_predec postinc i_postinc
     postdec i_postdec int hex oct abs pow multiply i_multiply

ext/XS-APItest/APItest.xs

@@ -1200,6 +1200,29 @@ static OP *THX_parse_keyword_subsignature(pTHX)
                     newSVpvf(kid->op_flags & OPf_KIDS ? "argelem:%s:d" : "argelem:%s", namepv)));
                 break;
             }
+            case OP_MULTIPARAM: {
+                struct op_multiparam_aux *p =
+                    (struct op_multiparam_aux *)(cUNOP_AUXx(kid)->op_aux);
+                PADNAMELIST *names = PadlistNAMES(CvPADLIST(find_runcv(0)));
+                SV *retsv = newSVpvf("multiparam:%" UVuf "..%" UVuf ":%c",
+                        p->min_args, p->n_positional, p->slurpy ? p->slurpy : '-');
+                for (UV paramidx = 0; paramidx < p->n_positional; paramidx++) {
+                    char *namepv = PadnamePV(padnamelist_fetch(names, p->param_padix[paramidx]));
+                    if(namepv)
+                        sv_catpvf(retsv, ":%s=%" UVf, namepv, paramidx);
+                    else
+                        sv_catpvf(retsv, ":(anon)=%" UVf, paramidx);
+                    if(paramidx >= p->min_args)
+                        sv_catpvs(retsv, "?");
+                }
+                if (p->slurpy_padix)
+                    sv_catpvf(retsv, ":%s=*",
+                        PadnamePV(padnamelist_fetch(names, p->slurpy_padix)));
+                retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0, retsv));
+                break;
+            }
+            case OP_PARAMTEST:
+                break;
             default:
                 fprintf(stderr, "TODO: examine kid %p (optype=%s)\n", kid, PL_op_name[kid->op_type]);
                 break;

ext/XS-APItest/t/subsignature.t

@@ -19,11 +19,11 @@ eval q{
 };
 is $@, "";
 is_deeply \@t, [
-	['nextstate:4', 'argcheck:2:0:-', 'argelem:$x', 'argelem:$y'],
-	['nextstate:5', 'argcheck:2:0:-', 'argelem:$z',],
-	['nextstate:6', 'argcheck:0:0:@', 'argelem:@rest'],
-	['nextstate:7', 'argcheck:0:0:%', 'argelem:%rest'],
-	['nextstate:8', 'argcheck:1:1:-', 'argelem:$one:d'],
+	['nextstate:4', 'multiparam:2..2:-:$x=0:$y=1' ],
+	['nextstate:5', 'multiparam:2..2:-:$z=0:(anon)=1',],
+	['nextstate:6', 'multiparam:0..0:@:@rest=*'],
+	['nextstate:7', 'multiparam:0..0:%:%rest=*'],
+	['nextstate:8', 'multiparam:0..1:-:$one=0?'],
 ];
 
 done_testing;

lib/B/Deparse.pm

@@ -26,6 +26,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
          OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
          OPpTRUEBOOL OPpINDEX_BOOLNEG OPpDEFER_FINALLY
          OPpARG_IF_UNDEF OPpARG_IF_FALSE
+         OPpPARAM_IF_UNDEF OPpPARAM_IF_FALSE
 	 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVf_FAKE SVs_RMG SVs_SMG
 	 SVs_PADTMP
          CVf_NOWARN_AMBIGUOUS CVf_LVALUE CVf_IsMETHOD
@@ -1180,6 +1181,94 @@ sub pad_subs {
 }
 
 
+# deparse_multiparam(): deparse, if possible, a sequence of ops into a
+# subroutine signature. If possible, returns a string representing the
+# signature syntax, minus the surrounding parentheses.
+
+sub deparse_multiparam {
+    my ($self, $topop, $cv) = @_;
+
+    $topop = $topop->first;
+    return unless $$topop and $topop->name eq 'lineseq';
+
+    # last op should be nextstate
+    my $last = $topop->last;
+    return unless $$last
+                    and (   _op_is_or_was($last, OP_NEXTSTATE)
+                         or _op_is_or_was($last, OP_DBSTATE));
+
+    # first OP_NEXTSTATE
+
+    my $o = $topop->first;
+    return unless $$o;
+    return if $o->label;
+
+    # OP_MULTIPARAM
+
+    $o = $o->sibling;
+    return unless $$o and $o->name eq 'multiparam';
+
+    my ($min_args, $max_args, $slurpy, @rest) = $o->aux_list($cv);
+    my $nparams = $max_args;
+    my @param_padix = splice @rest, 0, $nparams, ();
+    my ($slurpy_padix) = @rest;
+
+    my @sig;
+    my %parami_for_padix;
+
+    # Initial scalars
+    foreach my $parami ( 0 .. $max_args-1 ) {
+        my $padix = $param_padix[$parami];
+        $sig[$parami] = $self->padname($padix) || '$';
+        $parami_for_padix{$padix} = $parami;
+    }
+
+    $o = $o->sibling;
+    for (; $o and !null $o; $o = $o->sibling) {
+        # Look for OP_NULL[OP_PARAMTEST[OP_PARAMSTORE]]
+        if ($o->name eq 'null' and $o->flags & OPf_KIDS and
+                $o->first->name eq 'paramtest' and
+                $o->first->first->name eq 'paramstore') {
+            # A defaulting expression
+            my $paramtest = $o->first;
+
+            my $parami = $parami_for_padix{$paramtest->targ};
+
+            my $assign = "=";
+            $assign = "//=" if $paramtest->private == OPpPARAM_IF_UNDEF;
+            $assign = "||=" if $paramtest->private == OPpPARAM_IF_FALSE;
+
+            length $sig[$parami] > 1 ?
+                ( $sig[$parami] .= ' ' ) :
+                ( $sig[$parami] = '$' ); # intentionally no trailing space
+
+            my $defop = $paramtest->first->first;
+            if ($defop->name eq "stub") {
+                $sig[$parami] .= "$assign";
+            }
+            else {
+                my $def = $self->deparse($defop, 7);
+                $def = "($def)" if $defop->flags & OPf_PARENS;
+
+                $sig[$parami] .= "$assign $def";
+            }
+        }
+    }
+
+    if ($cv->CvFLAGS & CVf_IsMETHOD) {
+        # Remove the implied `$self` argument
+        warn "Expected first signature argument to be named \$self"
+            unless @sig and $sig[0] eq '$self';
+        shift @sig;
+    }
+
+    if ($slurpy) {
+        push @sig, $slurpy_padix ? $self->padname($slurpy_padix) : $slurpy;
+    }
+
+    return join(", ", @sig);
+}
+
 # deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
 # ops into a subroutine signature. If successful, return the first op
 # following the signature ops plus the signature string; else return the
@@ -1377,7 +1466,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
             and $firstop->name eq 'null'
             and $firstop->targ == OP_ARGCHECK
         ) {
-            my ($mysig) = $self->deparse_argops($firstop, $cv);
+            my ($mysig) = $self->deparse_multiparam($firstop, $cv) //
+                          $self->deparse_argops($firstop, $cv);
             if (defined $mysig) {
                 $sig = $mysig;
                 $firstop = $is_list ? $firstop->sibling : undef;