X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e994fd663a4d8acc8c717fa28479d849341d1bb4..96d521817563c2d56028871fbc15a1896b6fea30:/toke.c diff --git a/toke.c b/toke.c index aef667e..e8c1073 100644 --- a/toke.c +++ b/toke.c @@ -1,7 +1,7 @@ /* toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,8 +23,8 @@ #define PERL_IN_TOKE_C #include "perl.h" -#define yychar PL_yychar -#define yylval PL_yylval +#define yychar (*PL_yycharp) +#define yylval (*PL_yylvalp) static char ident_too_long[] = "Identifier too long"; static char c_without_g[] = "Use of /c modifier is meaningless without /g"; @@ -79,22 +79,6 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); #undef ff_next #endif -#ifdef USE_PURE_BISON -# ifndef YYMAXLEVEL -# define YYMAXLEVEL 100 -# endif -YYSTYPE* yylval_pointer[YYMAXLEVEL]; -int* yychar_pointer[YYMAXLEVEL]; -int yyactlevel = -1; -# undef yylval -# undef yychar -# define yylval (*yylval_pointer[yyactlevel]) -# define yychar (*yychar_pointer[yyactlevel]) -# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] -# undef yylex -# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) -#endif - #include "keywords.h" /* CLINE is a macro that ensures PL_copline has a sane value */ @@ -256,18 +240,23 @@ S_no_op(pTHX_ char *what, char *s) else PL_bufptr = s; yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); - if (is_first) - Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n"); - else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { - char *t; - for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; - if (t < PL_bufptr && isSPACE(*t)) - Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n", - t - PL_oldoldbufptr, PL_oldoldbufptr); - } - else { - assert(s >= oldbp); - Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + if (ckWARN_d(WARN_SYNTAX)) { + if (is_first) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing semicolon on previous line?)\n"); + else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { + char *t; + for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; + if (t < PL_bufptr && isSPACE(*t)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Do you need to predeclare %.*s?)\n", + t - PL_oldoldbufptr, PL_oldoldbufptr); + } + else { + assert(s >= oldbp); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + } } PL_bufptr = oldbp; } @@ -1231,7 +1220,7 @@ S_scan_const(pTHX_ char *start) const char *leaveit = /* set of acceptably-backslashed characters */ PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" + ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" : ""; if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { @@ -2171,26 +2160,6 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if we already built the token before, use it. */ -#ifdef USE_PURE_BISON -int -Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) -{ - int r; - - yyactlevel++; - yylval_pointer[yyactlevel] = lvalp; - yychar_pointer[yyactlevel] = lcharp; - if (yyactlevel >= YYMAXLEVEL) - Perl_croak(aTHX_ "panic: YYMAXLEVEL"); - - r = Perl_yylex(aTHX); - - if (yyactlevel > 0) - yyactlevel--; - - return r; -} -#endif #ifdef __SC__ #pragma segment Perl_yylex @@ -2427,8 +2396,12 @@ Perl_yylex(pTHX) if (!PL_rsfp) { PL_last_uni = 0; PL_last_lop = 0; - if (PL_lex_brackets) - yyerror("Missing right curly or square bracket"); + if (PL_lex_brackets) { + if (PL_lex_formbrack) + yyerror("Format not terminated"); + else + yyerror("Missing right curly or square bracket"); + } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); } ); @@ -2875,10 +2848,10 @@ Perl_yylex(pTHX) /* Assume it was a minus followed by a one-letter named * subroutine call (or a -bareword), then. */ DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### %c looked like a file test but was not\n", - (int)ftst); + "### '-%c' looked like a file test but was not\n", + tmp); } ); - s -= 2; + s = --PL_bufptr; } } tmp = *s++; @@ -3026,9 +2999,20 @@ Perl_yylex(pTHX) PL_lex_stuff = Nullsv; } else { + if (len == 6 && strnEQ(s, "unique", len)) { + if (PL_in_my == KEY_our) +#ifdef USE_ITHREADS + GvUNIQUE_on(cGVOPx_gv(yylval.opval)); +#else + ; /* skip to avoid loading attributes.pm */ +#endif + else + Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); + } + /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ - if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) CvLVALUE_on(PL_compcv); else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) CvLOCKED_on(PL_compcv); @@ -3036,11 +3020,6 @@ Perl_yylex(pTHX) CvMETHOD_on(PL_compcv); else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) CvASSERTION_on(PL_compcv); -#ifdef USE_ITHREADS - else if (PL_in_my == KEY_our && len == 6 && - strnEQ(s, "unique", len)) - GvUNIQUE_on(cGVOPx_gv(yylval.opval)); -#endif /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -3403,8 +3382,24 @@ Perl_yylex(pTHX) case '!': s++; tmp = *s++; - if (tmp == '=') + if (tmp == '=') { + /* was this !=~ where !~ was meant? + * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ + + if (*s == '~' && ckWARN(WARN_SYNTAX)) { + char *t = s+1; + + while (t < PL_bufend && isSPACE(*t)) + ++t; + + if (*t == '/' || *t == '?' || + ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || + (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "!=~ should be !~"); + } Eop(OP_NE); + } if (tmp == '~') PMop(OP_NOT); s--; @@ -5522,7 +5517,9 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; case 6: if (strEQ(d,"exists")) return KEY_exists; - if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif"); + if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "elseif should be elsif"); break; case 8: if (strEQ(d,"endgrent")) return -KEY_endgrent; @@ -6505,7 +6502,8 @@ S_scan_trans(pTHX_ char *start) New(803, tbl, complement&&!del?258:256, short); o = newPVOP(OP_TRANS, 0, (char*)tbl); - o->op_private = del|squash|complement| + o->op_private &= ~OPpTRANS_ALL; + o->op_private |= del|squash|complement| (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); @@ -7250,6 +7248,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) UV u = 0; I32 shift; bool overflowed = FALSE; + bool just_zero = TRUE; /* just plain 0 or binary number? */ static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; static char* bases[5] = { "", "binary", "", "octal", "hexadecimal" }; @@ -7266,9 +7265,11 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (s[1] == 'x') { shift = 4; s += 2; + just_zero = FALSE; } else if (s[1] == 'b') { shift = 1; s += 2; + just_zero = FALSE; } /* check for a decimal in disguise */ else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') @@ -7340,6 +7341,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) */ digit: + just_zero = FALSE; if (!overflowed) { x = u << shift; /* make room for the digit */ @@ -7398,7 +7400,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) #endif sv_setuv(sv, u); } - if (PL_hints & HINT_NEW_BINARY) + if (just_zero && (PL_hints & HINT_NEW_INTEGER)) + sv = new_constant(start, s - start, "integer", + sv, Nullsv, NULL); + else if (PL_hints & HINT_NEW_BINARY) sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); } break; @@ -7594,20 +7599,23 @@ S_scan_formline(pTHX_ register char *s) register char *t; SV *stuff = newSVpvn("",0); bool needargs = FALSE; + bool eofmt = FALSE; while (!needargs) { - if (*s == '.' || *s == /*{*/'}') { + if (*s == '.') { /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif - if (*t == '\n' || t == PL_bufend) + if (*t == '\n' || t == PL_bufend) { + eofmt = TRUE; break; + } } if (PL_in_eval && !PL_rsfp) { - eol = strchr(s,'\n'); + eol = memchr(s,'\n',PL_bufend-s); if (!eol++) eol = PL_bufend; } @@ -7644,7 +7652,6 @@ S_scan_formline(pTHX_ register char *s) PL_last_lop = PL_last_uni = Nullch; if (!s) { s = PL_bufptr; - yyerror("Format not terminated"); break; } } @@ -7673,7 +7680,8 @@ S_scan_formline(pTHX_ register char *s) } else { SvREFCNT_dec(stuff); - PL_lex_formbrack = 0; + if (eofmt) + PL_lex_formbrack = 0; PL_bufptr = s; } return s; @@ -7769,12 +7777,7 @@ Perl_yyerror(pTHX_ char *s) } else if (yychar > 255) where = "next token ???"; -#ifdef USE_PURE_BISON -/* GNU Bison sets the value -2 */ - else if (yychar == -2) { -#else - else if ((yychar & 127) == 127) { -#endif + else if (yychar == -2) { /* YYEMPTY */ if (PL_lex_state == LEX_NORMAL || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) where = "at end of line"; @@ -7806,8 +7809,8 @@ Perl_yyerror(pTHX_ char *s) (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); PL_multi_end = 0; } - if (PL_in_eval & EVAL_WARNONLY) - Perl_warn(aTHX_ "%"SVf, msg); + if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); else qerror(msg); if (PL_error_count >= 10) {