X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9388183fea7d692a0a6ded83ccc01767a8af49cf..0de1c906c34397b53c088e443cd0325d9c209649:/perly.c diff --git a/perly.c b/perly.c index b18e202..eff36d1 100644 --- a/perly.c +++ b/perly.c @@ -1,14 +1,14 @@ /* perly.c * - * Copyright (c) 2004 Larry Wall + * Copyright (c) 2004, 2005, 2006, 2007, 2008 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. * * 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: @@ -17,16 +17,21 @@ * 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 - #include "EXTERN.h" #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 @@ -40,46 +45,13 @@ typedef signed char yysigned_char; # define YYSIZE_T size_t -#define yyerrok (yyerrstatus = 0) -#define yyclearin (yychar = YYEMPTY) -#define YYEMPTY (-2) #define YYEOF 0 +#define YYTERROR 1 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrlab1 - -/* Like YYERROR except do call yyerror. This remains here temporarily - to ease the transition to the new meaning of YYERROR, for GCC. - Once GCC version 2 has supplanted version 1, this can go. */ - -#define YYFAIL goto yyerrlab - -#define YYRECOVERING() (!!yyerrstatus) - -#define YYBACKUP(Token, Value) \ -do \ - if (yychar == YYEMPTY && yylen == 1) { \ - yychar = (Token); \ - yylval = (Value); \ - yytoken = YYTRANSLATE (yychar); \ - YYPOPSTACK; \ - goto yybackup; \ - } \ - else { \ - yyerror ("syntax error: cannot back up"); \ - YYERROR; \ - } \ -while (0) - -#define YYTERROR 1 -#define YYERRCODE 256 - -/* YYLEX -- calling `yylex' with the right arguments. */ - -# define YYLEX yylex_r (&yylval, &yychar) - /* Enable debugging if requested. */ #ifdef DEBUGGING @@ -93,12 +65,6 @@ do { \ YYFPRINTF Args; \ } while (0) -# define YYDSYMPRINT(Args) \ -do { \ - if (yydebug) \ - yysymprint Args; \ -} while (0) - # define YYDSYMPRINTF(Title, Token, Value) \ do { \ if (yydebug) { \ @@ -113,65 +79,80 @@ do { \ `--------------------------------*/ static void -yysymprint (pTHX_ PerlIO *yyoutput, int yytype, YYSTYPE *yyvaluep) +yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep) { - /* Pacify ``unused variable'' warnings. */ - (void) yyvaluep; - if (yytype < YYNTOKENS) { YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); # ifdef YYPRINT YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # else - YYFPRINTF (yyoutput, "0x%x", yyvaluep->ival); + YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival); # endif } else YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); - switch (yytype) { - default: - break; - } YYFPRINTF (yyoutput, ")"); } /* yy_stack_print() - * print the top 8 items on the parse stack. The args have the same - * meanings as the local vars in yyparse() of the same name */ + * print the top 8 items on the parse stack. + */ static void -yy_stack_print (pTHX_ short *yyss, short *yyssp, YYSTYPE *yyvs, char**yyns) +yy_stack_print (pTHX_ const yy_parser *parser) { - int i; - int start = 1; - int count = (int)(yyssp - yyss); + const yy_stack_frame *ps, *min; - if (count > 8) { - start = count - 8 + 1; - count = 8; - } + min = parser->ps - 8 + 1; + if (min <= parser->stack) + min = parser->stack + 1; PerlIO_printf(Perl_debug_log, "\nindex:"); - for (i=0; i < count; i++) - PerlIO_printf(Perl_debug_log, " %8d", start+i); + for (ps = min; ps <= parser->ps; ps++) + PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); + PerlIO_printf(Perl_debug_log, "\nstate:"); - for (i=0, yyss += start; i < count; i++, yyss++) - PerlIO_printf(Perl_debug_log, " %8d", *yyss); + for (ps = min; ps <= parser->ps; ps++) + PerlIO_printf(Perl_debug_log, " %8d", ps->state); + PerlIO_printf(Perl_debug_log, "\ntoken:"); - for (i=0, yyns += start; i < count; i++, yyns++) - PerlIO_printf(Perl_debug_log, " %8.8s", *yyns); + for (ps = min; ps <= parser->ps; ps++) + PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); + PerlIO_printf(Perl_debug_log, "\nvalue:"); - for (i=0, yyvs += start; i < count; i++, yyvs++) - PerlIO_printf(Perl_debug_log, " %8x", yyvs->ival); + for (ps = min; ps <= parser->ps; ps++) { + switch (yy_type_tab[yystos[ps->state]]) { + case toketype_opval: + PerlIO_printf(Perl_debug_log, " %8.8s", + ps->val.opval + ? PL_op_name[ps->val.opval->op_type] + : "(Nullop)" + ); + break; +#ifndef PERL_IN_MADLY_C + case toketype_p_tkval: + PerlIO_printf(Perl_debug_log, " %8.8s", + ps->val.pval ? ps->val.pval : "(NULL)"); + break; + + case toketype_i_tkval: +#endif + case toketype_ival: + PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival); + break; + default: + PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival); + } + } PerlIO_printf(Perl_debug_log, "\n\n"); } -# define YY_STACK_PRINT(yyss, yyssp, yyvs, yyns) \ -do { \ - if (yydebug && DEBUG_v_TEST) \ - yy_stack_print (aTHX_ (yyss), (yyssp), (yyvs), (yyns)); \ +# define YY_STACK_PRINT(parser) \ +do { \ + if (yydebug && DEBUG_v_TEST) \ + yy_stack_print (aTHX_ parser); \ } while (0) @@ -183,7 +164,7 @@ static void yy_reduce_print (pTHX_ int yyrule) { int yyi; - unsigned int yylineno = yyrline[yyrule]; + const unsigned int yylineno = yyrline[yyrule]; YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ", yyrule - 1, yylineno); /* Print the symbols being reduced, and their result. */ @@ -200,78 +181,132 @@ do { \ #else /* !DEBUGGING */ # define YYDPRINTF(Args) -# define YYDSYMPRINT(Args) # define YYDSYMPRINTF(Title, Token, Value) -# define YY_STACK_PRINT(yyss, yyssp, yyvs, yyns) +# define YY_STACK_PRINT(parser) # define YY_REDUCE_PRINT(Rule) #endif /* !DEBUGGING */ - -/* YYINITDEPTH -- initial size of the parser's stacks. */ -#ifndef YYINITDEPTH -# define YYINITDEPTH 200 -#endif - - -#if YYERROR_VERBOSE -# ifndef yystrlen -# if defined (__GLIBC__) && defined (_STRING_H) -# define yystrlen strlen -# else -/* Return the length of YYSTR. */ -static YYSIZE_T -yystrlen (const char *yystr) -{ - register const char *yys = yystr; - - while (*yys++ != '\0') - continue; - - return yys - yystr - 1; -} -# endif -# endif - -# ifndef yystpcpy -# if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE) -# define yystpcpy stpcpy -# else -/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in - YYDEST. */ -static char * -yystpcpy (pTHX_ char *yydest, const char *yysrc) -{ - register char *yyd = yydest; - register const char *yys = yysrc; - - while ((*yyd++ = *yys++) != '\0') - continue; - - return yyd - 1; -} -# endif -# endif - -#endif /* !YYERROR_VERBOSE */ - - -/*-----------------------------------------------. -| Release the memory associated to this symbol. | -`-----------------------------------------------*/ +/* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the + * parse stack, thus avoiding leaks if we die */ static void -yydestruct (int yytype, YYSTYPE *yyvaluep) +S_clear_yystack(pTHX_ const yy_parser *parser) { - /* Pacify ``unused variable'' warnings. */ - (void) yyvaluep; - - switch (yytype) { - default: - break; + yy_stack_frame *ps = parser->ps; + int i = 0; + + if (!parser->stack || ps == parser->stack) + return; + + YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n")); + + /* Freeing ops on the stack, and the op_latefree / op_latefreed / + * op_attached flags: + * + * When we pop tokens off the stack during error recovery, or when + * we pop all the tokens off the stack after a die during a shift or + * reduce (i.e. Perl_croak somewhere in yylex() or in one of the + * newFOO() functions), then it's possible that some of these tokens are + * of type opval, pointing to an OP. All these ops are orphans; each is + * its own miniature subtree that has not yet been attached to a + * larger tree. In this case, we should clearly free the op (making + * sure, for each op we free that we have PL_comppad pointing to the + * right place for freeing any SVs attached to the op in threaded + * builds. + * + * However, there is a particular problem if we die in newFOO() called + * by a reducing action; e.g. + * + * foo : bar baz boz + * { $$ = newFOO($1,$2,$3) } + * + * where + * OP *newFOO { ....; if (...) croak; .... } + * + * In this case, when we come to clean bar baz and boz off the stack, + * we don't know whether newFOO() has already: + * * freed them + * * left them as is + * * attached them to part of a larger tree + * * attached them to PL_compcv + * * attached them to PL_compcv then freed it (as in BEGIN {die } ) + * + * To get round this problem, we set the flag op_latefree on every op + * that gets pushed onto the parser stack. If op_free() sees this + * flag, it clears the op and frees any children,, but *doesn't* free + * the op itself; instead it sets the op_latefreed flag. This means + * that we can safely call op_free() multiple times on each stack op. + * So, when clearing the stack, we first, for each op that was being + * reduced, call op_free with op_latefree=1. This ensures that all ops + * hanging off these op are freed, but the reducing ops themselces are + * just undefed. Then we set op_latefreed=0 on *all* ops on the stack + * and free them. A little thought should convince you that this + * two-part approach to the reducing ops should handle the first three + * cases above safely. + * + * In the case of attaching to PL_compcv (currently just newATTRSUB + * does this), then we set the op_attached flag on the op that has + * been so attached, then avoid doing the final op_free during + * cleanup, on the assumption that it will happen (or has already + * happened) when PL_compcv is freed. + * + * Note this is fairly fragile mechanism. A more robust approach + * would be to use two of these flag bits as 2-bit reference count + * field for each op, indicating whether it is pointed to from: + * * a parent op + * * the parser stack + * * a CV + * but this would involve reworking all code (core and external) that + * manipulate op trees. + * + * XXX DAPM 17/1/07 I've decided its too fragile for now, and so have + * disabled it */ + +#define DISABLE_STACK_FREE + + +#ifdef DISABLE_STACK_FREE + ps -= parser->yylen; + PERL_UNUSED_VAR(i); +#else + /* clear any reducing ops (1st pass) */ + + for (i=0; i< parser->yylen; i++) { + LEAVE_SCOPE(ps[-i].savestack_ix); + if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval + && ps[-i].val.opval) { + if ( ! (ps[-i].val.opval->op_attached + && !ps[-i].val.opval->op_latefreed)) + { + if (ps[-i].comppad != PL_comppad) { + PAD_RESTORE_LOCAL(ps[-i].comppad); + } + op_free(ps[-i].val.opval); + } + } } -} +#endif + /* now free whole the stack, including the just-reduced ops */ + while (ps > parser->stack) { + LEAVE_SCOPE(ps->savestack_ix); + if (yy_type_tab[yystos[ps->state]] == toketype_opval + && ps->val.opval) + { + if (ps->comppad != PL_comppad) { + PAD_RESTORE_LOCAL(ps->comppad); + } + YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); +#ifndef DISABLE_STACK_FREE + ps->val.opval->op_latefree = 0; + if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed)) +#endif + op_free(ps->val.opval); + } + ps--; + } +} /*----------. @@ -279,152 +314,83 @@ yydestruct (int yytype, YYSTYPE *yyvaluep) `----------*/ int +#ifdef PERL_IN_MADLY_C +Perl_madparse (pTHX) +#else Perl_yyparse (pTHX) +#endif { - int yychar; /* The lookahead symbol. */ - YYSTYPE yylval; /* The semantic value of the lookahead symbol. */ - int yynerrs; /* Number of syntax errors so far. */ + dVAR; register int yystate; register int yyn; int yyresult; - /* Number of tokens to shift before error messages enabled. */ - int yyerrstatus; /* Lookahead token as an internal (translated) token number. */ int yytoken = 0; - /* two stacks and their tools: - `yyss': related to states, - `yyvs': related to semantic values, - - Refer to the stacks thru separate pointers, to allow yyoverflow - to reallocate them elsewhere. */ - - /* The state stack. */ - short *yyss; - register short *yyssp; + register yy_parser *parser; /* the parser object */ + register yy_stack_frame *ps; /* current parser stack frame */ - /* The semantic value stack. */ - YYSTYPE *yyvs; - register YYSTYPE *yyvsp; +#define YYPOPSTACK parser->ps = --ps +#define YYPUSHSTACK parser->ps = ++ps - /* for ease of re-allocation and automatic freeing, have two SVs whose - * SvPVX points to the stacks */ - SV *yyss_sv, *yyvs_sv; - -#ifdef DEBUGGING - /* maintain also a stack of token/rule names for debugging with -Dpv */ - char **yyns, **yynsp; - SV *yyns_sv; -# define YYPOPSTACK (yyvsp--, yyssp--, yynsp--) -#else -# define YYPOPSTACK (yyvsp--, yyssp--) -#endif - - - YYSIZE_T yystacksize = YYINITDEPTH; - - /* The variables used to return semantic value and location from the - action routines. */ + /* The variable used to return semantic value and location from the + action routines: ie $$. */ YYSTYPE yyval; - - /* When reducing, the number of symbols on the RHS of the reduced - rule. */ - int yylen; - - YYDPRINTF ((Perl_debug_log, "Starting parse\n")); - -#ifdef USE_ITHREADS - /* XXX is this needed anymore? DAPM 13-Feb-04; - * if not, delete the correspinding LEAVE too */ - ENTER; /* force stack free before we return */ -#endif - yyss_sv = NEWSV(73, YYINITDEPTH * sizeof(short)); - yyvs_sv = NEWSV(73, YYINITDEPTH * sizeof(YYSTYPE)); - SAVEFREESV(yyss_sv); - SAVEFREESV(yyvs_sv); - yyss = (short *) SvPVX(yyss_sv); - yyvs = (YYSTYPE *) SvPVX(yyvs_sv); - /* note that elements zero of yyvs and yyns are not used */ - yyssp = yyss; - yyvsp = yyvs; -#ifdef DEBUGGING - yyns_sv = NEWSV(73, YYINITDEPTH * sizeof(char *)); - SAVEFREESV(yyns_sv); - yyns = (char **) SvPVX(yyns_sv); - yynsp = yyns; +#ifndef PERL_IN_MADLY_C +# ifdef PERL_MAD + if (PL_madskills) + return madparse(); +# endif #endif - yystate = 0; - yyerrstatus = 0; - yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ - + YYDPRINTF ((Perl_debug_log, "Starting parse\n")); + parser = PL_parser; + ps = parser->ps; - YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); - - goto yysetstate; + ENTER; /* force parser stack cleanup before we return */ + SAVEDESTRUCTOR_X(S_clear_yystack, parser); /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ yynewstate: - /* In all cases, when you get here, the value and location stacks - have just been pushed. so pushing a state here evens the stacks. - */ - yyssp++; - - yysetstate: - *yyssp = yystate; - - if (yyss + yystacksize - 1 <= yyssp) { - /* Get the current used size of the three stacks, in elements. */ - YYSIZE_T yysize = yyssp - yyss + 1; - - /* Extend the stack our own way. */ - if (YYMAXDEPTH <= yystacksize) - goto yyoverflowlab; - yystacksize *= 2; - if (YYMAXDEPTH < yystacksize) - yystacksize = YYMAXDEPTH; - - SvGROW(yyss_sv, yystacksize * sizeof(short)); - SvGROW(yyvs_sv, yystacksize * sizeof(YYSTYPE)); - yyss = (short *) SvPVX(yyss_sv); - yyvs = (YYSTYPE *) SvPVX(yyvs_sv); -#ifdef DEBUGGING - SvGROW(yyns_sv, yystacksize * sizeof(char *)); - yyns = (char **) SvPVX(yyns_sv); - if (! yyns) - goto yyoverflowlab; - yynsp = yyns + yysize - 1; -#endif - if (!yyss || ! yyvs) - goto yyoverflowlab; - - yyssp = yyss + yysize - 1; - yyvsp = yyvs + yysize - 1; + yystate = ps->state; - YYDPRINTF ((Perl_debug_log, "Stack size increased to %lu\n", - (unsigned long int) yystacksize)); + YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); - if (yyss + yystacksize - 1 <= yyssp) - YYABORT; +#ifndef DISABLE_STACK_FREE + if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) { + ps->val.opval->op_latefree = 1; + ps->val.opval->op_latefreed = 0; } +#endif + + parser->yylen = 0; - goto yybackup; + { + size_t size = ps - parser->stack + 1; - /*-----------. - | yybackup. | - `-----------*/ - yybackup: + /* grow the stack? We always leave 1 spare slot, + * in case of a '' -> 'foo' reduction */ + + if (size >= (size_t)parser->stack_size - 1) { + /* this will croak on insufficient memory */ + parser->stack_size *= 2; + Renew(parser->stack, parser->stack_size, yy_stack_frame); + ps = parser->ps = parser->stack + size -1; + + YYDPRINTF((Perl_debug_log, + "parser stack size increased to %lu frames\n", + (unsigned long int)parser->stack_size)); + } + } /* Do appropriate processing given the current state. */ /* Read a lookahead token if we need one and don't already have one. */ -/* yyresume: */ /* First try to decide what to do without reference to lookahead token. */ @@ -435,18 +401,28 @@ Perl_yyparse (pTHX) /* Not known => get a lookahead token if don't already have one. */ /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ - if (yychar == YYEMPTY) { + if (parser->yychar == YYEMPTY) { YYDPRINTF ((Perl_debug_log, "Reading a token: ")); - yychar = YYLEX; +#ifdef PERL_IN_MADLY_C + parser->yychar = PL_madskills ? madlex() : yylex(); +#else + parser->yychar = yylex(); +#endif + +# ifdef EBCDIC + if (parser->yychar >= 0 && parser->yychar < 255) { + parser->yychar = NATIVE_TO_ASCII(parser->yychar); + } +# endif } - if (yychar <= YYEOF) { - yychar = yytoken = YYEOF; + if (parser->yychar <= YYEOF) { + parser->yychar = yytoken = YYEOF; YYDPRINTF ((Perl_debug_log, "Now at end of input.\n")); } else { - yytoken = YYTRANSLATE (yychar); - YYDSYMPRINTF ("Next token is", yytoken, &yylval); + yytoken = YYTRANSLATE (parser->yychar); + YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval); } /* If the proper action on seeing token YYTOKEN is to reduce or to @@ -469,22 +445,22 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken])); /* Discard the token being shifted unless it is eof. */ - if (yychar != YYEOF) - yychar = YYEMPTY; - - *++yyvsp = yylval; + if (parser->yychar != YYEOF) + parser->yychar = YYEMPTY; + + YYPUSHSTACK; + ps->state = yyn; + ps->val = parser->yylval; + ps->comppad = PL_comppad; + ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING - *++yynsp = (char *)(yytname[yytoken]); + ps->name = (const char *)(yytname[yytoken]); #endif - /* Count tokens shifted since error; after three, turn off error status. */ - if (yyerrstatus) - yyerrstatus--; - - yystate = yyn; - YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); + if (parser->yyerrstatus) + parser->yyerrstatus--; goto yynewstate; @@ -504,63 +480,89 @@ Perl_yyparse (pTHX) `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ - yylen = yyr2[yyn]; + parser->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 users should not rely upon it. Assigning to YYVAL unconditionally makes the parser a bit smaller, and it avoids a GCC warning that YYVAL may be used uninitialized. */ - yyval = yyvsp[1-yylen]; - + yyval = ps[1-parser->yylen].val; + YY_STACK_PRINT(parser); YY_REDUCE_PRINT (yyn); + 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; -#ifdef DEBUGGING - yynsp -= yylen; +#ifndef DISABLE_STACK_FREE + /* any just-reduced ops with the op_latefreed flag cleared need to be + * freed; the rest need the flag resetting */ + { + int i; + for (i=0; i< parser->yylen; i++) { + if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval + && ps[-i].val.opval) + { + ps[-i].val.opval->op_latefree = 0; + if (ps[-i].val.opval->op_latefreed) + op_free(ps[-i].val.opval); + } + } + } #endif + parser->ps = ps -= (parser->yylen-1); - *++yyvsp = yyval; -#ifdef DEBUGGING - *++yynsp = (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. */ + ps->val = yyval; + ps->comppad = PL_comppad; + ps->savestack_ix = PL_savestack_ix; +#ifdef DEBUGGING + ps->name = (const char *)(yytname [yyr1[yyn]]); +#endif + yyn = yyr1[yyn]; - yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; - if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state; + if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state) yystate = yytable[yystate]; else yystate = yydefgoto[yyn - YYNTOKENS]; - - YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); - -#ifdef DEBUGGING - /* tmp push yystate for stack print; this is normally pushed later in - * yynewstate */ - yyssp++; - *yyssp = yystate; - YY_STACK_PRINT (yyss, yyssp, yyvs, yyns); - yyssp--; -#endif + ps->state = yystate; goto yynewstate; @@ -570,78 +572,40 @@ Perl_yyparse (pTHX) `------------------------------------*/ yyerrlab: /* If not already recovering from an error, report this error. */ - if (!yyerrstatus) { - ++yynerrs; -#if YYERROR_VERBOSE - yyn = yypact[yystate]; - - if (YYPACT_NINF < yyn && yyn < YYLAST) { - YYSIZE_T yysize = 0; - int yytype = YYTRANSLATE (yychar); - char *yymsg; - int yyx, yycount; - - yycount = 0; - /* Start YYX at -YYN if negative to avoid negative indexes in - YYCHECK. */ - for (yyx = yyn < 0 ? -yyn : 0; - yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++) - if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) - yysize += yystrlen (yytname[yyx]) + 15, yycount++; - yysize += yystrlen ("syntax error, unexpected ") + 1; - yysize += yystrlen (yytname[yytype]); - New(yymsg, yysize, char *); - if (yymsg != 0) { - char *yyp = yystpcpy (yymsg, "syntax error, unexpected "); - yyp = yystpcpy (yyp, yytname[yytype]); - - if (yycount < 5) { - yycount = 0; - for (yyx = yyn < 0 ? -yyn : 0; - yyx < (int) (sizeof (yytname) / sizeof (char *)); - yyx++) - { - if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) { - const char *yyq = ! yycount ? - ", expecting " : " or "; - yyp = yystpcpy (yyp, yyq); - yyp = yystpcpy (yyp, yytname[yyx]); - yycount++; - } - } - } - yyerror (yymsg); - YYSTACK_FREE (yymsg); - } - else - yyerror ("syntax error; also virtual memory exhausted"); - } - else -#endif /* YYERROR_VERBOSE */ - yyerror ("syntax error"); + if (!parser->yyerrstatus) { + yyerror ("syntax error"); } - if (yyerrstatus == 3) { + if (parser->yyerrstatus == 3) { /* If just tried and failed to reuse lookahead token after an error, discard it. */ /* Return failure if at end of input. */ - if (yychar == YYEOF) { + if (parser->yychar == YYEOF) { /* Pop the error token. */ YYPOPSTACK; /* Pop the rest of the stack. */ - while (yyss < yyssp) { - YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp); - yydestruct (yystos[*yyssp], yyvsp); + while (ps > parser->stack) { + YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val); + LEAVE_SCOPE(ps->savestack_ix); + if (yy_type_tab[yystos[ps->state]] == toketype_opval + && ps->val.opval) + { + YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); + if (ps->comppad != PL_comppad) { + PAD_RESTORE_LOCAL(ps->comppad); + } + ps->val.opval->op_latefree = 0; + op_free(ps->val.opval); + } YYPOPSTACK; } YYABORT; } - YYDSYMPRINTF ("Error: discarding", yytoken, &yylval); - yydestruct (yytoken, &yylval); - yychar = YYEMPTY; + YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); + parser->yychar = YYEMPTY; } @@ -654,7 +618,7 @@ Perl_yyparse (pTHX) | yyerrlab1 -- error raised explicitly by an action. | `----------------------------------------------------*/ yyerrlab1: - yyerrstatus = 3; /* Each real token shifted decrements this. */ + parser->yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; @@ -668,18 +632,23 @@ Perl_yyparse (pTHX) } /* Pop the current state because it cannot handle the error token. */ - if (yyssp == yyss) + if (ps == parser->stack) YYABORT; - YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp); - yydestruct (yystos[yystate], yyvsp); - yyvsp--; -#ifdef DEBUGGING - yynsp--; -#endif - yystate = *--yyssp; + YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val); + LEAVE_SCOPE(ps->savestack_ix); + if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) { + YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); + if (ps->comppad != PL_comppad) { + PAD_RESTORE_LOCAL(ps->comppad); + } + ps->val.opval->op_latefree = 0; + op_free(ps->val.opval); + } + YYPOPSTACK; + yystate = ps->state; - YY_STACK_PRINT (yyss, yyssp, yyvs, yyns); + YY_STACK_PRINT(parser); } if (yyn == YYFINAL) @@ -687,14 +656,15 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Shifting error token, ")); - *++yyvsp = yylval; + YYPUSHSTACK; + ps->state = yyn; + ps->val = parser->yylval; + ps->comppad = PL_comppad; + ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING - *++yynsp =""; + ps->name =""; #endif - yystate = yyn; - YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); - goto yynewstate; @@ -703,6 +673,7 @@ Perl_yyparse (pTHX) `-------------------------------------*/ yyacceptlab: yyresult = 0; + parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; /*-----------------------------------. @@ -712,19 +683,17 @@ Perl_yyparse (pTHX) yyresult = 1; goto yyreturn; - /*----------------------------------------------. - | yyoverflowlab -- parser overflow comes here. | - `----------------------------------------------*/ - yyoverflowlab: - yyerror ("parser stack overflow"); - yyresult = 2; - /* Fall through. */ - yyreturn: - -#ifdef USE_ITHREADS - LEAVE; /* force stack free before we return */ -#endif - + LEAVE; /* force parser stack cleanup before we return */ return yyresult; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */