/* 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.
*
* Note that this file was originally generated as an output from
* GNU bison version 1.875, but now the code is statically maintained
- * and edited; the bits that are dependent on perly.y are now #included
- * from the files perly.tab and perly.act.
+ * and edited; the bits that are dependent on perly.y are now
+ * #included from the files perly.tab and perly.act.
*
* Here is an important copyright statement from the original, generated
* file:
* Bison output file, you may use that output file without
* restriction. This special exception was added by the Free
* Software Foundation in version 1.24 of Bison.
+ *
+ * Note that this file is also #included in madly.c, to allow compilation
+ * of a second parser, Perl_madparse, that is identical to Perl_yyparse,
+ * but which includes extra code for dumping the parse tree.
+ * This is controlled by the PERL_IN_MADLY_C define.
*/
+
/* allow stack size to grow effectively without limit */
#define YYMAXDEPTH 10000000
#define PERL_IN_PERLY_C
#include "perl.h"
+typedef unsigned char yytype_uint8;
+typedef signed char yytype_int8;
+typedef unsigned short int yytype_uint16;
+typedef short int yytype_int16;
typedef signed char yysigned_char;
#ifdef DEBUGGING
YYFPRINTF Args; \
} while (0)
-# define YYDSYMPRINT(Args) \
-do { \
- if (yydebug) \
- yysymprint Args; \
-} while (0)
-
# define YYDSYMPRINTF(Title, Token, Value) \
do { \
if (yydebug) { \
`--------------------------------*/
static void
-yysymprint (pTHX_ PerlIO *yyoutput, int yytype, const YYSTYPE *yyvaluep)
+yysymprint(pTHX_ 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++) {
+ switch (yy_type_tab[yystos[yyss[start+i]]]) {
+ case toketype_opval:
+ PerlIO_printf(Perl_debug_log, " %8.8s",
+ yyvs[start+i].opval
+ ? PL_op_name[yyvs[start+i].opval->op_type]
+ : "(NULL)"
+ );
+ break;
+#ifndef PERL_IN_MADLY_C
+ case toketype_p_tkval:
+ PerlIO_printf(Perl_debug_log, " %8.8s",
+ yyvs[start+i].pval ? yyvs[start+i].pval : "(NULL)");
+ break;
+
+ case toketype_i_tkval:
+#endif
+ case toketype_ival:
+ PerlIO_printf(Perl_debug_log, " %8"IVdf, yyvs[start+i].ival);
+ break;
+ default:
+ 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;
+ AV **yypsp;
+ 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;
+ y->yypsp -= y->yylen;
+ while (y->yyssp > y->yyss) {
+ if (yy_type_tab[yystos[*y->yyssp]] == toketype_opval) {
+ if (*y->yypsp != PL_comppad) {
+ PAD_RESTORE_LOCAL(*y->yypsp);
+ }
+ YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ op_free(y->yyvsp->opval);
+ }
+ y->yyvsp--;
+ y->yyssp--;
+ y->yypsp--;
+ }
+}
+
+
+
/*----------.
| yyparse. |
`----------*/
int
+#ifdef PERL_IN_MADLY_C
+Perl_madparse (pTHX)
+#else
Perl_yyparse (pTHX)
+#endif
{
+ dVAR;
int yychar; /* The lookahead symbol. */
YYSTYPE yylval; /* The semantic value of the lookahead symbol. */
int yynerrs; /* Number of syntax errors so far. */
/* Lookahead token as an internal (translated) token number. */
int yytoken = 0;
- /* two stacks and their tools:
+ /* three stacks and their tools:
yyss: related to states,
yyvs: related to semantic values,
+ yyps: current value of PL_comppad for each state
+
Refer to the stacks thru separate pointers, to allow yyoverflow
to reallocate them elsewhere. */
YYSTYPE *yyvs;
register YYSTYPE *yyvsp;
- /* for ease of re-allocation and automatic freeing, have two SVs whose
+ AV **yyps;
+ AV **yypsp;
+
+ /* for ease of re-allocation and automatic freeing, have three SVs whose
* SvPVX points to the stacks */
- SV *yyss_sv, *yyvs_sv;
+ SV *yyss_sv, *yyvs_sv, *yyps_sv;
+ SV *ss_save_sv;
+ yystack_positions *ss_save;
+
#ifdef DEBUGGING
/* maintain also a stack of token/rule names for debugging with -Dpv */
const char **yyns, **yynsp;
SV *yyns_sv;
-# define YYPOPSTACK (yyvsp--, yyssp--, yynsp--)
+# define YYPOPSTACK (yyvsp--, yyssp--, yypsp--, yynsp--)
#else
-# define YYPOPSTACK (yyvsp--, yyssp--)
+# define YYPOPSTACK (yyvsp--, yyssp--, yypsp--)
#endif
rule. */
int yylen;
+#ifndef PERL_IN_MADLY_C
+# ifdef PERL_MAD
+ if (PL_madskills)
+ return madparse();
+# endif
+#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));
+ yyps_sv = newSV(YYINITDEPTH * sizeof(AV*));
+ ss_save_sv = newSV(sizeof(yystack_positions));
SAVEFREESV(yyss_sv);
SAVEFREESV(yyvs_sv);
+ SAVEFREESV(yyps_sv);
+ SAVEFREESV(ss_save_sv);
yyss = (short *) SvPVX(yyss_sv);
yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
+ yyps = (AV **) SvPVX(yyps_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;
+ yypsp = yyps;
#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);
yynerrs = 0;
yychar = YYEMPTY; /* Cause a token to be read. */
-
-
YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
goto yysetstate;
SvGROW(yyss_sv, yystacksize * sizeof(short));
SvGROW(yyvs_sv, yystacksize * sizeof(YYSTYPE));
+ SvGROW(yyps_sv, yystacksize * sizeof(AV*));
yyss = (short *) SvPVX(yyss_sv);
yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
+ yyps = (AV **) SvPVX(yyps_sv);
#ifdef DEBUGGING
SvGROW(yyns_sv, yystacksize * sizeof(char *));
/* XXX This seems strange to cast char * to char ** */
goto yyoverflowlab;
yynsp = yyns + yysize - 1;
#endif
- if (!yyss || ! yyvs)
+ if (!yyss || ! yyvs || ! yyps)
goto yyoverflowlab;
yyssp = yyss + yysize - 1;
yyvsp = yyvs + yysize - 1;
+ yypsp = yyps + yysize - 1;
YYDPRINTF ((Perl_debug_log, "Stack size increased to %lu\n",
/* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
if (yychar == YYEMPTY) {
YYDPRINTF ((Perl_debug_log, "Reading a token: "));
+#ifdef PERL_IN_MADLY_C
+ yychar = PL_madskills ? madlex() : yylex();
+#else
yychar = yylex();
+#endif
+
# ifdef EBCDIC
if (yychar >= 0 && yychar < 255) {
yychar = NATIVE_TO_ASCII(yychar);
yychar = YYEMPTY;
*++yyvsp = yylval;
+ *++yypsp = PL_comppad;
#ifdef DEBUGGING
*++yynsp = (const char *)(yytname[yytoken]);
#endif
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->yypsp = yypsp;
+ ss_save->yylen = yylen;
+
switch (yyn) {
-/* contains all the rule actions; auto-generated from perly.y */
#define dep() deprecate("\"do\" to call subroutines")
+
+#ifdef PERL_IN_MADLY_C
+# define IVAL(i) (i)->tk_lval.ival
+# define PVAL(p) (p)->tk_lval.pval
+# define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
+# define TOKEN_FREE(a) token_free(a)
+# define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
+# define IF_MAD(a,b) (a)
+# define DO_MAD(a) a
+# define MAD
+#else
+# define IVAL(i) (i)
+# define PVAL(p) (p)
+# define TOKEN_GETMAD(a,b,c)
+# define TOKEN_FREE(a)
+# define OP_GETMAD(a,b,c)
+# define IF_MAD(a,b) (b)
+# define DO_MAD(a)
+# undef MAD
+#endif
+
+/* contains all the rule actions; auto-generated from perly.y */
#include "perly.act"
}
yyvsp -= yylen;
yyssp -= yylen;
+ yypsp -= yylen;
#ifdef DEBUGGING
yynsp -= yylen;
#endif
*++yyvsp = yyval;
+ *++yypsp = PL_comppad;
+
#ifdef DEBUGGING
*++yynsp = (const char *)(yytname [yyr1[yyn]]);
#endif
/* Pop the rest of the stack. */
while (yyss < yyssp) {
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+ if (yy_type_tab[yystos[*yyssp]] == toketype_opval) {
+ YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ if (*yypsp != PL_comppad) {
+ PAD_RESTORE_LOCAL(*yypsp);
+ }
+ op_free(yyvsp->opval);
+ }
YYPOPSTACK;
}
YYABORT;
YYABORT;
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+ if (yy_type_tab[yystos[*yyssp]] == toketype_opval) {
+ YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ if (*yypsp != PL_comppad) {
+ PAD_RESTORE_LOCAL(*yypsp);
+ }
+ op_free(yyvsp->opval);
+ }
yyvsp--;
+ yypsp--;
#ifdef DEBUGGING
yynsp--;
#endif
YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
*++yyvsp = yylval;
+ *++yypsp = PL_comppad;
#ifdef DEBUGGING
*++yynsp ="<err>";
#endif
yyreturn:
+ ss_save->yyss = NULL; /* disarm parse stack cleanup */
LEAVE; /* force stack free before we return */
return yyresult;
https://perl5.git.perl.org / perl5.git / blobdiff