From: Simon Cozens Date: Sun, 8 Jul 2001 13:24:34 +0000 (+0100) Subject: Simplify yytoke() X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8eceec63d7a4c39284b15f8b23984d5483bf6573;p=p5sagit%2Fp5-mst-13.2.git Simplify yytoke() Message-ID: <20010708132434.A9448@deep-dark-truthful-mirror> Split out pending_ident(). p4raw-id: //depot/perl@11213 --- diff --git a/embed.h b/embed.h index 21bde98..ba67052 100644 --- a/embed.h +++ b/embed.h @@ -1125,6 +1125,7 @@ #define force_version S_force_version #define force_word S_force_word #define tokeq S_tokeq +#define pending_ident S_pending_ident #define scan_const S_scan_const #define scan_formline S_scan_formline #define scan_heredoc S_scan_heredoc @@ -1212,6 +1213,7 @@ #define ck_match Perl_ck_match #define ck_method Perl_ck_method #define ck_null Perl_ck_null +#define ck_octmode Perl_ck_octmode #define ck_open Perl_ck_open #define ck_repeat Perl_ck_repeat #define ck_require Perl_ck_require @@ -2624,6 +2626,7 @@ #define force_version(a) S_force_version(aTHX_ a) #define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e) #define tokeq(a) S_tokeq(aTHX_ a) +#define pending_ident() S_pending_ident(aTHX) #define scan_const(a) S_scan_const(aTHX_ a) #define scan_formline(a) S_scan_formline(aTHX_ a) #define scan_heredoc(a) S_scan_heredoc(aTHX_ a) @@ -2711,6 +2714,7 @@ #define ck_match(a) Perl_ck_match(aTHX_ a) #define ck_method(a) Perl_ck_method(aTHX_ a) #define ck_null(a) Perl_ck_null(aTHX_ a) +#define ck_octmode(a) Perl_ck_octmode(aTHX_ a) #define ck_open(a) Perl_ck_open(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) @@ -5109,6 +5113,8 @@ #define force_word S_force_word #define S_tokeq CPerlObj::S_tokeq #define tokeq S_tokeq +#define S_pending_ident CPerlObj::S_pending_ident +#define pending_ident S_pending_ident #define S_scan_const CPerlObj::S_scan_const #define scan_const S_scan_const #define S_scan_formline CPerlObj::S_scan_formline @@ -5264,6 +5270,8 @@ #define ck_method Perl_ck_method #define Perl_ck_null CPerlObj::Perl_ck_null #define ck_null Perl_ck_null +#define Perl_ck_octmode CPerlObj::Perl_ck_octmode +#define ck_octmode Perl_ck_octmode #define Perl_ck_open CPerlObj::Perl_ck_open #define ck_open Perl_ck_open #define Perl_ck_repeat CPerlObj::Perl_ck_repeat diff --git a/embed.pl b/embed.pl index e322ae2..c2f5351 100755 --- a/embed.pl +++ b/embed.pl @@ -2534,6 +2534,7 @@ s |char* |force_version |char *start s |char* |force_word |char *start|int token|int check_keyword \ |int allow_pack|int allow_tick s |SV* |tokeq |SV *sv +s |int |pending_ident s |char* |scan_const |char *start s |char* |scan_formline |char *s s |char* |scan_heredoc |char *s diff --git a/pod/perlapi.pod b/pod/perlapi.pod index bd794e2..bee65f6 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1344,17 +1344,6 @@ SV is B incremented. =for hackers Found in file sv.c -=item newSV - -Create a new null SV, or if len > 0, create a new empty SVt_PV type SV -with an initial PV allocation of len+1. Normally accessed via the C -macro. - - SV* newSV(STRLEN len) - -=for hackers -Found in file sv.c - =item NEWSV Creates a new SV. A non-zero C parameter indicates the number of @@ -1368,6 +1357,17 @@ C is an integer id between 0 and 1299 (used to identify leaks). =for hackers Found in file handy.h +=item newSV + +Create a new null SV, or if len > 0, create a new empty SVt_PV type SV +with an initial PV allocation of len+1. Normally accessed via the C +macro. + + SV* newSV(STRLEN len) + +=for hackers +Found in file sv.c + =item newSViv Creates a new SV and copies an integer into it. The reference count for the @@ -2234,22 +2234,22 @@ which guarantees to evaluate sv only once. =for hackers Found in file sv.h -=item SvNVX +=item SvNVx -Returns the raw value in the SV's NV slot, without checks or conversions. -Only use when you are sure SvNOK is true. See also C. +Coerces the given SV to a double and returns it. Guarantees to evaluate +sv only once. Use the more efficent C otherwise. - NV SvNVX(SV* sv) + NV SvNVx(SV* sv) =for hackers Found in file sv.h -=item SvNVx +=item SvNVX -Coerces the given SV to a double and returns it. Guarantees to evaluate -sv only once. Use the more efficent C otherwise. +Returns the raw value in the SV's NV slot, without checks or conversions. +Only use when you are sure SvNOK is true. See also C. - NV SvNVx(SV* sv) + NV SvNVX(SV* sv) =for hackers Found in file sv.h diff --git a/proto.h b/proto.h index 50d552a..5110345 100644 --- a/proto.h +++ b/proto.h @@ -1258,6 +1258,7 @@ STATIC void S_force_next(pTHX_ I32 type); STATIC char* S_force_version(pTHX_ char *start); STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick); STATIC SV* S_tokeq(pTHX_ SV *sv); +STATIC int S_pending_ident(pTHX); STATIC char* S_scan_const(pTHX_ char *start); STATIC char* S_scan_formline(pTHX_ char *s); STATIC char* S_scan_heredoc(pTHX_ char *s); diff --git a/toke.c b/toke.c index fa2b2bd..26b99d3 100644 --- a/toke.c +++ b/toke.c @@ -2166,132 +2166,8 @@ Perl_yylex(pTHX) bool bof = FALSE; /* check if there's an identifier for us to look at */ - if (PL_pending_ident) { - /* pit holds the identifier we read and pending_ident is reset */ - 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. - - if it's a legal name, the OP is a PADANY. - */ - if (PL_in_my) { - if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ "No package name allowed for " - "variable %s in \"our\"", - PL_tokenbuf)); - tmp = pad_allocmy(PL_tokenbuf); - } - else { - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); - - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); - return PRIVATEREF; - } - } - - /* - build the ops for accesses to a my() variable. - - Deny my($a) or my($b) in a sort block, *if* $a or $b is - then used in a comparison. This catches most, but not - all cases. For instance, it catches - sort { my($a); $a <=> $b } - but not - sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } - (although why you'd do that is anyone's guess). - */ - - if (!strchr(PL_tokenbuf,':')) { -#ifdef USE_THREADS - /* Check for single character per-thread SVs */ - if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0' - && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */ - && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD) - { - yylval.opval = newOP(OP_THREADSV, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; - } -#endif /* USE_THREADS */ - if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { - SV *namesv = AvARRAY(PL_comppad_name)[tmp]; - /* might be an "our" variable" */ - if (SvFLAGS(namesv) & SVpad_OUR) { - /* build ops for a bareword */ - SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0); - sv_catpvn(sym, "::", 2); - sv_catpv(sym, PL_tokenbuf+1); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); - yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(SvPVX(sym), - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : TRUE - ), - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); - return WORD; - } - - /* if it's a sort block and they're naming $a or $b */ - if (PL_last_lop_op == OP_SORT && - PL_tokenbuf[0] == '$' && - (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') - && !PL_tokenbuf[2]) - { - for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; - d < PL_bufend && *d != '\n'; - d++) - { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", - PL_tokenbuf); - } - } - } - - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; - } - } - - /* - Whine if they've said @foo in a doublequoted string, - and @foo isn't a variable we can find in the symbol - table. - */ - if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { - GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); - if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) - && ckWARN(WARN_AMBIGUOUS)) - { - /* Downgraded from fatal to warning 20000522 mjd */ - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Possible unintended interpolation of %s in string", - PL_tokenbuf); - } - } - - /* build ops for a bareword */ - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); - yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); - return WORD; - } + if (PL_pending_ident) + return pending_ident(aTHX); /* no identifier pending identification */ @@ -5236,6 +5112,136 @@ Perl_yylex(pTHX) #pragma segment Main #endif +int S_pending_ident(pTHX) +{ + register char *d; + register I32 tmp; + /* pit holds the identifier we read and pending_ident is reset */ + 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. + + if it's a legal name, the OP is a PADANY. + */ + if (PL_in_my) { + if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ + if (strchr(PL_tokenbuf,':')) + yyerror(Perl_form(aTHX_ "No package name allowed for " + "variable %s in \"our\"", + PL_tokenbuf)); + tmp = pad_allocmy(PL_tokenbuf); + } + else { + if (strchr(PL_tokenbuf,':')) + yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); + return PRIVATEREF; + } + } + + /* + build the ops for accesses to a my() variable. + + Deny my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ + + if (!strchr(PL_tokenbuf,':')) { +#ifdef USE_THREADS + /* Check for single character per-thread SVs */ + if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0' + && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */ + && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD) + { + yylval.opval = newOP(OP_THREADSV, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } +#endif /* USE_THREADS */ + if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { + SV *namesv = AvARRAY(PL_comppad_name)[tmp]; + /* might be an "our" variable" */ + if (SvFLAGS(namesv) & SVpad_OUR) { + /* build ops for a bareword */ + SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0); + sv_catpvn(sym, "::", 2); + sv_catpv(sym, PL_tokenbuf+1); + yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(SvPVX(sym), + (PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL) + : TRUE + ), + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; + } + + /* if it's a sort block and they're naming $a or $b */ + if (PL_last_lop_op == OP_SORT && + PL_tokenbuf[0] == '$' && + (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') + && !PL_tokenbuf[2]) + { + for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; + d < PL_bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", + PL_tokenbuf); + } + } + } + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } + } + + /* + Whine if they've said @foo in a doublequoted string, + and @foo isn't a variable we can find in the symbol + table. + */ + if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { + GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); + if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) + && ckWARN(WARN_AMBIGUOUS)) + { + /* Downgraded from fatal to warning 20000522 mjd */ + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Possible unintended interpolation of %s in string", + PL_tokenbuf); + } + } + + /* build ops for a bareword */ + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; +} + I32 Perl_keyword(pTHX_ register char *d, I32 len) {