X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perly.c;h=95779a014d1f94931cb37aba7563ad8f7ad306ac;hb=25270bc0b7409c7dbdeef1a6ec0b548e2d3e51a1;hp=1aaa22844606ad237562fc3ee0e37811a23d694d;hpb=1654d59374622f7e3936c1480c6dd5a043f5d77b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perly.c b/perly.c index 1aaa228..95779a0 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, 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,24 +34,6 @@ typedef unsigned short int yytype_uint16; typedef short int yytype_int16; typedef signed char yysigned_char; -typedef struct { - YYSTYPE val; /* semantic value */ - short state; - AV *comppad; /* value of PL_comppad when this value was created */ -#ifdef DEBUGGING - const char *name; /* token/rule name for -Dpv */ -#endif -} yy_stack_frame; - -typedef struct { - int stack_size; - int reduce_len; /* XXX integrate with yylen ? */ - yy_stack_frame *ps; /* current stack frame */ - yy_stack_frame stack[1]; /* will actually be as many as needed */ -} yy_parser; - - - #ifdef DEBUGGING # define YYDEBUG 1 #else @@ -63,7 +45,6 @@ typedef struct { # define YYSIZE_T size_t -#define YYEMPTY (-2) #define YYEOF 0 #define YYTERROR 1 @@ -124,13 +105,13 @@ yy_stack_print (pTHX_ const yy_parser *parser) { const yy_stack_frame *ps, *min; - min = parser->ps - 8; - if (min <= &parser->stack[0]) - min = &parser->stack[0] + 1; + min = parser->ps - 8 + 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++) @@ -205,52 +186,50 @@ 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; - if (ps == &parser->stack[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 flags: + /* 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 (ie Perl_croak somewhere in yylex(), or in one of the - * newFOO() functions, then its possible that some of these tokens are + * 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 shoould clearly free the op (making - * sure, for each op we free thyat we have PL_comppad pointing to the + * 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 + * 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 { .... croak .... } + * 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 it + * * 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 @@ -261,26 +240,55 @@ S_clear_yystack(pTHX_ const void *p) * 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 though should convince you that this - * two-part approach to the reducing ops should handle all three cases - * above safely. - */ + * 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 - /* free any reducing ops (1st pass) */ - for (i=0; i< parser->reduce_len; i++) { +#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++) { if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval && ps[-i].val.opval) { - if (ps[-i].comppad != PL_comppad) { - PAD_RESTORE_LOCAL(ps[-i].comppad); + 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); } - 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) { if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) { @@ -288,15 +296,17 @@ S_clear_yystack(pTHX_ const void *p) PAD_RESTORE_LOCAL(ps->comppad); } YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); +#ifndef DISABLE_STACK_FREE ps->val.opval->op_latefree = 0; - op_free(ps->val.opval); + if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed)) +#endif + op_free(ps->val.opval); } ps--; } } - /*----------. | yyparse. | `----------*/ @@ -309,33 +319,23 @@ 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. */ 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; - SV *parser_sv; /* SV whose PVX holds the parser object */ - yy_parser *parser; /* 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 - 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; - #ifndef PERL_IN_MADLY_C # ifdef PERL_MAD if (PL_madskills) @@ -345,29 +345,11 @@ Perl_yyparse (pTHX) YYDPRINTF ((Perl_debug_log, "Starting parse\n")); - ENTER; /* force stack free before we return */ - SAVEVPTR(PL_yycharp); - SAVEVPTR(PL_yylvalp); - PL_yycharp = &yychar; /* so PL_yyerror() can access it */ - PL_yylvalp = &yylval; /* so various functions in toke.c can access it */ - - parser_sv = newSV(sizeof(yy_parser) - + (YYINITDEPTH-1) * sizeof(yy_stack_frame)); - SAVEFREESV(parser_sv); - parser = (yy_parser*) SvPVX(parser_sv); - ps = (yy_stack_frame*) &parser->stack[0]; - parser->ps = ps; + parser = PL_parser; + ps = parser->ps; - parser->stack_size = YYINITDEPTH; - - /* cleanup the parse stack on premature exit */ - SAVEDESTRUCTOR_X(S_clear_yystack, (void*) parser_sv); - - - ps->state = 0; - yyerrstatus = 0; - yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ + ENTER; /* force parser stack cleanup before we return */ + SAVEDESTRUCTOR_X(S_clear_yystack, parser); /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | @@ -378,27 +360,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->reduce_len = 0; + 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; - 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", @@ -418,28 +399,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: ")); #ifdef PERL_IN_MADLY_C - yychar = PL_madskills ? madlex() : yylex(); + parser->yychar = PL_madskills ? madlex() : yylex(); #else - yychar = yylex(); + parser->yychar = yylex(); #endif # ifdef EBCDIC - if (yychar >= 0 && yychar < 255) { - yychar = NATIVE_TO_ASCII(yychar); + 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 @@ -462,12 +443,12 @@ 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; + if (parser->yychar != YYEOF) + parser->yychar = YYEMPTY; YYPUSHSTACK; ps->state = yyn; - ps->val = yylval; + ps->val = parser->yylval; ps->comppad = PL_comppad; #ifdef DEBUGGING ps->name = (const char *)(yytname[yytoken]); @@ -475,8 +456,8 @@ Perl_yyparse (pTHX) /* Count tokens shifted since error; after three, turn off error status. */ - if (yyerrstatus) - yyerrstatus--; + if (parser->yyerrstatus) + parser->yyerrstatus--; goto yynewstate; @@ -496,7 +477,7 @@ 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". @@ -506,14 +487,11 @@ Perl_yyparse (pTHX) 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 = ps[1-yylen].val; + yyval = ps[1-parser->yylen].val; YY_STACK_PRINT(parser); YY_REDUCE_PRINT (yyn); - /* if we croak during a reduce, this many tokens need special clean up */ - parser->reduce_len = yylen; - switch (yyn) { @@ -544,11 +522,12 @@ Perl_yyparse (pTHX) } +#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< yylen; i++) { + for (i=0; i< parser->yylen; i++) { if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval && ps[-i].val.opval) { @@ -558,8 +537,9 @@ Perl_yyparse (pTHX) } } } +#endif - parser->ps = ps -= (yylen-1); + parser->ps = ps -= (parser->yylen-1); /* Now shift the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule @@ -588,22 +568,21 @@ Perl_yyparse (pTHX) `------------------------------------*/ yyerrlab: /* If not already recovering from an error, report this error. */ - if (!yyerrstatus) { - ++yynerrs; + 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 (ps > &parser->stack[0]) { + while (ps > parser->stack) { YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val); if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) @@ -620,8 +599,8 @@ Perl_yyparse (pTHX) YYABORT; } - YYDSYMPRINTF ("Error: discarding", yytoken, &yylval); - yychar = YYEMPTY; + YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); + parser->yychar = YYEMPTY; } @@ -634,7 +613,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]; @@ -648,7 +627,7 @@ 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); @@ -673,7 +652,7 @@ Perl_yyparse (pTHX) YYPUSHSTACK; ps->state = yyn; - ps->val = yylval; + ps->val = parser->yylval; ps->comppad = PL_comppad; #ifdef DEBUGGING ps->name =""; @@ -687,7 +666,7 @@ Perl_yyparse (pTHX) `-------------------------------------*/ yyacceptlab: yyresult = 0; - parser->ps = &parser->stack[0]; /* disable cleanup */ + parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; /*-----------------------------------. @@ -698,7 +677,7 @@ Perl_yyparse (pTHX) goto yyreturn; yyreturn: - LEAVE; /* force stack free before we return */ + LEAVE; /* force parser stack cleanup before we return */ return yyresult; }