X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=e8c1073d248641f2e350893d88aba3d6a79eb2f2;hb=dc9da78b70f004446f5a9327eea553687ad8c180;hp=aa200963eb36cc7dc9bd616b44fb40624e48980a;hpb=52327cafe6c445fb33a7b02ad4bf3a6d10bae0de;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index aa20096..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) {
@@ -1324,7 +1313,7 @@ S_scan_const(pTHX_ char *start)
 	   except for the last char, which will be done separately. */
 	else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
 	    if (s[2] == '#') {
-		while (s < send && *s != ')')
+		while (s+1 < send && *s != ')')
 		    *d++ = NATIVE_TO_NEED(has_utf8,*s++);
 	    }
 	    else if (s[2] == '{' /* This should match regcomp.c */
@@ -1343,10 +1332,8 @@ S_scan_const(pTHX_ char *start)
 			count--;
 		    regparse++;
 		}
-		if (*regparse != ')') {
+		if (*regparse != ')')
 		    regparse--;		/* Leave one char for continuation. */
-		    yyerror("Sequence (?{...}) not terminated or not {}-balanced");
-		}
 		while (s < regparse)
 		    *d++ = NATIVE_TO_NEED(has_utf8,*s++);
 	    }
@@ -2173,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
@@ -2429,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");
             } );
@@ -2877,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++;
@@ -3028,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);
@@ -3038,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
@@ -3405,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--;
@@ -5524,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;
@@ -6507,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);
 
@@ -7252,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" };
@@ -7268,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')
@@ -7342,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 */
 
@@ -7400,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;
@@ -7596,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;
 	}
@@ -7646,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;
 	    }
 	}
@@ -7675,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;
@@ -7771,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";
@@ -7808,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) {