X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8c29fccb2d2fd2d0d9fd6074018645febe1cb943..0a24517e59bfbc9209da93efe7938f8cc619b5af:/toke.c?ds=sidebyside

diff --git a/toke.c b/toke.c
index 257d69b..8ac0f31 100644
--- a/toke.c
+++ b/toke.c
@@ -182,17 +182,10 @@ static const char* const lex_state_names[] = {
 };
 #endif
 
-#ifdef ff_next
-#undef ff_next
-#endif
-
 #include "keywords.h"
 
 /* CLINE is a macro that ensures PL_copline has a sane value */
 
-#ifdef CLINE
-#undef CLINE
-#endif
 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 
 #ifdef PERL_MAD
@@ -218,6 +211,7 @@ static const char* const lex_state_names[] = {
  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
  * PREREF       : *EXPR where EXPR is not a simple identifier
  * TERM         : expression term
+ * POSTDEREF    : postfix dereference (->$* ->@[...] etc.)
  * LOOPX        : loop exiting command (goto, last, dump, etc)
  * FTST         : file test operator
  * FUN0         : zero-argument function
@@ -249,6 +243,7 @@ static const char* const lex_state_names[] = {
 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
+#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 #define FTST(f)  return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 #define FUN0(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
@@ -384,6 +379,7 @@ static struct debug_tokens {
     { PLUGEXPR,		TOKENTYPE_OPVAL,	"PLUGEXPR" },
     { PLUGSTMT,		TOKENTYPE_OPVAL,	"PLUGSTMT" },
     { PMFUNC,		TOKENTYPE_OPVAL,	"PMFUNC" },
+    { POSTJOIN,		TOKENTYPE_NONE,		"POSTJOIN" },
     { POSTDEC,		TOKENTYPE_NONE,		"POSTDEC" },
     { POSTINC,		TOKENTYPE_NONE,		"POSTINC" },
     { POWOP,		TOKENTYPE_OPNUM,	"POWOP" },
@@ -486,7 +482,9 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s)
 
     PERL_ARGS_ASSERT_PRINTBUF;
 
+    GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+    GCC_DIAG_RESTORE;
     SvREFCNT_dec(tmp);
 }
 
@@ -771,8 +769,11 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
 	parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
-    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
-				 |LEX_DONT_CLOSE_RSFP);
+
+    assert(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+                                                        |LEX_DONT_CLOSE_RSFP));
+    parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+                                                        |LEX_DONT_CLOSE_RSFP));
 
     parser->in_pod = parser->filtered = 0;
 }
@@ -2162,6 +2163,43 @@ S_force_next(pTHX_ I32 type)
 #endif
 }
 
+/*
+ * S_postderef
+ *
+ * This subroutine handles postfix deref syntax after the arrow has already
+ * been emitted.  @* $* etc. are emitted as two separate token right here.
+ * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
+ * only the first, leaving yylex to find the next.
+ */
+
+static int
+S_postderef(pTHX_ int const funny, char const next)
+{
+    dVAR;
+    assert(funny == DOLSHARP || strchr("$@%&*", funny));
+    assert(strchr("*[{", next));
+    if (next == '*') {
+	PL_expect = XOPERATOR;
+	if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
+	    assert('@' == funny || '$' == funny || DOLSHARP == funny);
+	    PL_lex_state = LEX_INTERPEND;
+	    start_force(PL_curforce);
+	    force_next(POSTJOIN);
+	}
+	start_force(PL_curforce);
+	force_next(next);
+	PL_bufptr+=2;
+    }
+    else {
+	if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
+	 && !PL_lex_brackets)
+	    PL_lex_dojoin = 2;
+	PL_expect = XOPERATOR;
+	PL_bufptr++;
+    }
+    return funny;
+}
+
 void
 Perl_yyunlex(pTHX)
 {
@@ -2477,18 +2515,17 @@ S_tokeq(pTHX_ SV *sv)
     char *s;
     char *send;
     char *d;
-    STRLEN len = 0;
     SV *pv = sv;
 
     PERL_ARGS_ASSERT_TOKEQ;
 
-    if (!SvLEN(sv))
+    assert (SvPOK(sv));
+    assert (SvLEN(sv));
+    assert (!SvIsCOW(sv));
+    if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
 	goto finish;
-
-    s = SvPV_force(sv, len);
-    if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
-	goto finish;
-    send = s + len;
+    s = SvPVX(sv);
+    send = SvEND(sv);
     /* This is relying on the SV being "well formed" with a trailing '\0'  */
     while (s < send && !(*s == '\\' && s[1] == '\\'))
 	s++;
@@ -2496,7 +2533,8 @@ S_tokeq(pTHX_ SV *sv)
 	goto finish;
     d = s;
     if ( PL_hints & HINT_NEW_STRING ) {
-	pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
+	pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
+			    SVs_TEMP | SvUTF8(sv));
     }
     while (s < send) {
 	if (*s == '\\') {
@@ -2552,7 +2590,7 @@ S_sublex_start(pTHX)
 	PL_lex_op = NULL;
 	return THING;
     }
-    if (op_type == OP_CONST || op_type == OP_READLINE) {
+    if (op_type == OP_CONST) {
 	SV *sv = tokeq(PL_lex_stuff);
 
 	if (SvTYPE(sv) == SVt_PVIV) {
@@ -2565,17 +2603,6 @@ S_sublex_start(pTHX)
 	}
 	pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 	PL_lex_stuff = NULL;
-	/* Allow <FH> // "foo" */
-	if (op_type == OP_READLINE)
-	    PL_expect = XTERMORDORDOR;
-	return THING;
-    }
-    else if (op_type == OP_BACKTICK && PL_lex_op) {
-	/* readpipe() was overridden */
-	cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
-	pl_yylval.opval = PL_lex_op;
-	PL_lex_op = NULL;
-	PL_lex_stuff = NULL;
 	return THING;
     }
 
@@ -2611,7 +2638,7 @@ S_sublex_push(pTHX)
     ENTER;
 
     PL_lex_state = PL_sublex_info.super_state;
-    SAVEBOOL(PL_lex_dojoin);
+    SAVEI8(PL_lex_dojoin);
     SAVEI32(PL_lex_brackets);
     SAVEI32(PL_lex_allbrackets);
     SAVEI32(PL_lex_formbrack);
@@ -2719,7 +2746,8 @@ S_sublex_done(pTHX)
 
     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
     assert(PL_lex_inwhat != OP_TRANSR);
-    if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
+    if (PL_lex_repl) {
+	assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
 	PL_linestr = PL_lex_repl;
 	PL_lex_inpat = 0;
 	PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
@@ -2830,11 +2858,12 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
      * validation. */
     table = GvHV(PL_hintgv);		 /* ^H */
     cvp = hv_fetchs(table, "charnames", FALSE);
-    if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
-        && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
+    if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
+        SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
     {
         const char * const name = HvNAME(stash);
-        if strEQ(name, "_charnames") {
+        if (HvNAMELEN(stash) == sizeof("_charnames")-1
+         && strEQ(name, "_charnames")) {
            return res;
        }
     }
@@ -3353,6 +3382,7 @@ S_scan_const(pTHX_ char *start)
 	    if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
 		isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
 	    {
+		/* diag_listed_as: \%d better written as $%d */
 		Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
 		*--s = '$';
 		break;
@@ -3540,7 +3570,7 @@ S_scan_const(pTHX_ char *start)
 		    if (! PL_lex_inpat) {
 			yyerror("Missing right brace on \\N{}");
 		    } else {
-			yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
+			yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
 		    }
 		    continue;
 		}
@@ -3914,6 +3944,7 @@ S_scan_const(pTHX_ char *start)
  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
  *
  * ->[ and ->{ return TRUE
+ * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
  * { and [ outside a pattern are always subscripts, so return TRUE
  * if we're outside a pattern and it's not { or [, then return FALSE
  * if we're in a pattern and the first char is a {
@@ -3939,6 +3970,11 @@ S_intuit_more(pTHX_ char *s)
 	return TRUE;
     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
 	return TRUE;
+    if (*s == '-' && s[1] == '>'
+     && FEATURE_POSTDEREF_QQ_IS_ENABLED
+     && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
+	||(s[2] == '@' && strchr("*[{",s[3])) ))
+	return TRUE;
     if (*s != '{' && *s != '[')
 	return FALSE;
     if (!PL_lex_inpat)
@@ -4430,32 +4466,6 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
     return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
 }
 
-/*
- * S_readpipe_override
- * Check whether readpipe() is overridden, and generates the appropriate
- * optree, provided sublex_start() is called afterwards.
- */
-STATIC void
-S_readpipe_override(pTHX)
-{
-    GV **gvp;
-    GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
-    pl_yylval.ival = OP_BACKTICK;
-    if ((gv_readpipe
-		&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
-	    ||
-	    ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
-	     && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
-	     && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
-    {
-	COPLINE_SET_FROM_MULTI_END;
-	PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
-	    op_append_elem(OP_LIST,
-		newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
-		newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
-    }
-}
-
 #ifdef PERL_MAD 
  /*
  * Perl_madlex
@@ -4671,7 +4681,7 @@ S_tokenize_use(pTHX_ int is_use, char *s) {
 #ifdef DEBUGGING
     static const char* const exp_name[] =
 	{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
-	  "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
+	  "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR"
 	};
 #endif
 
@@ -4744,9 +4754,6 @@ S_check_scalar_slice(pTHX_ char *s)
 */
 
 
-#ifdef __SC__
-#pragma segment Perl_yylex
-#endif
 int
 Perl_yylex(pTHX)
 {
@@ -4755,7 +4762,7 @@ Perl_yylex(pTHX)
     char *d;
     STRLEN len;
     bool bof = FALSE;
-    const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
+    const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
     U8 formbrack = 0;
     U32 fake_eof = 0;
 
@@ -4777,11 +4784,9 @@ Perl_yylex(pTHX)
     } );
 
     switch (PL_lex_state) {
-#ifdef COMMENTARY
-    case LEX_NORMAL:		/* Some compilers will produce faster */
-    case LEX_INTERPNORMAL:	/* code if we comment these out. */
+    case LEX_NORMAL:
+    case LEX_INTERPNORMAL:
 	break;
-#endif
 
     /* when we've already built the next token, just pull it out of the queue */
     case LEX_KNOWNEXT:
@@ -5039,6 +5044,7 @@ Perl_yylex(pTHX)
 
     case LEX_INTERPEND:
 	if (PL_lex_dojoin) {
+	    const U8 dojoin_was = PL_lex_dojoin;
 	    PL_lex_dojoin = FALSE;
 	    PL_lex_state = LEX_INTERPCONCAT;
 #ifdef PERL_MAD
@@ -5049,7 +5055,7 @@ Perl_yylex(pTHX)
 	    }
 #endif
 	    PL_lex_allbrackets--;
-	    return REPORT(')');
+	    return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
 	}
 	if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
 	    && SvEVALED(PL_lex_repl))
@@ -5673,7 +5679,6 @@ Perl_yylex(pTHX)
 		DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
 		OPERATOR('-');		/* unary minus */
 	    }
-	    PL_last_uni = PL_oldbufptr;
 	    switch (tmp) {
 	    case 'r': ftst = OP_FTEREAD;	break;
 	    case 'w': ftst = OP_FTEWRITE;	break;
@@ -5712,6 +5717,7 @@ Perl_yylex(pTHX)
 		break;
 	    }
 	    if (ftst) {
+                PL_last_uni = PL_oldbufptr;
 		PL_last_lop_op = (OPCODE)ftst;
 		DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Saw file test %c\n", (int)tmp);
@@ -5740,6 +5746,20 @@ Perl_yylex(pTHX)
 	    else if (*s == '>') {
 		s++;
 		s = SKIPSPACE1(s);
+		if (FEATURE_POSTDEREF_IS_ENABLED && (
+		    ((*s == '$' || *s == '&') && s[1] == '*')
+		  ||(*s == '$' && s[1] == '#' && s[2] == '*')
+		  ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
+		  ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
+		 ))
+		{
+		    Perl_ck_warner_d(aTHX_
+			packWARN(WARN_EXPERIMENTAL__POSTDEREF),
+			"Postfix dereference is experimental"
+		    );
+		    PL_expect = XPOSTDEREF;
+		    TOKEN(ARROW);
+		}
 		if (isIDFIRST_lazy_if(s,UTF)) {
 		    s = force_word(s,METHOD,FALSE,TRUE);
 		    TOKEN(ARROW);
@@ -5790,6 +5810,7 @@ Perl_yylex(pTHX)
 	}
 
     case '*':
+	if (PL_expect == XPOSTDEREF) POSTDEREF('*');
 	if (PL_expect != XOPERATOR) {
 	    s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
 	    PL_expect = XOPERATOR;
@@ -5826,6 +5847,7 @@ Perl_yylex(pTHX)
 	    PL_parser->saw_infix_sigil = 1;
 	    Mop(OP_MODULO);
 	}
+	else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
 	PL_tokenbuf[0] = '%';
 	s = scan_ident(s, PL_tokenbuf + 1,
 		sizeof PL_tokenbuf - 1, FALSE);
@@ -5836,13 +5858,6 @@ Perl_yylex(pTHX)
 	if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
 	    if (*s == '[')
 		PL_tokenbuf[0] = '@';
-
-	    /* Warn about % where they meant $. */
-	    if (*s == '[' || *s == '{') {
-		if (ckWARN(WARN_SYNTAX)) {
-		    S_check_scalar_slice(aTHX_ s);
-		}
-	    }
 	}
 	PL_expect = XOPERATOR;
 	force_ident_maybe_lex('%');
@@ -5935,7 +5950,7 @@ Perl_yylex(pTHX)
 		}
 		sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
 		if (*d == '(') {
-		    d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
+		    d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL);
 		    COPLINE_SET_FROM_MULTI_END;
 		    if (!d) {
 			/* MUST advance bufptr here to avoid bogus
@@ -6078,6 +6093,7 @@ Perl_yylex(pTHX)
 	    TOKEN(0);
 	s++;
 	if (PL_lex_brackets <= 0)
+	    /* diag_listed_as: Unmatched right %s bracket */
 	    yyerror("Unmatched right square bracket");
 	else
 	    --PL_lex_brackets;
@@ -6256,6 +6272,7 @@ Perl_yylex(pTHX)
       rightbracket:
 	s++;
 	if (PL_lex_brackets <= 0)
+	    /* diag_listed_as: Unmatched right %s bracket */
 	    yyerror("Unmatched right curly bracket");
 	else
 	    PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
@@ -6307,6 +6324,7 @@ Perl_yylex(pTHX)
 	}
 	TOKEN(';');
     case '&':
+	if (PL_expect == XPOSTDEREF) POSTDEREF('&');
 	s++;
 	if (*s++ == '&') {
 	    if (!PL_lex_allbrackets && PL_lex_fakeeof >=
@@ -6565,6 +6583,13 @@ Perl_yylex(pTHX)
 		return deprecate_commaless_var_list();
 	    }
 	}
+	else if (PL_expect == XPOSTDEREF) {
+	    if (s[1] == '#') {
+		s++;
+		POSTDEREF(DOLSHARP);
+	    }
+	    POSTDEREF('$');
+	}
 
 	if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
 	    PL_tokenbuf[0] = '@';
@@ -6698,6 +6723,7 @@ Perl_yylex(pTHX)
     case '@':
 	if (PL_expect == XOPERATOR)
 	    no_op("Array", s);
+	else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
 	PL_tokenbuf[0] = '@';
 	s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
 	pl_yylval.ival = 0;
@@ -6829,7 +6855,7 @@ Perl_yylex(pTHX)
 	TERM(THING);
 
     case '\'':
-	s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	COPLINE_SET_FROM_MULTI_END;
 	DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
 	if (PL_expect == XOPERATOR) {
@@ -6845,7 +6871,7 @@ Perl_yylex(pTHX)
 	TERM(sublex_start());
 
     case '"':
-	s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	DEBUG_T( {
 	    if (s)
 		printbuf("### Saw string before %s\n", s);
@@ -6876,18 +6902,19 @@ Perl_yylex(pTHX)
 	TERM(sublex_start());
 
     case '`':
-	s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
 	if (PL_expect == XOPERATOR)
 	    no_op("Backticks",s);
 	if (!s)
 	    missingterm(NULL);
-	readpipe_override();
+	pl_yylval.ival = OP_BACKTICK;
 	TERM(sublex_start());
 
     case '\\':
 	s++;
-	if (PL_lex_inwhat && isDIGIT(*s))
+	if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+	 && isDIGIT(*s))
 	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
 			   *s, *s);
 	if (PL_expect == XOPERATOR)
@@ -6984,8 +7011,10 @@ Perl_yylex(pTHX)
 	anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
 
 	/* x::* is just a word, unless x is "CORE" */
-	if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+	if (!anydelim && *s == ':' && s[1] == ':') {
+	    if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
 	    goto just_a_word;
+	}
 
 	d = s;
 	while (d < PL_bufend && isSPACE(*d))
@@ -7084,7 +7113,8 @@ Perl_yylex(pTHX)
 	    if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
 		CV *cv;
 		if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
-                                            UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
+					    (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
+					    SVt_PVCV)) &&
 		    (cv = GvCVu(gv)))
 		{
 		    if (GvIMPORTED_CV(gv))
@@ -7094,9 +7124,14 @@ Perl_yylex(pTHX)
 		}
 		if (!ogv &&
 		    (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
-                                            UTF ? -(I32)len : (I32)len, FALSE)) &&
-		    (gv = *gvp) && isGV_with_GP(gv) &&
-		    GvCVu(gv) && GvIMPORTED_CV(gv))
+					  len, FALSE)) &&
+		    (gv = *gvp) && (
+			isGV_with_GP(gv)
+			    ? GvCVu(gv) && GvIMPORTED_CV(gv)
+			    :   SvPCS_IMPORTED(gv)
+			     && (gv_init(gv, PL_globalstash, PL_tokenbuf,
+					 len, 0), 1)
+		   ))
 		{
 		    ogv = gv;
 		}
@@ -7119,7 +7154,7 @@ Perl_yylex(pTHX)
 		}
 		gv = NULL;
 		gvp = 0;
-		if (hgv && tmp != KEY_x && tmp != KEY_CORE)	/* never ambiguous */
+		if (hgv && tmp != KEY_x)	/* never ambiguous */
 		    Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
 				   "Ambiguous call resolved as CORE::%s(), "
 				   "qualify as such or use &",
@@ -7575,8 +7610,13 @@ Perl_yylex(pTHX)
 			    while (isLOWER(*d))
 				d++;
 			    if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
+                            {
+                                /* PL_warn_reserved is constant */
+                                GCC_DIAG_IGNORE(-Wformat-nonliteral);
 				Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
 				       PL_tokenbuf);
+                                GCC_DIAG_RESTORE;
+                            }
 			}
 		    }
 		}
@@ -7725,8 +7765,8 @@ Perl_yylex(pTHX)
 	    }
 	    goto just_a_word;
 
-	case KEY_CORE:
-	    if (*s == ':' && s[1] == ':') {
+	case_KEY_CORE:
+	    {
 		STRLEN olen = len;
 		d = s;
 		s += 2;
@@ -7750,7 +7790,6 @@ Perl_yylex(pTHX)
 		    orig_keyword = tmp;
 		goto reserved_word;
 	    }
-	    goto just_a_word;
 
 	case KEY_abs:
 	    UNI(OP_ABS);
@@ -7853,7 +7892,8 @@ Perl_yylex(pTHX)
 		*PL_tokenbuf = '&';
 		d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
 			      1, &len);
-		if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
+		if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
+		 && !keyword(PL_tokenbuf + 1, len, 0)) {
 		    d = SKIPSPACE1(d);
 		    if (*d == '(') {
 			force_ident_maybe_lex('&');
@@ -7981,8 +8021,9 @@ Perl_yylex(pTHX)
 		    strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
 		    p += 3;
 		p = PEEKSPACE(p);
+                /* skip optional package name, as in "for my abc $x (..)" */
 		if (isIDFIRST_lazy_if(p,UTF)) {
-		    p = scan_ident(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+		    p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
 		    p = PEEKSPACE(p);
 		}
 		if (*p != '$')
@@ -8119,7 +8160,7 @@ Perl_yylex(pTHX)
 
 	case KEY_glob:
 	    LOP(
-	     orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+	     orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
 	     XTERM
 	    );
 
@@ -8352,7 +8393,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_PIPE_OP,XTERM);
 
 	case KEY_q:
-	    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	    COPLINE_SET_FROM_MULTI_END;
 	    if (!s)
 		missingterm(NULL);
@@ -8364,7 +8405,7 @@ Perl_yylex(pTHX)
 
 	case KEY_qw: {
 	    OP *words = NULL;
-	    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	    COPLINE_SET_FROM_MULTI_END;
 	    if (!s)
 		missingterm(NULL);
@@ -8415,7 +8456,7 @@ Perl_yylex(pTHX)
 	}
 
 	case KEY_qq:
-	    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	    if (!s)
 		missingterm(NULL);
 	    pl_yylval.ival = OP_STRINGIFY;
@@ -8428,10 +8469,10 @@ Perl_yylex(pTHX)
 	    TERM(sublex_start());
 
 	case KEY_qx:
-	    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+	    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	    if (!s)
 		missingterm(NULL);
-	    readpipe_override();
+	    pl_yylval.ival = OP_BACKTICK;
 	    TERM(sublex_start());
 
 	case KEY_return:
@@ -8745,7 +8786,7 @@ Perl_yylex(pTHX)
 
 		/* Look for a prototype */
 		if (*s == '(') {
-		    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+		    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 		    COPLINE_SET_FROM_MULTI_END;
 		    if (!s)
 			Perl_croak(aTHX_ "Prototype not terminated");
@@ -8960,9 +9001,6 @@ Perl_yylex(pTHX)
 	}
     }}
 }
-#ifdef __SC__
-#pragma segment Main
-#endif
 
 /*
   S_pending_ident
@@ -9012,10 +9050,14 @@ S_pending_ident(pTHX)
             tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
         }
         else {
-            if (has_colon)
+            if (has_colon) {
+                /* PL_no_myglob is constant */
+                GCC_DIAG_IGNORE(-Wformat-nonliteral);
                 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
 			    PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
                             UTF ? SVf_UTF8 : 0);
+                GCC_DIAG_RESTORE;
+            }
 
             pl_yylval.opval = newOP(OP_PADANY, 0);
             pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
@@ -9207,7 +9249,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
 			    newSVpvs(":full"),
 			    newSVpvs(":short"),
 			    NULL);
-	    SPAGAIN;
+            assert(sp == PL_stack_sp);
 	    table = GvHV(PL_hintgv);
 	    if (table
 		&& (PL_hints & HINT_LOCALIZE_HH)
@@ -9377,7 +9419,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
     char *d = dest;
     char * const e = d + destlen - 3;    /* two-character token, ending NUL */
     bool is_utf8 = cBOOL(UTF);
-    I32 orig_copline, tmp_copline = 0;
+    I32 orig_copline = 0, tmp_copline = 0;
 
     PERL_ARGS_ASSERT_SCAN_IDENT;
 
@@ -9647,6 +9689,7 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse
 	    yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
 	}
 	else if (c == 'a') {
+  /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
 	    yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
 	}
 	else {
@@ -9674,7 +9717,7 @@ S_scan_pat(pTHX_ char *start, I32 type)
     PERL_ARGS_ASSERT_SCAN_PAT;
 
     s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
-                       TRUE /* look for escaped bracketed metas */ );
+                       TRUE /* look for escaped bracketed metas */, NULL);
 
     if (!s) {
 	const char * const delimiter = skipspace(start);
@@ -9762,19 +9805,19 @@ S_scan_subst(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_SUBST;
 
     pl_yylval.ival = OP_NULL;
 
     s = scan_str(start,!!PL_madskills,FALSE,FALSE,
-                 TRUE /* look for escaped bracketed metas */ );
+                 TRUE /* look for escaped bracketed metas */, &t);
 
     if (!s)
 	Perl_croak(aTHX_ "Substitution pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-	s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
 	CURMAD('q', PL_thisopen);
@@ -9787,7 +9830,7 @@ S_scan_subst(pTHX_ char *start)
 
     first_start = PL_multi_start;
     first_line = CopLINE(PL_curcop);
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
 	if (PL_lex_stuff) {
 	    SvREFCNT_dec(PL_lex_stuff);
@@ -9874,17 +9917,17 @@ S_scan_trans(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_TRANS;
 
     pl_yylval.ival = OP_NULL;
 
-    s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t);
     if (!s)
 	Perl_croak(aTHX_ "Transliteration pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-	s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
 	CURMAD('q', PL_thisopen);
@@ -9895,7 +9938,7 @@ S_scan_trans(pTHX_ char *start)
     }
 #endif
 
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
 	if (PL_lex_stuff) {
 	    SvREFCNT_dec(PL_lex_stuff);
@@ -10348,7 +10391,7 @@ S_scan_inputsymbol(pTHX_ char *start)
 
     if (d - PL_tokenbuf != len) {
 	pl_yylval.ival = OP_GLOB;
-	s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+	s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
 	if (!s)
 	   Perl_croak(aTHX_ "Glob not terminated");
 	return s;
@@ -10356,7 +10399,6 @@ S_scan_inputsymbol(pTHX_ char *start)
     else {
 	bool readline_overriden = FALSE;
 	GV *gv_readline;
-	GV **gvp;
     	/* we're in a filehandle read situation */
 	d = PL_tokenbuf;
 
@@ -10366,12 +10408,7 @@ S_scan_inputsymbol(pTHX_ char *start)
 
 	/* Check whether readline() is overriden */
 	gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
-	if ((gv_readline
-		&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
-		||
-		((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
-		 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
-		&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
+	if ((gv_readline = gv_override("readline",8)))
 	    readline_overriden = TRUE;
 
 	/* if <$fh>, create the ops to turn the variable into a
@@ -10454,6 +10491,11 @@ intro_sym:
 	deprecate_escaped_meta	issue a deprecation warning for cer-
 				tain paired metacharacters that appear
 				escaped within it
+	delimp			if non-null, this is set to the position of
+				the closing delimiter, or just after it if
+				the closing and opening delimiters differ
+				(i.e., the opening delimiter of a substitu-
+				tion replacement)
    returns: position to continue reading from buffer
    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
    	updates the read buffer.
@@ -10495,7 +10537,7 @@ intro_sym:
 
 STATIC char *
 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
-		 bool deprecate_escaped_meta
+		 bool deprecate_escaped_meta, char **delimp
     )
 {
     dVAR;
@@ -10922,6 +10964,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
 	PL_sublex_info.repl = sv;
     else
 	PL_lex_stuff = sv;
+    if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
     return s;
 }
 
@@ -11473,9 +11516,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
     return oldsavestack_ix;
 }
 
-#ifdef __SC__
-#pragma segment Perl_yylex
-#endif
 static int
 S_yywarn(pTHX_ const char *const s, U32 flags)
 {
@@ -11607,9 +11647,6 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
     PL_in_my_stash = NULL;
     return 0;
 }
-#ifdef __SC__
-#pragma segment Main
-#endif
 
 STATIC char*
 S_swallow_bom(pTHX_ U8 *s)