This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Floating point too messy.
[perl5.git] / toke.c
diff --git a/toke.c b/toke.c
index f8d7145..4e90201 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -126,40 +126,42 @@ int yyactlevel = -1;
  * Also see LOP and lop() below.
  */
 
+/* Note that REPORT() and REPORT2() will be expressions that supply
+ * their own trailing comma, not suitable for statements as such. */
 #ifdef DEBUGGING /* Serve -DT. */
-#   define REPORT(x,retval) tokereport(x,s,(int)retval)
-#   define REPORT2(x,retval) tokereport(x,s, yylval.ival)
+#   define REPORT(x,retval) tokereport(x,s,(int)retval),
+#   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
 #else
-#   define REPORT(x,retval) 1
-#   define REPORT2(x,retval) 1
+#   define REPORT(x,retval)
+#   define REPORT2(x,retval)
 #endif
 
-#define TOKEN(retval) return (REPORT2("token",retval), PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (REPORT2("operator",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((REPORT2("aop",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (REPORT2("preblock",retval), PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval), PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (REPORT2("preref",retval), PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, REPORT2("term",retval), PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f), PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f, REPORT("ftst",f), PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f), PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f), PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f, REPORT("matchop",f), PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f, REPORT("add",f), PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f), PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f, REPORT("eq",f), PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f, REPORT("rel",f), PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
+#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
+#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
+#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
+#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
+#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
+#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
+#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
+#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
+#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
+#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
+#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
+#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
+#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 
 /* This bit of chicanery makes a unary function followed by
  * a parenthesis into a function with one argument, highest precedence.
  */
 #define UNI(f) return(yylval.ival = f, \
-       REPORT("uni",f), \
+       REPORT("uni",f) \
        PL_expect = XTERM, \
        PL_bufptr = s, \
        PL_last_uni = PL_oldbufptr, \
@@ -167,7 +169,7 @@ int yyactlevel = -1;
        (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 
 #define UNIBRACK(f) return(yylval.ival = f, \
-        REPORT("uni",f), \
+        REPORT("uni",f) \
        PL_bufptr = s, \
        PL_last_uni = PL_oldbufptr, \
        (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
@@ -387,6 +389,8 @@ Perl_lex_start(pTHX_ SV *line)
     SAVEPPTR(PL_bufend);
     SAVEPPTR(PL_oldbufptr);
     SAVEPPTR(PL_oldoldbufptr);
+    SAVEPPTR(PL_last_lop);
+    SAVEPPTR(PL_last_uni);
     SAVEPPTR(PL_linestart);
     SAVESPTR(PL_linestr);
     SAVEPPTR(PL_lex_brackstack);
@@ -429,6 +433,7 @@ Perl_lex_start(pTHX_ SV *line)
     SvTEMP_off(PL_linestr);
     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+    PL_last_lop = PL_last_uni = Nullch;
     SvREFCNT_dec(PL_rs);
     PL_rs = newSVpvn("\n", 1);
     PL_rsfp = 0;
@@ -574,6 +579,7 @@ S_skipspace(pTHX_ register char *s)
            PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
                = SvPVX(PL_linestr);
            PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+           PL_last_lop = PL_last_uni = Nullch;
 
            /* Close the filehandle.  Could be from -P preprocessor,
             * STDIN, or a regular file.  If we were reading code from
@@ -705,7 +711,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
 {
     yylval.ival = f;
     CLINE;
-    REPORT("lop", f);
+    REPORT("lop", f)
     PL_expect = x;
     PL_bufptr = s;
     PL_last_lop = PL_oldbufptr;
@@ -1031,6 +1037,8 @@ S_sublex_push(pTHX)
     SAVEPPTR(PL_bufptr);
     SAVEPPTR(PL_oldbufptr);
     SAVEPPTR(PL_oldoldbufptr);
+    SAVEPPTR(PL_last_lop);
+    SAVEPPTR(PL_last_uni);
     SAVEPPTR(PL_linestart);
     SAVESPTR(PL_linestr);
     SAVEPPTR(PL_lex_brackstack);
@@ -1042,6 +1050,7 @@ S_sublex_push(pTHX)
     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
        = SvPVX(PL_linestr);
     PL_bufend += SvCUR(PL_linestr);
+    PL_last_lop = PL_last_uni = Nullch;
     SAVEFREESV(PL_linestr);
 
     PL_lex_dojoin = FALSE;
@@ -1093,6 +1102,7 @@ S_sublex_done(pTHX)
        PL_lex_inpat = 0;
        PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
        PL_bufend += SvCUR(PL_linestr);
+       PL_last_lop = PL_last_uni = Nullch;
        SAVEFREESV(PL_linestr);
        PL_lex_dojoin = FALSE;
        PL_lex_brackets = 0;
@@ -1230,6 +1240,17 @@ S_scan_const(pTHX_ char *start)
                I32 min;                        /* first character in range */
                I32 max;                        /* last character in range */
 
+               if (utf) {
+                   char *c = (char*)utf8_hop((U8*)d, -1);
+                   char *e = d++;
+                   while (e-- > c)
+                       *(e + 1) = *e;
+                   *c = (char)0xff;
+                   /* mark the range as done, and continue */
+                   dorange = FALSE;
+                   didrange = TRUE;
+                   continue;
+               }
                i = d - SvPVX(sv);              /* remember current offset */
                SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
                d = SvPVX(sv) + i;              /* refresh d after realloc */
@@ -1456,7 +1477,7 @@ S_scan_const(pTHX_ char *start)
                            char *src, *dst;
                          
                            d = SvGROW(sv,
-                                      SvCUR(sv) + hicount + 1) +
+                                      SvLEN(sv) + hicount + 1) +
                                         (d - old_pvx);
 
                            src = d - 1;
@@ -1529,7 +1550,7 @@ S_scan_const(pTHX_ char *start)
                    if (len > e - s + 4) {
                        char *odest = SvPVX(sv);
 
-                       SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
+                       SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
                        d = SvPVX(sv) + (d - odest);
                    }
                    Copy(str, d, len, char);
@@ -2558,6 +2579,7 @@ Perl_yylex(pTHX)
            sv_catpv(PL_linestr, "\n");
            PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
            PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+           PL_last_lop = PL_last_uni = Nullch;
            if (PERLDB_LINE && PL_curstash != PL_debstash) {
                SV *sv = NEWSV(85,0);
 
@@ -2586,10 +2608,12 @@ Perl_yylex(pTHX)
                    sv_catpv(PL_linestr,";}");
                    PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+                   PL_last_lop = PL_last_uni = Nullch;
                    PL_minus_n = PL_minus_p = 0;
                    goto retry;
                }
                PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+               PL_last_lop = PL_last_uni = Nullch;
                sv_setpv(PL_linestr,"");
                TOKEN(';');     /* not infinite loop because rsfp is NULL now */
            }
@@ -2632,6 +2656,7 @@ Perl_yylex(pTHX)
                    sv_setpv(PL_linestr, "");
                    PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+                   PL_last_lop = PL_last_uni = Nullch;
                    PL_doextract = FALSE;
                }
            }
@@ -2646,6 +2671,7 @@ Perl_yylex(pTHX)
            av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
        }
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+       PL_last_lop = PL_last_uni = Nullch;
        if (CopLINE(PL_curcop) == 1) {
            while (s < PL_bufend && isSPACE(*s))
                s++;
@@ -2789,6 +2815,7 @@ Perl_yylex(pTHX)
                            sv_setpv(PL_linestr, "");
                            PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
                            PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+                           PL_last_lop = PL_last_uni = Nullch;
                            PL_preambled = FALSE;
                            if (PERLDB_LINE)
                                (void)gv_fetchfile(PL_origfilename);
@@ -3678,7 +3705,7 @@ Perl_yylex(pTHX)
     case '\'':
        s = scan_str(s,FALSE,FALSE);
         DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string in '%s'\n", s);
+                    "### Saw string before '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
@@ -3697,7 +3724,7 @@ Perl_yylex(pTHX)
     case '"':
        s = scan_str(s,FALSE,FALSE);
         DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string in '%s'\n", s);
+                    "### Saw string before '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
@@ -3722,7 +3749,7 @@ Perl_yylex(pTHX)
     case '`':
        s = scan_str(s,FALSE,FALSE);
         DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw backtick string in '%s'\n", s);
+                    "### Saw backtick string before '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
@@ -4744,11 +4771,7 @@ Perl_yylex(pTHX)
            TOKEN('(');
 
        case KEY_qq:
-       case KEY_qu:
            s = scan_str(s,FALSE,FALSE);
-           if (tmp == KEY_qu &&
-               is_utf8_string((U8*)SvPVX(PL_lex_stuff), SvCUR(PL_lex_stuff)))
-               SvUTF8_on(PL_lex_stuff);
            if (!s)
                missingterm((char*)0);
            yylval.ival = OP_STRINGIFY;
@@ -5581,7 +5604,6 @@ Perl_keyword(pTHX_ register char *d, I32 len)
            if (strEQ(d,"q"))                   return KEY_q;
            if (strEQ(d,"qr"))                  return KEY_qr;
            if (strEQ(d,"qq"))                  return KEY_qq;
-           if (strEQ(d,"qu"))                  return KEY_qu;
            if (strEQ(d,"qw"))                  return KEY_qw;
            if (strEQ(d,"qx"))                  return KEY_qx;
        }
@@ -6292,9 +6314,6 @@ S_scan_trans(pTHX_ char *start)
        Perl_croak(aTHX_ "Transliteration replacement not terminated");
     }
 
-    New(803,tbl,256,short);
-    o = newPVOP(OP_TRANS, 0, (char*)tbl);
-
     complement = del = squash = 0;
     while (strchr("cds", *s)) {
        if (*s == 'c')
@@ -6305,6 +6324,9 @@ S_scan_trans(pTHX_ char *start)
            squash = OPpTRANS_SQUASH;
        s++;
     }
+
+    New(803, tbl, complement&&!del?258:256, short);
+    o = newPVOP(OP_TRANS, 0, (char*)tbl);
     o->op_private = del|squash|complement|
       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
@@ -6449,6 +6471,7 @@ S_scan_heredoc(pTHX_ register char *s)
        sv_setsv(PL_linestr,herewas);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+       PL_last_lop = PL_last_uni = Nullch;
     }
     else
        sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
@@ -6460,6 +6483,7 @@ S_scan_heredoc(pTHX_ register char *s)
        }
        CopLINE_inc(PL_curcop);
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+       PL_last_lop = PL_last_uni = Nullch;
 #ifndef PERL_STRICT_CR
        if (PL_bufend - PL_linestart >= 2) {
            if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
@@ -6818,6 +6842,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
        /* having changed the buffer, we must update PL_bufend */
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+       PL_last_lop = PL_last_uni = Nullch;
     }
 
     /* at this point, we have successfully read the delimited string */
@@ -7334,6 +7359,7 @@ S_scan_formline(pTHX_ register char *s)
            s = filter_gets(PL_linestr, PL_rsfp, 0);
            PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
            PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+           PL_last_lop = PL_last_uni = Nullch;
            if (!s) {
                s = PL_bufptr;
                yyerror("Format not terminated");
Unnamed repository; edit this file 'description' to name the repository.