[perl #116735] Honour lexical prototypes when no parens are used

As Peter Martini noted in ticket #116735, lexical subs produce dif-
ferent op trees for ‘foo 1’ and ‘foo(1)’.  foo(1) produces an rv2cv
op with a padcv kid.  The unparenthetical version produces just
a padcv op.

And the difference in op trees caused lexical sub calls to honour
prototypes only in the presence of parentheses, because rv2cv_op_cv
(which searches for the cv in order to check its prototype) was
expecting rv2cv+padcv.

Not realising there was a discrepancy between the two forms, and
noticing that foo() produces *two* newCVREF ops, in commit 279d09bf893
I made newCVREF return just a padcv op for lexical subs.  At the time
I couldn’t figure out why there were two rv2cv ops, and punted on
researching it.

This is how it works for package subs:

When a sub call is compiled, if there are parentheses, an implicit '&'
is fed to the parser.  The token that follows is a WORD token with a
constant op attached to it, containing the name of the subroutine.
When the parser sees '&', it calls newCVREF on the const op to create
an rv2cv op.

For sub calls without parentheses, the token passed to the parser is
already an rv2cv op.

The resulting op tree is the same either way.

For lexical subs, I had the lexer emitting an rv2cv op in both paths,
which was why we got the double rv2cv when newCVREF was returning an
rv2cv for lexical subs.

The real solution is to call newCVREF in the lexer only when there
are no parentheses, since in that case the lexer is not going to call
newCVREF itself.  That avoids a redundant newCVREF call.  Hence, we
can have newCVREF always return an rv2cv op.

The result is that ‘foo(1)’ and ‘foo 1’ produce identical op trees for
a lexical sub.

One more thing needed to change:  The lexer was not looking at the
lexical prototype CV but simply the stub to be autovivified, so it
couldn’t see the parameter prototype attached to the CV (the stub
doesn’t have one).

The lexer needs to see the parameter prototype too, in order to deter-
mine precedence.

The logic for digging through pads to find the CV has been extracted
out of rv2cv_op_cv into a separate (non-API!) routine.

6 files changed, 34 insertions, 24 deletions

diff --git a/embed.fnc b/embed.fnc
index 61b7af87f5..0c9be6af67 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -427,6 +427,7 @@ p	|void	|dump_sub_perl	|NN const GV* gv|bool justperl
 Apd	|void	|fbm_compile	|NN SV* sv|U32 flags
 ApdR	|char*	|fbm_instr	|NN unsigned char* big|NN unsigned char* bigend \
 				|NN SV* littlestr|U32 flags
+p	|CV *	|find_lexical_cv|PADOFFSET off
 : Defined in util.c, used only in perl.c
 p	|char*	|find_script	|NN const char *scriptname|bool dosearch \
 				|NULLOK const char *const *const search_ext|I32 flags
diff --git a/embed.h b/embed.h
index 1f398d6cd3..d609bd53c9 100644
--- a/embed.h
+++ b/embed.h
@@ -1090,6 +1090,7 @@
 #define dump_packsubs_perl(a,b)	Perl_dump_packsubs_perl(aTHX_ a,b)
 #define dump_sub_perl(a,b)	Perl_dump_sub_perl(aTHX_ a,b)
 #define finalize_optree(a)	Perl_finalize_optree(aTHX_ a)
+#define find_lexical_cv(a)	Perl_find_lexical_cv(aTHX_ a)
 #define find_runcv_where(a,b,c)	Perl_find_runcv_where(aTHX_ a,b,c)
 #define find_rundefsv2(a,b)	Perl_find_rundefsv2(aTHX_ a,b)
 #define find_script(a,b,c,d)	Perl_find_script(aTHX_ a,b,c,d)
diff --git a/op.c b/op.c
index 95609f0853..7d33995692 100644
--- a/op.c
+++ b/op.c
@@ -8189,7 +8189,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o)
 	dVAR;
 	o->op_type = OP_PADCV;
 	o->op_ppaddr = PL_ppaddr[OP_PADCV];
-	return o;
     }
     return newUNOP(OP_RV2CV, flags, scalar(o));
 }
@@ -9910,6 +9909,28 @@ subroutine.
 =cut
 */
 
+/* shared by toke.c:yylex */
+CV *
+Perl_find_lexical_cv(pTHX_ PADOFFSET off)
+{
+    PADNAME *name = PAD_COMPNAME(off);
+    CV *compcv = PL_compcv;
+    while (PadnameOUTER(name)) {
+	assert(PARENT_PAD_INDEX(name));
+	compcv = CvOUTSIDE(PL_compcv);
+	name = PadlistNAMESARRAY(CvPADLIST(compcv))
+		[off = PARENT_PAD_INDEX(name)];
+    }
+    assert(!PadnameIsOUR(name));
+    if (!PadnameIsSTATE(name)) {
+	MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+	assert(mg);
+	assert(mg->mg_obj);
+	return (CV *)mg->mg_obj;
+    }
+    return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+}
+
 CV *
 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
 {
@@ -9944,24 +9965,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
 	    gv = NULL;
 	} break;
 	case OP_PADCV: {
-	    PADNAME *name = PAD_COMPNAME(rvop->op_targ);
-	    CV *compcv = PL_compcv;
-	    PADOFFSET off = rvop->op_targ;
-	    while (PadnameOUTER(name)) {
-		assert(PARENT_PAD_INDEX(name));
-		compcv = CvOUTSIDE(PL_compcv);
-		name = PadlistNAMESARRAY(CvPADLIST(compcv))
-			[off = PARENT_PAD_INDEX(name)];
-	    }
-	    assert(!PadnameIsOUR(name));
-	    if (!PadnameIsSTATE(name)) {
-		MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
-		assert(mg);
-		assert(mg->mg_obj);
-		cv = (CV *)mg->mg_obj;
-	    }
-	    else cv =
-		    (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+	    cv = find_lexical_cv(rvop->op_targ);
 	    gv = NULL;
 	} break;
 	default: {
diff --git a/proto.h b/proto.h
index 8eaf3fa44b..19a6970358 100644
--- a/proto.h
+++ b/proto.h
@@ -1087,6 +1087,7 @@ PERL_CALLCONV void	Perl_finalize_optree(pTHX_ OP* o)
 #define PERL_ARGS_ASSERT_FINALIZE_OPTREE	\
 	assert(o)
 
+PERL_CALLCONV CV *	Perl_find_lexical_cv(pTHX_ PADOFFSET off);
 PERL_CALLCONV CV*	Perl_find_runcv(pTHX_ U32 *db_seqp)
 			__attribute__warn_unused_result__;
 
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index b6960e03ed..0e101e865f 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
     *bar::like = *like;
 }
 no warnings 'deprecated';
-plan 132;
+plan 134;
 
 # -------------------- Errors with feature disabled -------------------- #
 
@@ -299,6 +299,7 @@ sub make_anon_with_state_sub{
     is ref $_[0], 'ARRAY', 'state sub with proto';
   }
   p(my @a);
+  p my @b;
   state sub q () { 45 }
   is q(), 45, 'state constant called with parens';
 }
@@ -598,6 +599,7 @@ not_lexical11();
     is ref $_[0], 'ARRAY', 'my sub with proto';
   }
   p(my @a);
+  p @a;
   my sub q () { 46 }
   is q(), 46, 'my constant called with parens';
 }
diff --git a/toke.c b/toke.c
index 954ec330b9..1fdaa7e9c1 100644
--- a/toke.c
+++ b/toke.c
@@ -6936,8 +6936,7 @@ Perl_yylex(pTHX)
 		else {
 		    rv2cv_op = newOP(OP_PADANY, 0);
 		    rv2cv_op->op_targ = off;
-		    rv2cv_op = (OP*)newCVREF(0, rv2cv_op);
-		    cv = (CV *)PAD_SV(off);
+		    cv = find_lexical_cv(off);
 		}
 		lex = TRUE;
 		goto just_a_word;
@@ -7266,7 +7265,8 @@ Perl_yylex(pTHX)
 		    }
 
 		    op_free(pl_yylval.opval);
-		    pl_yylval.opval = rv2cv_op;
+		    pl_yylval.opval =
+			off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
 		    pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
 		    PL_last_lop = PL_oldbufptr;
 		    PL_last_lop_op = OP_ENTERSUB;
@@ -7362,7 +7362,8 @@ Perl_yylex(pTHX)
 			gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
                                         SVt_PVCV);
 			op_free(pl_yylval.opval);
-			pl_yylval.opval = rv2cv_op;
+			pl_yylval.opval =
+			    off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
 			pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
 			PL_last_lop = PL_oldbufptr;
 			PL_last_lop_op = OP_ENTERSUB;