X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=232c4eeb2b41ab1502b06c9bbde23a62cc0e54a1;hb=5b3035ed4d02db655cf5d2d62ab1ebb11c131def;hp=6cb8e16889cc7208b5c52b1b159be20ce0d2418c;hpb=3f270f98f93055407790f4fc65bd60980f2723b2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 6cb8e16..232c4ee 100644 --- a/toke.c +++ b/toke.c @@ -121,7 +121,7 @@ int yyactlevel = 0; * Aop : addition-level operator * Mop : multiplication-level operator * Eop : equality-testing operator - * Rop : relational operator <= != gt + * Rop : relational operator <= != gt * * Also see LOP and lop() below. */ @@ -274,7 +274,6 @@ S_missingterm(pTHX_ char *s) void Perl_deprecate(pTHX_ char *s) { - dTHR; if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); } @@ -337,7 +336,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - dTHR; char *s; STRLEN len; @@ -433,7 +431,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -495,7 +492,6 @@ S_incline(pTHX_ char *s) STATIC char * S_skipspace(pTHX_ register char *s) { - dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; @@ -614,7 +610,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -680,7 +675,6 @@ S_uni(pTHX_ I32 f, char *s) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { - dTHR; yylval.ival = f; CLINE; PL_expect = x; @@ -782,7 +776,6 @@ S_force_ident(pTHX_ register char *s, int kind) PL_nextval[PL_nexttoke].opval = o; force_next(WORD); if (kind) { - dTHR; /* just for in_eval */ o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. @@ -995,7 +988,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1356,7 +1348,6 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; @@ -1381,7 +1372,6 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - dTHR; if (ckWARN(WARN_MISC) && isALNUM(*s)) Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", @@ -2073,7 +2063,6 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) int Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) { - dTHR; int r; yylval_pointer[yyactlevel] = lvalp; @@ -2101,7 +2090,6 @@ Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) Perl_yylex(pTHX) #endif { - dTHR; register char *s; register char *d; register I32 tmp; @@ -2115,6 +2103,9 @@ Perl_yylex(pTHX) char pit = PL_pending_ident; PL_pending_ident = 0; + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) + /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so just check for colons. @@ -2252,6 +2243,10 @@ Perl_yylex(pTHX) PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, + (IV)PL_nexttype[PL_nexttoke]); }) + return(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. @@ -2283,6 +2278,8 @@ Perl_yylex(pTHX) return yylex(); } else { + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Saw case modifier at '%s'\n", PL_bufptr); }) s = PL_bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ @@ -2333,6 +2330,8 @@ Perl_yylex(pTHX) case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) return sublex_done(); + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Interpolated variable at '%s'\n", PL_bufptr); }) PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2429,7 +2428,7 @@ Perl_yylex(pTHX) s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_p( { + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", exp_name[PL_expect], s); } ) @@ -2449,6 +2448,9 @@ Perl_yylex(pTHX) PL_last_lop = 0; if (PL_lex_brackets) yyerror("Missing right curly or square bracket"); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Tokener got EOF\n"); + } ) TOKEN(0); } if (s++ < PL_bufend) @@ -2704,7 +2706,7 @@ Perl_yylex(pTHX) else newargv = PL_origargv; newargv[0] = ipath; - PerlProc_execv(ipath, newargv); + PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); Perl_croak(aTHX_ "Can't exec %s", ipath); } #endif @@ -2788,6 +2790,8 @@ Perl_yylex(pTHX) goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { + I32 ftst = 0; + s++; PL_bufptr = s; tmp = *s++; @@ -2797,42 +2801,65 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw unary minus before =>, forcing word '%s'\n", s); + } ) OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; - PL_last_lop_op = OP_FTEREAD; /* good enough */ switch (tmp) { - case 'r': FTST(OP_FTEREAD); - case 'w': FTST(OP_FTEWRITE); - case 'x': FTST(OP_FTEEXEC); - case 'o': FTST(OP_FTEOWNED); - case 'R': FTST(OP_FTRREAD); - case 'W': FTST(OP_FTRWRITE); - case 'X': FTST(OP_FTREXEC); - case 'O': FTST(OP_FTROWNED); - case 'e': FTST(OP_FTIS); - case 'z': FTST(OP_FTZERO); - case 's': FTST(OP_FTSIZE); - case 'f': FTST(OP_FTFILE); - case 'd': FTST(OP_FTDIR); - case 'l': FTST(OP_FTLINK); - case 'p': FTST(OP_FTPIPE); - case 'S': FTST(OP_FTSOCK); - case 'u': FTST(OP_FTSUID); - case 'g': FTST(OP_FTSGID); - case 'k': FTST(OP_FTSVTX); - case 'b': FTST(OP_FTBLK); - case 'c': FTST(OP_FTCHR); - case 't': FTST(OP_FTTTY); - case 'T': FTST(OP_FTTEXT); - case 'B': FTST(OP_FTBINARY); - case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME); - case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME); - case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME); + case 'r': ftst = OP_FTEREAD; break; + case 'w': ftst = OP_FTEWRITE; break; + case 'x': ftst = OP_FTEEXEC; break; + case 'o': ftst = OP_FTEOWNED; break; + case 'R': ftst = OP_FTRREAD; break; + case 'W': ftst = OP_FTRWRITE; break; + case 'X': ftst = OP_FTREXEC; break; + case 'O': ftst = OP_FTROWNED; break; + case 'e': ftst = OP_FTIS; break; + case 'z': ftst = OP_FTZERO; break; + case 's': ftst = OP_FTSIZE; break; + case 'f': ftst = OP_FTFILE; break; + case 'd': ftst = OP_FTDIR; break; + case 'l': ftst = OP_FTLINK; break; + case 'p': ftst = OP_FTPIPE; break; + case 'S': ftst = OP_FTSOCK; break; + case 'u': ftst = OP_FTSUID; break; + case 'g': ftst = OP_FTSGID; break; + case 'k': ftst = OP_FTSVTX; break; + case 'b': ftst = OP_FTBLK; break; + case 'c': ftst = OP_FTCHR; break; + case 't': ftst = OP_FTTTY; break; + case 'T': ftst = OP_FTTEXT; break; + case 'B': ftst = OP_FTBINARY; break; + case 'M': case 'A': case 'C': + gv_fetchpv("\024",TRUE, SVt_PV); + switch (tmp) { + case 'M': ftst = OP_FTMTIME; break; + case 'A': ftst = OP_FTATIME; break; + case 'C': ftst = OP_FTCTIME; break; + default: break; + } + break; default: - Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp); break; } + if (ftst) { + PL_last_lop_op = ftst; + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", ftst); + } ) + if (*s == '(' && ckWARN(WARN_AMBIGUOUS)) + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Ambiguous -%c() resolved as a file test", + tmp); + FTST(ftst); + } + else { + /* Assume it was a minus followed by a one-letter named + * subroutine call (or a -bareword), then. */ + s -= 2; + } } tmp = *s++; if (*s == tmp) { @@ -3576,12 +3603,18 @@ Perl_yylex(pTHX) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &yylval); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw number in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3598,6 +3631,9 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3620,6 +3656,9 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -5708,7 +5747,6 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) { int level = 1; for (w = s+2; *w && level; w++) { @@ -5991,7 +6029,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d = '\0'; while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; Perl_warner(aTHX_ WARN_AMBIGUOUS, @@ -6023,7 +6060,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (funny == '#') funny = '@'; if (PL_lex_state == LEX_NORMAL) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { @@ -6222,7 +6258,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ register char *s) { - dTHR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; @@ -6574,7 +6609,6 @@ S_scan_inputsymbol(pTHX_ char *start) STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { - dTHR; SV *sv; /* scalar value: string */ char *tmps; /* temp string, used for delimiter matching */ register char *s = start; /* current position in the buffer */ @@ -6805,7 +6839,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ - dTHR; NV n = 0.0; UV u = 0; I32 shift; @@ -6893,7 +6926,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - dTHR; overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) @@ -6925,7 +6957,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) out: sv = NEWSV(92,0); if (overflowed) { - dTHR; if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6934,7 +6965,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } else { #if UVSIZE > 4 - dTHR; if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6964,7 +6994,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if -w is on */ if (*s == '_') { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; @@ -6980,7 +7009,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (lastub && s - lastub != 3) { - dTHR; if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -7132,7 +7160,7 @@ vstring: pos++; if (!isALPHA(*pos)) { UV rev; - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tmpend; bool utf8 = FALSE; s++; /* get past 'v' */ @@ -7197,7 +7225,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); @@ -7288,7 +7315,6 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dTHR; I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; AV* comppadlist; @@ -7344,7 +7370,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) int Perl_yywarn(pTHX_ char *s) { - dTHR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -7354,7 +7379,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1;