X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/714c8e96dde801b3b2e73fc130d02c78db1eb06f..09eb7cfbca20b4071e1b90c66713173d118d1d47:/perly.c diff --git a/perly.c b/perly.c index 016c7d7..3edf57d 100644 --- a/perly.c +++ b/perly.c @@ -1,6 +1,6 @@ /* perly.c * - * Copyright (c) 2004, 2005, 2006 Larry Wall and others + * 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. @@ -34,6 +34,9 @@ typedef unsigned short int yytype_uint16; typedef short int yytype_int16; typedef signed char yysigned_char; +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#define YYINITDEPTH 200 + #ifdef DEBUGGING # define YYDEBUG 1 #else @@ -45,7 +48,6 @@ typedef signed char yysigned_char; # define YYSIZE_T size_t -#define YYEMPTY (-2) #define YYEOF 0 #define YYTERROR 1 @@ -107,12 +109,12 @@ yy_stack_print (pTHX_ const yy_parser *parser) const yy_stack_frame *ps, *min; min = parser->ps - 8 + 1; - if (min <= &parser->stack[0]) - min = &parser->stack[0] + 1; + if (min <= parser->stack) + min = parser->stack + 1; PerlIO_printf(Perl_debug_log, "\nindex:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", ps - &parser->stack[0]); + PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); PerlIO_printf(Perl_debug_log, "\nstate:"); for (ps = min; ps <= parser->ps; ps++) @@ -187,21 +189,16 @@ do { \ # define YY_REDUCE_PRINT(Rule) #endif /* !DEBUGGING */ - -/* YYINITDEPTH -- initial size of the parser's stacks. */ -#define YYINITDEPTH 200 - /* 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) +S_clear_yystack(pTHX_ const yy_parser *parser) { - yy_parser *parser = (yy_parser*) SvPVX((SV*)p); yy_stack_frame *ps = parser->ps; - int i; + int i = 0; - if (ps == &parser->stack[0]) + if (!parser->stack) return; YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n")); @@ -264,42 +261,62 @@ S_clear_yystack(pTHX_ const void *p) * * 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 + for (i=0; i< parser->yylen; i++) { + SvREFCNT_dec(ps[-i].compcv); + } + ps -= parser->yylen; +#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); + if (ps[-i].compcv != PL_compcv) { + PL_compcv = ps[-i].compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } op_free(ps[-i].val.opval); } } } +#endif /* now free whole the stack, including the just-reduced ops */ - while (ps > &parser->stack[0]) { + 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); + if (ps->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } 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); } + SvREFCNT_dec(ps->compcv); ps--; } -} + Safefree(parser->stack); +} /*----------. @@ -308,9 +325,9 @@ S_clear_yystack(pTHX_ const void *p) int #ifdef PERL_IN_MADLY_C -Perl_madparse (pTHX) +Perl_madparse (pTHX_ int gramtype) #else -Perl_yyparse (pTHX) +Perl_yyparse (pTHX_ int gramtype) #endif { dVAR; @@ -321,45 +338,45 @@ Perl_yyparse (pTHX) /* Lookahead token as an internal (translated) token number. */ int yytoken = 0; - SV *parser_sv; /* SV whose PVX holds the parser object */ register yy_parser *parser; /* the parser object */ register yy_stack_frame *ps; /* current parser stack frame */ #define YYPOPSTACK parser->ps = --ps #define YYPUSHSTACK parser->ps = ++ps - /* The variables used to return semantic value and location from the + /* The variable used to return semantic value and location from the action routines: ie $$. */ YYSTYPE yyval; #ifndef PERL_IN_MADLY_C # ifdef PERL_MAD if (PL_madskills) - return madparse(); + return madparse(gramtype); # endif #endif YYDPRINTF ((Perl_debug_log, "Starting parse\n")); - ENTER; /* force stack free before we return */ - SAVEVPTR(PL_parser); + parser = PL_parser; - parser_sv = newSV(sizeof(yy_parser) - + (YYINITDEPTH-1) * sizeof(yy_stack_frame)); - SAVEFREESV(parser_sv); - PL_parser = parser = (yy_parser*) SvPVX(parser_sv); - ps = (yy_stack_frame*) &parser->stack[0]; - parser->ps = ps; + ENTER; /* force parser state cleanup/restoration before we return */ + SAVEPPTR(parser->yylval.pval); + SAVEINT(parser->yychar); + SAVEINT(parser->yyerrstatus); + SAVEINT(parser->stack_size); + SAVEINT(parser->yylen); + SAVEVPTR(parser->stack); + SAVEVPTR(parser->ps); + /* initialise state for this parse */ + parser->yychar = gramtype; + parser->yyerrstatus = 0; parser->stack_size = YYINITDEPTH; - - /* cleanup the parse stack on premature exit */ - SAVEDESTRUCTOR_X(S_clear_yystack, (void*) parser_sv); - - + parser->yylen = 0; + Newx(parser->stack, YYINITDEPTH, yy_stack_frame); + ps = parser->ps = parser->stack; ps->state = 0; - parser->yyerrstatus = 0; - parser->yychar = YYEMPTY; /* Cause a token to be read. */ + SAVEDESTRUCTOR_X(S_clear_yystack, parser); /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | @@ -370,28 +387,26 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); +#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; { - size_t size = ps - &parser->stack[0] + 1; + size_t size = ps - parser->stack + 1; /* grow the stack? We always leave 1 spare slot, * in case of a '' -> 'foo' reduction */ - if (size >= parser->stack_size - 1) { + if (size >= (size_t)parser->stack_size - 1) { /* this will croak on insufficient memory */ parser->stack_size *= 2; - PL_parser = parser = - (yy_parser*) SvGROW(parser_sv, sizeof(yy_parser) - + (parser->stack_size-1) * sizeof(yy_stack_frame)); - - /* readdress any pointers into realloced parser object */ - ps = parser->ps = &parser->stack[0] + size -1; + 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", @@ -461,7 +476,8 @@ Perl_yyparse (pTHX) YYPUSHSTACK; ps->state = yyn; ps->val = parser->yylval; - ps->comppad = PL_comppad; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name = (const char *)(yytname[yytoken]); #endif @@ -539,6 +555,7 @@ Perl_yyparse (pTHX) { int i; for (i=0; i< parser->yylen; i++) { +#ifndef DISABLE_STACK_FREE if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval && ps[-i].val.opval) { @@ -546,6 +563,8 @@ Perl_yyparse (pTHX) if (ps[-i].val.opval->op_latefreed) op_free(ps[-i].val.opval); } +#endif + SvREFCNT_dec(ps[-i].compcv); } } @@ -556,7 +575,8 @@ Perl_yyparse (pTHX) number reduced by. */ ps->val = yyval; - ps->comppad = PL_comppad; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name = (const char *)(yytname [yyr1[yyn]]); #endif @@ -590,26 +610,32 @@ Perl_yyparse (pTHX) /* Return failure if at end of input. */ if (parser->yychar == YYEOF) { /* Pop the error token. */ + SvREFCNT_dec(ps->compcv); YYPOPSTACK; /* Pop the rest of the stack. */ - while (ps > &parser->stack[0]) { + 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); + if (ps->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } ps->val.opval->op_latefree = 0; op_free(ps->val.opval); } + SvREFCNT_dec(ps->compcv); YYPOPSTACK; } YYABORT; } YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); + if (yy_type_tab[yytoken] == toketype_opval) + op_free(parser->yylval.opval); parser->yychar = YYEMPTY; } @@ -637,18 +663,21 @@ Perl_yyparse (pTHX) } /* Pop the current state because it cannot handle the error token. */ - if (ps == &parser->stack[0]) + if (ps == parser->stack) YYABORT; 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); + if (ps->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } ps->val.opval->op_latefree = 0; op_free(ps->val.opval); } + SvREFCNT_dec(ps->compcv); YYPOPSTACK; yystate = ps->state; @@ -663,7 +692,8 @@ Perl_yyparse (pTHX) YYPUSHSTACK; ps->state = yyn; ps->val = parser->yylval; - ps->comppad = PL_comppad; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name =""; #endif @@ -676,7 +706,10 @@ Perl_yyparse (pTHX) `-------------------------------------*/ yyacceptlab: yyresult = 0; - parser->ps = &parser->stack[0]; /* disable cleanup */ + for (ps=parser->ps; ps > parser->stack; ps--) { + SvREFCNT_dec(ps->compcv); + } + parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; /*-----------------------------------. @@ -687,7 +720,7 @@ Perl_yyparse (pTHX) goto yyreturn; yyreturn: - LEAVE; /* force stack free before we return */ + LEAVE; /* force parser stack cleanup before we return */ return yyresult; }