/* perly.c
*
- * Copyright (c) 2004 Larry Wall
+ * Copyright (c) 2004, 2005, 2006 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.
YYFPRINTF Args; \
} while (0)
-# define YYDSYMPRINT(Args) \
-do { \
- if (yydebug) \
- yysymprint Args; \
-} while (0)
-
# define YYDSYMPRINTF(Title, Token, Value) \
do { \
if (yydebug) { \
YYFPRINTF (Perl_debug_log, "%s ", Title); \
- yysymprint (aTHX_ Perl_debug_log, Token, Value); \
+ yysymprint (Perl_debug_log, Token, Value); \
YYFPRINTF (Perl_debug_log, "\n"); \
} \
} while (0)
`--------------------------------*/
static void
-yysymprint (pTHX_ PerlIO *yyoutput, int yytype, const YYSTYPE *yyvaluep)
+yysymprint(PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
{
if (yytype < YYNTOKENS) {
YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
for (i=0; i < count; i++)
PerlIO_printf(Perl_debug_log, " %8d", start+i);
PerlIO_printf(Perl_debug_log, "\nstate:");
- for (i=0, yyss += start; i < count; i++, yyss++)
- PerlIO_printf(Perl_debug_log, " %8d", *yyss);
+ for (i=0; i < count; i++)
+ PerlIO_printf(Perl_debug_log, " %8d", yyss[start+i]);
PerlIO_printf(Perl_debug_log, "\ntoken:");
- for (i=0, yyns += start; i < count; i++, yyns++)
- PerlIO_printf(Perl_debug_log, " %8.8s", *yyns);
+ for (i=0; i < count; i++)
+ PerlIO_printf(Perl_debug_log, " %8.8s", yyns[start+i]);
PerlIO_printf(Perl_debug_log, "\nvalue:");
- for (i=0, yyvs += start; i < count; i++, yyvs++)
- PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)yyvs->ival);
+ for (i=0; i < count; i++) {
+ if (yy_is_opval[yystos[yyss[start+i]]]) {
+ PerlIO_printf(Perl_debug_log, " %8.8s",
+ yyvs[start+i].opval
+ ? PL_op_name[yyvs[start+i].opval->op_type]
+ : "NULL"
+ );
+ }
+ else
+ PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)yyvs[start+i].ival);
+ }
PerlIO_printf(Perl_debug_log, "\n\n");
}
#else /* !DEBUGGING */
# define YYDPRINTF(Args)
-# define YYDSYMPRINT(Args)
# define YYDSYMPRINTF(Title, Token, Value)
# define YY_STACK_PRINT(yyss, yyssp, yyvs, yyns)
# define YY_REDUCE_PRINT(Rule)
#endif /* !YYERROR_VERBOSE */
+
+/* a snapshot of the current stack position variables for use by
+ * S_clear_yystack */
+
+typedef struct {
+ short *yyss;
+ short *yyssp;
+ YYSTYPE *yyvsp;
+ int yylen;
+} yystack_positions;
+
+/* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
+ * parse stack, thus avoiding leaks if we die */
+
+static void
+S_clear_yystack(pTHX_ const void *p)
+{
+ yystack_positions *y = (yystack_positions*) p;
+
+ if (!y->yyss)
+ return;
+ YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
+ y->yyvsp -= y->yylen; /* ignore the tokens that have just been reduced */
+ y->yyssp -= y->yylen;
+ while (y->yyssp > y->yyss) {
+ if (yy_is_opval[yystos[*y->yyssp]])
+ op_free(y->yyvsp->opval);
+ y->yyvsp--;
+ y->yyssp--;
+ }
+}
+
/*----------.
| yyparse. |
`----------*/
int
Perl_yyparse (pTHX)
{
+ dVAR;
int yychar; /* The lookahead symbol. */
YYSTYPE yylval; /* The semantic value of the lookahead symbol. */
int yynerrs; /* Number of syntax errors so far. */
int yytoken = 0;
/* two stacks and their tools:
- `yyss': related to states,
- `yyvs': related to semantic values,
+ yyss: related to states,
+ yyvs: related to semantic values,
Refer to the stacks thru separate pointers, to allow yyoverflow
to reallocate them elsewhere. */
/* for ease of re-allocation and automatic freeing, have two SVs whose
* SvPVX points to the stacks */
SV *yyss_sv, *yyvs_sv;
+ SV *ss_save_sv;
+ yystack_positions *ss_save;
#ifdef DEBUGGING
/* maintain also a stack of token/rule names for debugging with -Dpv */
rule. */
int yylen;
+#ifdef PERL_MAD
+ if (PL_madskills)
+ return madparse();
+#endif
+
YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
ENTER; /* force stack free before we return */
PL_yycharp = &yychar; /* so PL_yyerror() can access it */
PL_yylvalp = &yylval; /* so various functions in toke.c can access it */
- yyss_sv = NEWSV(73, YYINITDEPTH * sizeof(short));
- yyvs_sv = NEWSV(73, YYINITDEPTH * sizeof(YYSTYPE));
+ yyss_sv = newSV(YYINITDEPTH * sizeof(short));
+ yyvs_sv = newSV(YYINITDEPTH * sizeof(YYSTYPE));
+ ss_save_sv = newSV(sizeof(yystack_positions));
SAVEFREESV(yyss_sv);
SAVEFREESV(yyvs_sv);
+ SAVEFREESV(ss_save_sv);
yyss = (short *) SvPVX(yyss_sv);
yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
+ ss_save = (yystack_positions *) SvPVX(ss_save_sv);
+
+ ss_save->yyss = NULL; /* disarm stack cleanup */
+ /* cleanup the parse stack on premature exit */
+ SAVEDESTRUCTOR_X(S_clear_yystack, (void*) ss_save);
+
/* note that elements zero of yyvs and yyns are not used */
yyssp = yyss;
yyvsp = yyvs;
#ifdef DEBUGGING
- yyns_sv = NEWSV(73, YYINITDEPTH * sizeof(char *));
+ yyns_sv = newSV(YYINITDEPTH * sizeof(char *));
SAVEFREESV(yyns_sv);
+ /* XXX This seems strange to cast char * to char ** */
yyns = (const char **) SvPVX(yyns_sv);
yynsp = yyns;
#endif
yynerrs = 0;
yychar = YYEMPTY; /* Cause a token to be read. */
-
-
YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
goto yysetstate;
yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
#ifdef DEBUGGING
SvGROW(yyns_sv, yystacksize * sizeof(char *));
+ /* XXX This seems strange to cast char * to char ** */
yyns = (const char **) SvPVX(yyns_sv);
if (! yyns)
goto yyoverflowlab;
/* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
if (yychar == YYEMPTY) {
YYDPRINTF ((Perl_debug_log, "Reading a token: "));
+#ifdef PERL_MAD
+ yychar = PL_madskills ? madlex() : yylex();
+#else
yychar = yylex();
+#endif
# ifdef EBCDIC
if (yychar >= 0 && yychar < 255) {
yychar = NATIVE_TO_ASCII(yychar);
yylen = yyr2[yyn];
/* If YYLEN is nonzero, implement the default value of the action:
- `$$ = $1'.
+ "$$ = $1".
Otherwise, the following line sets YYVAL to garbage.
This behavior is undocumented and Bison
YY_REDUCE_PRINT (yyn);
+
+ /* running external code may trigger a die (eg 'use nosuchmodule'):
+ * record the current stack state so that an unwind will
+ * free all the pesky OPs lounging around on the parse stack */
+ ss_save->yyss = yyss;
+ ss_save->yyssp = yyssp;
+ ss_save->yyvsp = yyvsp;
+ ss_save->yylen = yylen;
+
switch (yyn) {
/* contains all the rule actions; auto-generated from perly.y */
*++yynsp = (const char *)(yytname [yyr1[yyn]]);
#endif
- /* Now `shift' the result of the reduction. Determine what state
+ /* Now shift the result of the reduction. Determine what state
that goes to, based on the state we popped back to and the rule
number reduced by. */
yysize += yystrlen (yytname[yyx]) + 15, yycount++;
yysize += yystrlen ("syntax error, unexpected ") + 1;
yysize += yystrlen (yytname[yytype]);
- New(yymsg, yysize, char *);
+ Newx(yymsg, yysize, char *);
if (yymsg != 0) {
const char *yyp = yystpcpy (yymsg, "syntax error, unexpected ");
yyp = yystpcpy (yyp, yytname[yytype]);
/* Pop the rest of the stack. */
while (yyss < yyssp) {
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+ if (yy_is_opval[yystos[*yyssp]]) {
+ YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ op_free(yyvsp->opval);
+ }
YYPOPSTACK;
}
YYABORT;
YYABORT;
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+ if (yy_is_opval[yystos[*yyssp]]) {
+ YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ op_free(yyvsp->opval);
+ }
yyvsp--;
#ifdef DEBUGGING
yynsp--;
yyreturn:
- LEAVE; /* force stack free before we return */
+ ss_save->yyss = NULL; /* disarm parse stack cleanup */
+ LEAVE; /* force stack free before we return */
return yyresult;
}
* indent-tabs-mode: t
* End:
*
- * vim: ts=8 sts=4 sw=4 noet:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff