X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/199e78b72f538ce004dd96ef2f457b84b88279cc..099323b4093c97c455157b30e60502a8dde670c1:/perly.c diff --git a/perly.c b/perly.c index af09290..abb4d4e 100644 --- a/perly.c +++ b/perly.c @@ -1,6 +1,7 @@ /* perly.c * - * Copyright (c) 2004, 2005, 2006 Larry Wall and others + * Copyright (c) 2004, 2005, 2006, 2007, 2008, + * 2009, 2010, 2011 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. @@ -18,15 +19,12 @@ * 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. */ #include "EXTERN.h" #define PERL_IN_PERLY_C #include "perl.h" +#include "feature.h" typedef unsigned char yytype_uint8; typedef signed char yytype_int8; @@ -34,12 +32,22 @@ 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 YYDEBUG +# undef YYDEBUG +#endif #ifdef DEBUGGING # define YYDEBUG 1 #else # define YYDEBUG 0 #endif +#ifndef YY_NULL +# define YY_NULL 0 +#endif + /* contains all the parser state tables; auto-generated from perly.y */ #include "perly.tab" @@ -81,6 +89,7 @@ do { \ static void yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep) { + PERL_UNUSED_CONTEXT; if (yytype < YYNTOKENS) { YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); # ifdef YYPRINT @@ -111,7 +120,7 @@ yy_stack_print (pTHX_ const yy_parser *parser) PerlIO_printf(Perl_debug_log, "\nindex:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", ps - parser->stack); + PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); PerlIO_printf(Perl_debug_log, "\nstate:"); for (ps = min; ps <= parser->ps; ps++) @@ -131,14 +140,6 @@ yy_stack_print (pTHX_ const yy_parser *parser) : "(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; @@ -193,115 +194,38 @@ static void S_clear_yystack(pTHX_ const yy_parser *parser) { yy_stack_frame *ps = parser->ps; - int i; + int i = 0; - if (!parser->stack || ps == parser->stack) + if (!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. - */ - - /* clear any reducing ops (1st pass) */ - for (i=0; i< parser->yylen; i++) { - 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); - } - } + SvREFCNT_dec(ps[-i].compcv); } + ps -= parser->yylen; /* 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); + if (ps->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); } YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); - ps->val.opval->op_latefree = 0; - if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed)) - op_free(ps->val.opval); + op_free(ps->val.opval); } + SvREFCNT_dec(ps->compcv); ps--; } -} -/* delete a parser object */ - -void -Perl_parser_free(pTHX_ const yy_parser *parser) -{ - S_clear_yystack(aTHX_ parser); Safefree(parser->stack); - PL_parser = parser->old_parser; } @@ -310,22 +234,17 @@ Perl_parser_free(pTHX_ const yy_parser *parser) `----------*/ int -#ifdef PERL_IN_MADLY_C -Perl_madparse (pTHX) -#else -Perl_yyparse (pTHX) -#endif +Perl_yyparse (pTHX_ int gramtype) { - dVAR; - register int yystate; - register int yyn; + int yystate; + int yyn; int yyresult; /* Lookahead token as an internal (translated) token number. */ int yytoken = 0; - register yy_parser *parser; /* the parser object */ - register yy_stack_frame *ps; /* current parser stack frame */ + yy_parser *parser; /* the parser object */ + yy_stack_frame *ps; /* current parser stack frame */ #define YYPOPSTACK parser->ps = --ps #define YYPUSHSTACK parser->ps = ++ps @@ -334,20 +253,28 @@ Perl_yyparse (pTHX) action routines: ie $$. */ YYSTYPE yyval; -#ifndef PERL_IN_MADLY_C -# ifdef PERL_MAD - if (PL_madskills) - return madparse(); -# endif -#endif - YYDPRINTF ((Perl_debug_log, "Starting parse\n")); parser = PL_parser; - ps = parser->ps; - ENTER; /* force parser free before we return */ - SAVEDESTRUCTOR_X(Perl_parser_free, (void*) parser); + 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; + parser->yylen = 0; + Newx(parser->stack, YYINITDEPTH, yy_stack_frame); + ps = parser->ps = parser->stack; + ps->state = 0; + SAVEDESTRUCTOR_X(S_clear_yystack, parser); /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | @@ -358,11 +285,6 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); - if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) { - ps->val.opval->op_latefree = 1; - ps->val.opval->op_latefreed = 0; - } - parser->yylen = 0; { @@ -371,7 +293,7 @@ Perl_yyparse (pTHX) /* 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; Renew(parser->stack, parser->stack_size, yy_stack_frame); @@ -396,18 +318,8 @@ Perl_yyparse (pTHX) /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ if (parser->yychar == YYEMPTY) { - YYDPRINTF ((Perl_debug_log, "Reading a token: ")); -#ifdef PERL_IN_MADLY_C - parser->yychar = PL_madskills ? madlex() : yylex(); -#else + YYDPRINTF ((Perl_debug_log, "Reading a token:\n")); parser->yychar = yylex(); -#endif - -# ifdef EBCDIC - if (parser->yychar >= 0 && parser->yychar < 255) { - parser->yychar = NATIVE_TO_ASCII(parser->yychar); - } -# endif } if (parser->yychar <= YYEOF) { @@ -415,7 +327,16 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Now at end of input.\n")); } else { - yytoken = YYTRANSLATE (parser->yychar); + /* perly.tab is shipped based on an ASCII system, so need to index it + * with characters translated to ASCII. Although it's not designed for + * this purpose, we can use NATIVE_TO_UNI here. It returns its + * argument on ASCII platforms, and on EBCDIC translates native to + * ascii in the 0-255 range, leaving everything else unchanged. This + * jibes with yylex() returning some bare characters in that range, but + * all tokens it returns are either 0, or above 255. There could be a + * problem if NULs weren't 0, or were ever returned as raw chars by + * yylex() */ + yytoken = YYTRANSLATE (NATIVE_TO_UNI(parser->yychar)); YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval); } @@ -445,7 +366,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 @@ -490,46 +412,15 @@ Perl_yyparse (pTHX) switch (yyn) { - -#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" } - /* 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); - } + SvREFCNT_dec(ps[-i].compcv); } } @@ -540,7 +431,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 @@ -574,20 +466,23 @@ 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) { 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; @@ -625,14 +520,16 @@ Perl_yyparse (pTHX) 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; @@ -647,7 +544,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 @@ -660,6 +558,9 @@ Perl_yyparse (pTHX) `-------------------------------------*/ yyacceptlab: yyresult = 0; + for (ps=parser->ps; ps > parser->stack; ps--) { + SvREFCNT_dec(ps->compcv); + } parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; @@ -671,16 +572,10 @@ Perl_yyparse (pTHX) goto yyreturn; yyreturn: - LEAVE; /* force parser free before we return */ + 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: + * ex: set ts=8 sts=4 sw=4 et: */