redo change#2061 and parts of change#1169 with code in the

parser; PL_last_proto hackery gone, strict 'subs' in now
implemented in the optimizer where specifying the exceptional
cases is much more robust; '*' (bareword) prototype now works
reliably when used in second and subsequent arguments

p4raw-link: @2061 on //depot/perl: bf8481137c02593eb36f8d0e234a2ec41a1c92e4
p4raw-link: @1169 on //depot/perl: 2a841d1398ee9bbf30a942905192cc2591b3e92a

p4raw-id: //depot/perl@3447

8 files changed, 47 insertions, 39 deletions

diff --git a/dump.c b/dump.c
index cb3a643b03..cc6682ac25 100644
--- a/dump.c
+++ b/dump.c
@@ -481,6 +481,8 @@ do_op_dump(I32 level, PerlIO *file, OP *o)
 	else if (o->op_type == OP_CONST) {
 	    if (o->op_private & OPpCONST_BARE)
 		sv_catpv(tmpsv, ",BARE");
+	    if (o->op_private & OPpCONST_STRICT)
+		sv_catpv(tmpsv, ",STRICT");
 	}
 	else if (o->op_type == OP_FLIP) {
 	    if (o->op_private & OPpFLIP_LINENUM)
diff --git a/embed.h b/embed.h
index 8c2474ad2d..e413efc90c 100644
--- a/embed.h
+++ b/embed.h
@@ -1452,6 +1452,7 @@
 #define nextargv		CPerlObj::Perl_nextargv
 #define nextchar		CPerlObj::Perl_nextchar
 #define ninstr			CPerlObj::Perl_ninstr
+#define no_bareword_allowed	CPerlObj::Perl_no_bareword_allowed
 #define no_fh_allowed		CPerlObj::Perl_no_fh_allowed
 #define no_op			CPerlObj::Perl_no_op
 #define not_a_number		CPerlObj::Perl_not_a_number
diff --git a/embed.pl b/embed.pl
index 2fde0dddfb..028e217771 100755
--- a/embed.pl
+++ b/embed.pl
@@ -313,6 +313,7 @@ my @staticfuncs = qw(
     bad_type
     modkids
     no_fh_allowed
+    no_bareword_allowed
     scalarboolean
     too_few_arguments
     too_many_arguments
diff --git a/objXSUB.h b/objXSUB.h
index f037d3a497..a74e8eeb3b 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1765,6 +1765,8 @@
 #define nextchar		pPerl->Perl_nextchar
 #undef  ninstr
 #define ninstr			pPerl->Perl_ninstr
+#undef  no_bareword_allowed
+#define no_bareword_allowed	pPerl->Perl_no_bareword_allowed
 #undef  no_fh_allowed
 #define no_fh_allowed		pPerl->Perl_no_fh_allowed
 #undef  no_op
diff --git a/op.c b/op.c
index 94c0b392d1..06977641ce 100644
--- a/op.c
+++ b/op.c
@@ -66,6 +66,7 @@ static I32 list_assignment _((OP *o));
 static void bad_type _((I32 n, char *t, char *name, OP *kid));
 static OP *modkids _((OP *o, I32 type));
 static OP *no_fh_allowed _((OP *o));
+static void no_bareword_allowed _((OP *o));
 static OP *scalarboolean _((OP *o));
 static OP *too_few_arguments _((OP *o, char* name));
 static OP *too_many_arguments _((OP *o, char* name));
@@ -116,6 +117,14 @@ bad_type(I32 n, char *t, char *name, OP *kid)
 		 (int)n, name, t, PL_op_desc[kid->op_type]));
 }
 
+STATIC void
+no_bareword_allowed(OP *o)
+{
+    warn("Bareword \"%s\" not allowed while \"strict subs\" in use",
+	  SvPV_nolen(cSVOPo->op_sv));
+    ++PL_error_count;
+}
+
 void
 assertref(OP *o)
 {
@@ -987,7 +996,9 @@ scalarvoid(OP *o)
 
     case OP_CONST:
 	sv = cSVOPo->op_sv;
-	{
+	if (cSVOPo->op_private & OPpCONST_STRICT)
+	    no_bareword_allowed(o);
+	else {
 	    dTHR;
 	    if (ckWARN(WARN_VOID)) {
 		useless = "a constant";
@@ -1841,6 +1852,10 @@ fold_constants(register OP *o)
 	goto nope;
 
     switch (type) {
+    case OP_NEGATE:
+	/* XXX might want a ck_negate() for this */
+	cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+	break;
     case OP_SPRINTF:
     case OP_UCFIRST:
     case OP_LCFIRST:
@@ -1861,10 +1876,11 @@ fold_constants(register OP *o)
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
 	if (curop->op_type != OP_CONST &&
-		curop->op_type != OP_LIST &&
-		curop->op_type != OP_SCALAR &&
-		curop->op_type != OP_NULL &&
-		curop->op_type != OP_PUSHMARK) {
+	    curop->op_type != OP_LIST &&
+	    curop->op_type != OP_SCALAR &&
+	    curop->op_type != OP_NULL &&
+	    curop->op_type != OP_PUSHMARK)
+	{
 	    goto nope;
 	}
     }
@@ -5356,6 +5372,10 @@ ck_subr(OP *o)
 	    }
 	}
     }
+    else if (cvop->op_type == OP_METHOD) {
+	if (o2->op_type == OP_CONST)
+	    o2->op_private &= ~OPpCONST_STRICT;
+    }
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
 	o->op_private |= OPpENTERSUB_DB;
@@ -5390,6 +5410,8 @@ ck_subr(OP *o)
 		arg++;
 		if (o2->op_type == OP_RV2GV)
 		    goto wrapref;	/* autoconvert GLOB -> GLOBref */
+		else if (o2->op_type == OP_CONST)
+		    o2->op_private &= ~OPpCONST_STRICT;
 		scalar(o2);
 		break;
 	    case '\\':
@@ -5502,8 +5524,11 @@ peep(register OP *o)
 	    o->op_seq = PL_op_seqmax++;
 	    break;
 
-	case OP_CONCAT:
 	case OP_CONST:
+	    if (cSVOPo->op_private & OPpCONST_STRICT)
+		no_bareword_allowed(o);
+	    /* FALL THROUGH */
+	case OP_CONCAT:
 	case OP_JOIN:
 	case OP_UC:
 	case OP_UCFIRST:
diff --git a/op.h b/op.h
index 67e636f79e..03ea2afca4 100644
--- a/op.h
+++ b/op.h
@@ -123,12 +123,14 @@ typedef U32 PADOFFSET;
 #define OPpDEREF_SV		(32|64)	/*   Want ref to SV. */
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB		16	/* Debug subroutine. */
+  /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER	8	/* Used & form to call. */
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER		16	/* Defer creation of array/hash elem */
   /* for OP_RV2?V, lower bits carry hints */
 
 /* Private for OP_CONST */
+#define	OPpCONST_STRICT		8	/* bearword subject to strict 'subs' */
 #define OPpCONST_ENTERED	16	/* Has been entered as symbol. */
 #define OPpCONST_ARYBASE	32	/* Was a $[ translated to constant. */
 #define OPpCONST_BARE		64	/* Was a bare word (filehandle?). */
diff --git a/proto.h b/proto.h
index ea364f1b62..6ec5b378d4 100644
--- a/proto.h
+++ b/proto.h
@@ -821,6 +821,7 @@ CV *get_db_sub _((SV **svp, CV *cv));
 I32 list_assignment _((OP *o));
 void bad_type _((I32 n, char *t, char *name, OP *kid));
 OP *modkids _((OP *o, I32 type));
+void no_bareword_allowed _((OP *o));
 OP *no_fh_allowed _((OP *o));
 OP *scalarboolean _((OP *o));
 OP *too_few_arguments _((OP *o, char* name));
diff --git a/toke.c b/toke.c
index 739c666b58..df45a56980 100644
--- a/toke.c
+++ b/toke.c
@@ -3186,13 +3186,9 @@ int yylex(PERL_YYLEX_PARAM_DECL)
 		s = skipspace(s);
 		if (*s == '(') {
 		    CLINE;
-		    PL_last_proto = Nullch;
 		    if (gv && GvCVu(gv)) {
-			CV *cv;
-			if ((cv = GvCV(gv)) && SvPOK(cv))
-			    PL_last_proto = SvPV((SV*)cv, n_a);
 			for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
-			if (*d == ')' && (sv = cv_const_sv(cv))) {
+			if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
 			    s = d + 1;
 			    goto its_constant;
 			}
@@ -3201,7 +3197,6 @@ int yylex(PERL_YYLEX_PARAM_DECL)
 		    PL_expect = XOPERATOR;
 		    force_next(WORD);
 		    yylval.ival = 0;
-		    PL_last_lop_op = OP_ENTERSUB;
 		    TOKEN('&');
 		}
 
@@ -3225,9 +3220,6 @@ int yylex(PERL_YYLEX_PARAM_DECL)
 		    if (lastchar == '-')
 			warn("Ambiguous use of -%s resolved as -&%s()",
 				PL_tokenbuf, PL_tokenbuf);
-		    PL_last_lop = PL_oldbufptr;
-		    PL_last_lop_op = OP_ENTERSUB;
-		    PL_last_proto = Nullch;
 		    /* Check for a constant sub */
 		    cv = GvCV(gv);
 		    if ((sv = cv_const_sv(cv))) {
@@ -3241,16 +3233,17 @@ int yylex(PERL_YYLEX_PARAM_DECL)
 		    /* Resolve to GV now. */
 		    op_free(yylval.opval);
 		    yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+		    PL_last_lop = PL_oldbufptr;
 		    PL_last_lop_op = OP_ENTERSUB;
 		    /* Is there a prototype? */
 		    if (SvPOK(cv)) {
 			STRLEN len;
-			PL_last_proto = SvPV((SV*)cv, len);
+			char *proto = SvPV((SV*)cv, len);
 			if (!len)
 			    TERM(FUNC0SUB);
-			if (strEQ(PL_last_proto, "$"))
+			if (strEQ(proto, "$"))
 			    OPERATOR(UNIOPSUB);
-			if (*PL_last_proto == '&' && *s == '{') {
+			if (*proto == '&' && *s == '{') {
 			    sv_setpv(PL_subname,"__ANON__");
 			    PREBLOCK(LSTOPSUB);
 			}
@@ -3261,27 +3254,8 @@ int yylex(PERL_YYLEX_PARAM_DECL)
 		    TOKEN(NOAMP);
 		}
 
-		/* It could be a prototypical bearword. */
-		if (PL_last_lop_op == OP_ENTERSUB && PL_last_proto &&
-		    PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')
-		{
-		    PL_last_proto = Nullch;
-		    TOKEN(WORD);
-		}
-
-		if (PL_hints & HINT_STRICT_SUBS &&
-		    lastchar != '-' &&
-		    strnNE(s,"->",2) &&
-		    PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
-		    PL_last_lop_op != OP_ACCEPT &&
-		    PL_last_lop_op != OP_PIPE_OP &&
-		    PL_last_lop_op != OP_SOCKPAIR)
-		{
-		    warn(
-		     "Bareword \"%s\" not allowed while \"strict subs\" in use",
-			PL_tokenbuf);
-		    ++PL_error_count;
-		}
+		if (PL_hints & HINT_STRICT_SUBS)
+		    yylval.opval->op_private |= OPpCONST_STRICT;
 
 		/* Call it a bare word */