Re: Announce : Tokener reporting patch

Message-ID: <20010122021722.A9334@pembro26.pmb.ox.ac.uk>

p4raw-id: //depot/perl@8562

diff --git a/embed.h b/embed.h
index 790f43b..f2a05c7 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1131,6 +1131,7 @@
 #define filter_gets            S_filter_gets
 #define find_in_my_stash       S_find_in_my_stash
 #define new_constant           S_new_constant
+#define tokereport             S_tokereport
 #define ao                     S_ao
 #define depcom                 S_depcom
 #define incl_perldb            S_incl_perldb
@@ -2600,6 +2601,7 @@
 #define filter_gets(a,b,c)     S_filter_gets(aTHX_ a,b,c)
 #define find_in_my_stash(a,b)  S_find_in_my_stash(aTHX_ a,b)
 #define new_constant(a,b,c,d,e,f)      S_new_constant(aTHX_ a,b,c,d,e,f)
+#define tokereport(a,b,c)      S_tokereport(aTHX_ a,b,c)
 #define ao(a)                  S_ao(aTHX_ a)
 #define depcom()               S_depcom(aTHX)
 #define incl_perldb()          S_incl_perldb(aTHX)
@@ -5058,6 +5060,8 @@
 #define find_in_my_stash       S_find_in_my_stash
 #define S_new_constant         CPerlObj::S_new_constant
 #define new_constant           S_new_constant
+#define S_tokereport           CPerlObj::S_tokereport
+#define tokereport             S_tokereport
 #define S_ao                   CPerlObj::S_ao
 #define ao                     S_ao
 #define S_depcom               CPerlObj::S_depcom

diff --git a/embed.pl b/embed.pl
index e5ca87a..e71337b 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2518,6 +2518,7 @@ s |char * |filter_gets    |SV *sv|PerlIO *fp|STRLEN append
 s      |HV *   |find_in_my_stash|char *pkgname|I32 len
 s      |SV*    |new_constant   |char *s|STRLEN len|const char *key|SV *sv \
                                |SV *pv|const char *type
+s      |void   |tokereport     |char *thing|char *s|I32 rv
 s      |int    |ao             |int toketype
 s      |void   |depcom
 s      |char*  |incl_perldb

diff --git a/proto.h b/proto.h
index 97e7ba7..a1f0fee 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1252,6 +1252,7 @@ STATIC I32        S_sublex_start(pTHX);
 STATIC char *  S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append);
 STATIC HV *    S_find_in_my_stash(pTHX_ char *pkgname, I32 len);
 STATIC SV*     S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type);
+STATIC void    S_tokereport(pTHX_ char *thing, char *s, I32 rv);
 STATIC int     S_ao(pTHX_ int toketype);
 STATIC void    S_depcom(pTHX);
 STATIC char*   S_incl_perldb(pTHX);

diff --git a/toke.c b/toke.c
index 398253c..d2dd026 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -126,31 +126,40 @@ int yyactlevel = -1;
  * Also see LOP and lop() below.
  */
 
-#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+#ifdef DEBUGGING /* Serve -DT. */
+#   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
+#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)
 
 /* 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), \
        PL_expect = XTERM, \
        PL_bufptr = s, \
        PL_last_uni = PL_oldbufptr, \
@@ -158,6 +167,7 @@ int yyactlevel = -1;
        (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 
 #define UNIBRACK(f) return(yylval.ival = f, \
+        REPORT("uni",f), \
        PL_bufptr = s, \
        PL_last_uni = PL_oldbufptr, \
        (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
@@ -165,6 +175,24 @@ int yyactlevel = -1;
 /* grandfather return to old style */
 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 
+void
+S_tokereport(char *thing, char* s, I32 rv)
+{ 
+    SV *report;
+    DEBUG_T({
+        report = newSVpv(thing, 0);
+        sv_catpvf(report, ":line %i:%i:", CopLINE(PL_curcop), rv);
+
+        if (s - PL_bufptr > 0)
+            sv_catpvn(report, PL_bufptr, s - PL_bufptr);
+        else {
+            if (PL_oldbufptr && *PL_oldbufptr)
+                sv_catpv(report, PL_tokenbuf);
+        }
+        PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
+    })
+}
+
 /*
  * S_ao
  *
@@ -677,6 +705,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
 {
     yylval.ival = f;
     CLINE;
+    REPORT("lop", f);
     PL_expect = x;
     PL_bufptr = s;
     PL_last_lop = PL_oldbufptr;