Tokeniser debugging

Message-ID: <20001129141545.A30864@pembro33.pmb.ox.ac.uk>

p4raw-id: //depot/perl@7916

diff --git a/perl.c b/perl.c
index a422550..0ebd935 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2098,7 +2098,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef DEBUGGING
        forbid_setid("-D");
        if (isALPHA(s[1])) {
-           static char debopts[] = "psltocPmfrxuLHXDS";
+           static char debopts[] = "psltocPmfrxuLHXDST";
            char *d;
 
            for (s++; *s && (d = strchr(debopts,*s)); s++)

diff --git a/perl.h b/perl.h
index eff0336..07e3103 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2149,6 +2149,7 @@ Gid_t getegid (void);
 #  else
 #    define DEBUG_S(a)
 #  endif
+#define DEBUG_T(a) if (PL_debug & (1<<17))     a
 #else
 #define DEB(a)
 #define DEBUG(a)
@@ -2169,6 +2170,7 @@ Gid_t getegid (void);
 #define DEBUG_X(a)
 #define DEBUG_D(a)
 #define DEBUG_S(a)
+#define DEBUG_T(a)
 #endif
 #define YYMAXDEPTH 300
 

diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index d532912..4a4c957 100644 (file)
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -322,6 +322,7 @@ equivalent to B<-Dtls>):
     16384  X  Scratchpad allocation
     32768  D  Cleaning up
     65536  S  Thread synchronization
+   131072  T  Tokenising
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable.  See the F<INSTALL> file in the Perl source distribution 

diff --git a/toke.c b/toke.c
index 6cb8e16..1290c69 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2115,6 +2115,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 +2255,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 %i\n", PL_bufptr,
+              PL_nexttype[PL_nexttoke]); })
+
        return(PL_nexttype[PL_nexttoke]);
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -2283,6 +2290,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 +2342,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 +2440,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 +2460,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)
@@ -2797,10 +2811,16 @@ 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 */
+            DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                        "### Saw file test %c\n", (int)tmp);
+            } )
            switch (tmp) {
            case 'r': FTST(OP_FTEREAD);
            case 'w': FTST(OP_FTEWRITE);
@@ -3576,12 +3596,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 +3624,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 +3649,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)