/* toke.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define PERL_IN_TOKE_C
#include "perl.h"
-#define yychar (*PL_yycharp)
-#define yylval (*PL_yylvalp)
+#define yylval (PL_parser->yylval)
+
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#define YYINITDEPTH 200
+
+/* XXX temporary backwards compatibility */
+#define PL_lex_brackets (PL_parser->lex_brackets)
+#define PL_lex_brackstack (PL_parser->lex_brackstack)
+#define PL_lex_casemods (PL_parser->lex_casemods)
+#define PL_lex_casestack (PL_parser->lex_casestack)
+#define PL_lex_defer (PL_parser->lex_defer)
+#define PL_lex_dojoin (PL_parser->lex_dojoin)
+#define PL_lex_expect (PL_parser->lex_expect)
+#define PL_lex_formbrack (PL_parser->lex_formbrack)
+#define PL_lex_inpat (PL_parser->lex_inpat)
+#define PL_lex_inwhat (PL_parser->lex_inwhat)
+#define PL_lex_op (PL_parser->lex_op)
+#define PL_lex_repl (PL_parser->lex_repl)
+#define PL_lex_starts (PL_parser->lex_starts)
+#define PL_lex_stuff (PL_parser->lex_stuff)
+#define PL_multi_start (PL_parser->multi_start)
+#define PL_multi_open (PL_parser->multi_open)
+#define PL_multi_close (PL_parser->multi_close)
+#define PL_pending_ident (PL_parser->pending_ident)
+#define PL_preambled (PL_parser->preambled)
+#define PL_sublex_info (PL_parser->sublex_info)
+
+#ifdef PERL_MAD
+# define PL_endwhite (PL_parser->endwhite)
+# define PL_faketokens (PL_parser->faketokens)
+# define PL_lasttoke (PL_parser->lasttoke)
+# define PL_nextwhite (PL_parser->nextwhite)
+# define PL_realtokenstart (PL_parser->realtokenstart)
+# define PL_skipwhite (PL_parser->skipwhite)
+# define PL_thisclose (PL_parser->thisclose)
+# define PL_thismad (PL_parser->thismad)
+# define PL_thisopen (PL_parser->thisopen)
+# define PL_thisstuff (PL_parser->thisstuff)
+# define PL_thistoken (PL_parser->thistoken)
+# define PL_thiswhite (PL_parser->thiswhite)
+#endif
+
+static int
+S_pending_ident(pTHX);
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
}
#endif
+
+
/*
* Perl_lex_start
* Initialize variables. Uses the Perl save_stack to save its state (for
Perl_lex_start(pTHX_ SV *line)
{
dVAR;
- const char *s;
+ const char *s = NULL;
STRLEN len;
+ yy_parser *parser;
+
+ /* create and initialise a parser */
+
+ Newxz(parser, 1, yy_parser);
+ parser->old_parser = PL_parser;
+ PL_parser = parser;
+
+ Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
+ parser->ps = parser->stack;
+ parser->stack_size = YYINITDEPTH;
+
+ parser->stack->state = 0;
+ parser->yyerrstatus = 0;
+ parser->yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* initialise lexer state */
- SAVEI32(PL_lex_dojoin);
- SAVEI32(PL_lex_brackets);
- SAVEI32(PL_lex_casemods);
- SAVEI32(PL_lex_starts);
SAVEI32(PL_lex_state);
- SAVEVPTR(PL_lex_inpat);
- SAVEI32(PL_lex_inwhat);
#ifdef PERL_MAD
if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = PL_lasttoke;
+ I32 toke = parser->old_parser->lasttoke;
while (--toke >= 0) {
SAVEI32(PL_nexttoke[toke].next_type);
SAVEVPTR(PL_nexttoke[toke].next_val);
if (PL_madskills)
SAVEVPTR(PL_nexttoke[toke].next_mad);
}
- SAVEI32(PL_lasttoke);
- }
- if (PL_madskills) {
- SAVESPTR(PL_thistoken);
- SAVESPTR(PL_thiswhite);
- SAVESPTR(PL_nextwhite);
- SAVESPTR(PL_thisopen);
- SAVESPTR(PL_thisclose);
- SAVESPTR(PL_thisstuff);
- SAVEVPTR(PL_thismad);
- SAVEI32(PL_realtokenstart);
- SAVEI32(PL_faketokens);
}
SAVEI32(PL_curforce);
#else
SAVEPPTR(PL_last_uni);
SAVEPPTR(PL_linestart);
SAVESPTR(PL_linestr);
- SAVEGENERICPV(PL_lex_brackstack);
- SAVEGENERICPV(PL_lex_casestack);
SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
- SAVESPTR(PL_lex_stuff);
- SAVEI32(PL_lex_defer);
- SAVEI32(PL_sublex_info.sub_inwhat);
- SAVESPTR(PL_lex_repl);
SAVEINT(PL_expect);
- SAVEINT(PL_lex_expect);
PL_lex_state = LEX_NORMAL;
- PL_lex_defer = 0;
PL_expect = XSTATE;
- PL_lex_brackets = 0;
- Newx(PL_lex_brackstack, 120, char);
- Newx(PL_lex_casestack, 12, char);
- PL_lex_casemods = 0;
- *PL_lex_casestack = '\0';
- PL_lex_dojoin = 0;
- PL_lex_starts = 0;
- PL_lex_stuff = NULL;
- PL_lex_repl = NULL;
- PL_lex_inpat = 0;
-#ifdef PERL_MAD
- PL_lasttoke = 0;
-#else
+ Newx(parser->lex_brackstack, 120, char);
+ Newx(parser->lex_casestack, 12, char);
+ *parser->lex_casestack = '\0';
+#ifndef PERL_MAD
PL_nexttoke = 0;
#endif
- PL_lex_inwhat = 0;
- PL_sublex_info.sub_inwhat = 0;
- PL_linestr = line;
- s = SvPV_const(PL_linestr, len);
- if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') {
- PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0));
- if (!len || s[len-1] != ';')
+
+ if (line) {
+ s = SvPV_const(line, len);
+ } else {
+ len = 0;
+ }
+ if (!len) {
+ PL_linestr = newSVpvs("\n;");
+ } else if (SvREADONLY(line) || s[len-1] != ';') {
+ PL_linestr = newSVsv(line);
+ if (s[len-1] != ';')
sv_catpvs(PL_linestr, "\n;");
+ } else {
+ SvTEMP_off(line);
+ SvREFCNT_inc_simple_void_NN(line);
+ PL_linestr = line;
}
- SvTEMP_off(PL_linestr);
+ /* PL_linestr needs to survive until end of scope, not just the next
+ FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */
+ SAVEFREESV(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 = NULL;
#endif
STATIC void
-S_update_debugger_info_pv(pTHX_ const char *buf, STRLEN len)
-{
- AV *av = CopFILEAVx(PL_curcop);
- if (av) {
- SV * const sv = newSV(0);
- sv_upgrade(sv, SVt_PVMG);
- sv_setpvn(sv, buf, len);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(av, (I32)CopLINE(PL_curcop), sv);
- }
-}
-
-STATIC void
-S_update_debugger_info_sv(pTHX_ SV *orig_sv)
+S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
{
AV *av = CopFILEAVx(PL_curcop);
if (av) {
SV * const sv = newSV(0);
sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv, orig_sv);
+ if (orig_sv)
+ sv_setsv(sv, orig_sv);
+ else
+ sv_setpvn(sv, buf, len);
(void)SvIOK_on(sv);
SvIV_set(sv, 0);
av_store(av, (I32)CopLINE(PL_curcop), sv);
* so store the line into the debugger's array of lines
*/
if (PERLDB_LINE && PL_curstash != PL_debstash)
- update_debugger_info_pv(PL_bufptr, PL_bufend - PL_bufptr);
+ update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
}
#ifdef PERL_MAD
* S_force_word
* When the lexer knows the next thing is a word (for instance, it has
* just seen -> and it knows that the next char is a word char, then
- * it calls S_force_word to stick the next word into the PL_next lookahead.
+ * it calls S_force_word to stick the next word into the PL_nexttoke/val
+ * lookahead.
*
* Arguments:
* char *start : buffer position (must be within PL_linestr)
- * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
+ * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
* int check_keyword : if true, Perl checks to make sure the word isn't
* a keyword (do this if the word is a label, e.g. goto FOO)
* int allow_pack : if true, : characters will also be allowed (require,
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (PERLDB_LINE && PL_curstash != PL_debstash)
- update_debugger_info_sv(PL_linestr);
+ update_debugger_info(PL_linestr, NULL, 0);
goto retry;
}
do {
if (PL_madskills)
sv_catsv(PL_thiswhite, PL_linestr);
#endif
- if (*s == '=' && strnEQ(s, "=cut", 4)) {
+ if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
sv_setpvn(PL_linestr, "", 0);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
if (PERLDB_LINE && PL_curstash != PL_debstash)
- update_debugger_info_sv(PL_linestr);
+ update_debugger_info(PL_linestr, NULL, 0);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (CopLINE(PL_curcop) == 1) {
t++;
} while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN dummylen;
+ STRLEN len;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &dummylen);
+ &len);
while (isSPACE(*t))
t++;
- if (*t == ';' && get_cv(tmpbuf, FALSE))
+ if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"",
tmpbuf);
if (!tmp && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- yylval.pval = savepv(PL_tokenbuf);
+ yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
TOKEN(LABEL);
}
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- (void*)name));
+ SVfARG(name)));
FREETMPS;
LEAVE;
}
if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Illegal character in prototype for %"SVf" : %s",
- (void*)PL_subname, d);
+ SVfARG(PL_subname), d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';')
- Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname);
+ Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
}
#ifdef PERL_MAD
}
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
+ (keyword(dest, d - dest, 0)
+ || get_cvn_flags(dest, d - dest, 0)))
{
if (funny == '#')
funny = '@';
}
no_more:
- Newx(tbl, complement&&!del?258:256, short);
+ tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
o = newPVOP(OP_TRANS, 0, (char*)tbl);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
PL_bufend[-1] = '\n';
#endif
if (PERLDB_LINE && PL_curstash != PL_debstash)
- update_debugger_info_sv(PL_linestr);
+ update_debugger_info(PL_linestr, NULL, 0);
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
/* update debugger info */
if (PERLDB_LINE && PL_curstash != PL_debstash)
- update_debugger_info_sv(PL_linestr);
+ update_debugger_info(PL_linestr, NULL, 0);
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
#ifdef PERL_MAD
if (PL_madskills) {
char * const tstart = SvPVX(PL_linestr) + stuffstart;
- const int len = s - start;
+ const int len = s - tstart;
if (PL_thisstuff)
sv_catpvn(PL_thisstuff, tstart, len);
else
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
else
qerror(msg);
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- (void*)ERRSV, OutCopFILE(PL_curcop));
+ SVfARG(ERRSV), OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
projects / p5sagit/p5-mst-13.2.git / blobdiff