In perl.git, the branch smoke-me/nicholas/force-word has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ed02e01b4c3d6f2f74af4dc16ec124fd1df510a6?hp=707b805eb119df89ce8192e0415768c10dc19501>
- Log ----------------------------------------------------------------- commit ed02e01b4c3d6f2f74af4dc16ec124fd1df510a6 Author: Nicholas Clark <[email protected]> Date: Wed Feb 27 16:09:29 2013 +0100 Inline a subset of S_force_word() into the KEY_format section of Perl_yylex(). In code handling formats, Perl_yylex() calls S_force_word() at a point where it has already done half the work that S_force_word() does. The validation Perl_yylex() has already passed, along with the normalisation performed by S_scan_word() mean that all it actually needs from S_force_word() is the token forcing. Inlining these lines decouples the code. M toke.c commit 8bbf1e86266a8d8d3638afbfa97e5d82d80d73f7 Author: Brian Fraser <[email protected]> Date: Tue Feb 26 17:07:59 2013 -0300 toke.c: Remove the allow_initial_tick hack from S_force_word. Over the years, every caller which used this hack had it progressively turned off. Prior to this commit, only one call remained, which ostensibly handled this case: format 'STDOUT = ... However, turns out that even there it was superflous, since a scan_word a dozen lines before will've already turned all ticks into double colons. M embed.fnc M embed.h M proto.h M toke.c commit b85a8444f7b10de59fe64a60adfca39f81e727df Author: Brian Fraser <[email protected]> Date: Tue Feb 26 20:07:41 2013 -0300 Eliminate the last call to S_force_word() passing allow_initial_tick as TRUE. Turns out that that final place using the allow_tick hack could get a tick, because it was using the original buffer, rather than the already processed identifier from scan_word. M toke.c commit 21e3ba4faffc5c6202932c95c5e7446b804bea49 Author: Nicholas Clark <[email protected]> Date: Wed Feb 27 10:50:46 2013 +0100 Test that C<format ::Foo> is identical to C<format Foo> This wasn't being explicitly tested. M t/comp/parser.t commit 75b114233608230cfc692853e2f7f9c91ff5aed6 Author: Brian Fraser <[email protected]> Date: Tue Feb 26 20:07:41 2013 -0300 Test that C<format 'Foo> is identical to C<format Foo> When declaring a format, using a leading package separator requires careful handling in the parser, to avoid confusion with a subroutine of the same name. M t/comp/parser.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- embed.h | 2 +- proto.h | 2 +- t/comp/parser.t | 24 +++++++++++++++++++++++- toke.c | 46 +++++++++++++++++++++++++++------------------- 5 files changed, 53 insertions(+), 23 deletions(-) diff --git a/embed.fnc b/embed.fnc index c9832d4..1e8ad33 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2189,7 +2189,7 @@ s |void |force_next |I32 type s |char* |force_version |NN char *s|int guessing s |char* |force_strict_version |NN char *s s |char* |force_word |NN char *start|int token|int check_keyword \ - |int allow_pack|int allow_tick + |int allow_pack s |SV* |tokeq |NN SV *sv s |void |readpipe_override| sR |char* |scan_const |NN char *start diff --git a/embed.h b/embed.h index 9654979..8edd87a 100644 --- a/embed.h +++ b/embed.h @@ -1601,7 +1601,7 @@ #define force_next(a) S_force_next(aTHX_ a) #define force_strict_version(a) S_force_strict_version(aTHX_ a) #define force_version(a,b) S_force_version(aTHX_ a,b) -#define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e) +#define force_word(a,b,c,d) S_force_word(aTHX_ a,b,c,d) #define get_and_check_backslash_N_name(a,b) S_get_and_check_backslash_N_name(aTHX_ a,b) #define incline(a) S_incline(aTHX_ a) #define intuit_method(a,b,c) S_intuit_method(aTHX_ a,b,c) diff --git a/proto.h b/proto.h index 9192960..08fd678 100644 --- a/proto.h +++ b/proto.h @@ -7226,7 +7226,7 @@ STATIC char* S_force_version(pTHX_ char *s, int guessing) #define PERL_ARGS_ASSERT_FORCE_VERSION \ assert(s) -STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick) +STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORCE_WORD \ assert(start) diff --git a/t/comp/parser.t b/t/comp/parser.t index 7c0db7f..fa11de9 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -3,7 +3,7 @@ # Checks if the parser behaves correctly in edge cases # (including weird syntax errors) -print "1..154\n"; +print "1..156\n"; sub failed { my ($got, $expected, $name) = @_; @@ -450,6 +450,28 @@ for my $pkg(()){} $pkg = 3; is $pkg, 3, '[perl #114942] for my $foo()){} $foo'; +# Check that format 'Foo still works after removing the hack from +# force_word +$test++; +format 'one = +ok @<< - format 'foo still works +$test +. +{ + local $~ = "one"; + write(); +} + +$test++; +format ::two = +ok @<< - format ::foo still works +$test +. +{ + local $~ = "two"; + write(); +} + # Add new tests HERE (above this line) # bug #74022: Loop on characters in \p{OtherIDContinue} diff --git a/toke.c b/toke.c index aace60b..c324917 100644 --- a/toke.c +++ b/toke.c @@ -2110,7 +2110,7 @@ S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) */ STATIC char * -S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) +S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) { dVAR; char *s; @@ -2121,8 +2121,7 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, in start = SKIPSPACE1(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || - (allow_pack && *s == ':') || - (allow_initial_tick && *s == '\'') ) + (allow_pack && *s == ':') ) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); if (check_keyword && keyword(PL_tokenbuf, len, 0)) @@ -4531,12 +4530,12 @@ S_tokenize_use(pTHX_ int is_use, char *s) { force_next(WORD); } else if (*s == 'v') { - s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_word(s,WORD,FALSE,TRUE); s = force_version(s, FALSE); } } else { - s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_word(s,WORD,FALSE,TRUE); s = force_version(s, FALSE); } pl_yylval.ival = is_use; @@ -5525,7 +5524,7 @@ Perl_yylex(pTHX) s++; if (strnEQ(s,"=>",2)) { - s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); + s = force_word(PL_bufptr,WORD,FALSE,FALSE); DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } @@ -5597,7 +5596,7 @@ Perl_yylex(pTHX) s++; s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { - s = force_word(s,METHOD,FALSE,TRUE,FALSE); + s = force_word(s,METHOD,FALSE,TRUE); TOKEN(ARROW); } else if (*s == '$') @@ -5957,7 +5956,7 @@ Perl_yylex(pTHX) d++; if (*d == '}') { const char minus = (PL_tokenbuf[0] == '-'); - s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); + s = force_word(s + minus, WORD, FALSE, TRUE); if (minus) force_next('-'); } @@ -7711,7 +7710,7 @@ Perl_yylex(pTHX) case KEY_dump: PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE,FALSE); + s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_DUMP); case KEY_else: @@ -7844,7 +7843,7 @@ Perl_yylex(pTHX) case KEY_goto: PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE,FALSE); + s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_GOTO); case KEY_gmtime: @@ -7967,7 +7966,7 @@ Perl_yylex(pTHX) case KEY_last: PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE,FALSE); + s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_LAST); case KEY_lc: @@ -8075,7 +8074,7 @@ Perl_yylex(pTHX) case KEY_next: PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE,FALSE); + s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_NEXT); case KEY_ne: @@ -8165,7 +8164,7 @@ Perl_yylex(pTHX) LOP(OP_PACK,XTERM); case KEY_package: - s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_word(s,WORD,FALSE,TRUE); s = SKIPSPACE1(s); s = force_strict_version(s); PL_lex_expect = XBLOCK; @@ -8268,7 +8267,7 @@ Perl_yylex(pTHX) || (s = force_version(s, TRUE), *s == 'v')) { *PL_tokenbuf = '\0'; - s = force_word(s,WORD,TRUE,TRUE,FALSE); + s = force_word(s,WORD,TRUE,TRUE); if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD | (UTF ? SVf_UTF8 : 0)); @@ -8293,7 +8292,7 @@ Perl_yylex(pTHX) case KEY_redo: PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE,FALSE); + s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_REDO); case KEY_rename: @@ -8434,7 +8433,7 @@ Perl_yylex(pTHX) checkcomma(s,PL_tokenbuf,"subroutine name"); s = SKIPSPACE1(s); PL_expect = XTERM; - s = force_word(s,WORD,TRUE,TRUE,FALSE); + s = force_word(s,WORD,TRUE,TRUE); LOP(OP_SORT,XREF); case KEY_split: @@ -8470,6 +8469,7 @@ Perl_yylex(pTHX) expectation attrful; bool have_name, have_proto; const int key = tmp; + SV *format_name = NULL; #ifdef PERL_MAD SV *tmpwhite = 0; @@ -8504,6 +8504,8 @@ Perl_yylex(pTHX) if (PL_madskills) nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr)); #endif + if (key == KEY_format) + format_name = S_newSV_maybe_utf8(aTHX_ s, d - s); *PL_tokenbuf = '&'; if (memchr(tmpbuf, ':', len) || key != KEY_sub || pad_findmy_pvn( @@ -8550,9 +8552,15 @@ Perl_yylex(pTHX) PL_thistoken = subtoken; s = d; #else - if (have_name) - (void) force_word(PL_oldbufptr + tboffset, WORD, - FALSE, TRUE, TRUE); + if (format_name) { + start_force(PL_curforce); + if (PL_madskills) + curmad('X', newSVpvn(start,s-start)); + NEXTVAL_NEXTTOKE.opval + = (OP*)newSVOP(OP_CONST,0, format_name); + NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; + force_next(WORD); + } #endif PREBLOCK(FORMAT); } -- Perl5 Master Repository
