Mercurial > repo
diff perl-5.22.2/perly.c @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/perl-5.22.2/perly.c Sat May 14 14:54:38 2016 +0000 @@ -0,0 +1,581 @@ +/* perly.c + * + * 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. + * + * 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. + * + * Here is an important copyright statement from the original, generated + * file: + * + * As a special exception, when this file is copied by Bison into a + * 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. + * + */ + +#include "EXTERN.h" +#define PERL_IN_PERLY_C +#include "perl.h" +#include "feature.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; + +/* 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" + +# define YYSIZE_T size_t + +#define YYEOF 0 +#define YYTERROR 1 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrlab1 + +/* Enable debugging if requested. */ +#ifdef DEBUGGING + +# define yydebug (DEBUG_p_TEST) + +# define YYFPRINTF PerlIO_printf + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) + +# define YYDSYMPRINTF(Title, Token, Value) \ +do { \ + if (yydebug) { \ + YYFPRINTF (Perl_debug_log, "%s ", Title); \ + yysymprint (aTHX_ Perl_debug_log, Token, Value); \ + YYFPRINTF (Perl_debug_log, "\n"); \ + } \ +} while (0) + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +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 + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# else + YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival); +# endif + } + else + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + + YYFPRINTF (yyoutput, ")"); +} + + +/* yy_stack_print() + * print the top 8 items on the parse stack. + */ + +static void +yy_stack_print (pTHX_ const yy_parser *parser) +{ + const yy_stack_frame *ps, *min; + + 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", (int)(ps - parser->stack)); + + PerlIO_printf(Perl_debug_log, "\nstate:"); + for (ps = min; ps <= parser->ps; ps++) + PerlIO_printf(Perl_debug_log, " %8d", ps->state); + + PerlIO_printf(Perl_debug_log, "\ntoken:"); + for (ps = min; ps <= parser->ps; ps++) + PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); + + PerlIO_printf(Perl_debug_log, "\nvalue:"); + 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; + 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(parser) \ +do { \ + if (yydebug && DEBUG_v_TEST) \ + yy_stack_print (aTHX_ parser); \ +} while (0) + + +/*------------------------------------------------. +| Report that the YYRULE is going to be reduced. | +`------------------------------------------------*/ + +static void +yy_reduce_print (pTHX_ int yyrule) +{ + int yyi; + 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. */ + for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++) + YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]); + YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]); +} + +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (aTHX_ Rule); \ +} while (0) + +#else /* !DEBUGGING */ +# define YYDPRINTF(Args) +# define YYDSYMPRINTF(Title, Token, Value) +# define YY_STACK_PRINT(parser) +# define YY_REDUCE_PRINT(Rule) +#endif /* !DEBUGGING */ + +/* 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 yy_parser *parser) +{ + yy_stack_frame *ps = parser->ps; + int i = 0; + + if (!parser->stack) + return; + + YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n")); + + for (i=0; i< parser->yylen; i++) { + 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->compcv && (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")); + op_free(ps->val.opval); + } + SvREFCNT_dec(ps->compcv); + ps--; + } + + Safefree(parser->stack); +} + + +/*----------. +| yyparse. | +`----------*/ + +int +Perl_yyparse (pTHX_ int gramtype) +{ + int yystate; + int yyn; + int yyresult; + + /* Lookahead token as an internal (translated) token number. */ + int yytoken = 0; + + yy_parser *parser; /* the parser object */ + yy_stack_frame *ps; /* current parser stack frame */ + +#define YYPOPSTACK parser->ps = --ps +#define YYPUSHSTACK parser->ps = ++ps + + /* The variable used to return semantic value and location from the + action routines: ie $$. */ + YYSTYPE yyval; + + YYDPRINTF ((Perl_debug_log, "Starting parse\n")); + + parser = PL_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. | +`------------------------------------------------------------*/ + yynewstate: + + yystate = ps->state; + + YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); + + parser->yylen = 0; + + { + size_t size = ps - parser->stack + 1; + + /* 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. */ + + /* First try to decide what to do without reference to lookahead token. */ + + yyn = yypact[yystate]; + if (yyn == YYPACT_NINF) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ + if (parser->yychar == YYEMPTY) { + YYDPRINTF ((Perl_debug_log, "Reading a token:\n")); + parser->yychar = yylex(); + } + + if (parser->yychar <= YYEOF) { + parser->yychar = yytoken = YYEOF; + YYDPRINTF ((Perl_debug_log, "Now at end of input.\n")); + } + else { + /* 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); + } + + /* If the proper action on seeing token YYTOKEN is to reduce or to + detect an error, take that action. */ + yyn += yytoken; + if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) + goto yydefault; + yyn = yytable[yyn]; + if (yyn <= 0) { + if (yyn == 0 || yyn == YYTABLE_NINF) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + + if (yyn == YYFINAL) + YYACCEPT; + + /* Shift the lookahead token. */ + YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken])); + + /* Discard the token being shifted unless it is eof. */ + if (parser->yychar != YYEOF) + parser->yychar = YYEMPTY; + + YYPUSHSTACK; + ps->state = yyn; + ps->val = parser->yylval; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; +#ifdef DEBUGGING + ps->name = (const char *)(yytname[yytoken]); +#endif + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (parser->yyerrstatus) + parser->yyerrstatus--; + + goto yynewstate; + + + /*-----------------------------------------------------------. + | yydefault -- do the default action for the current state. | + `-----------------------------------------------------------*/ + yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + + /*-----------------------------. + | yyreduce -- Do a reduction. | + `-----------------------------*/ + yyreduce: + /* yyn is the number of a rule to reduce with. */ + parser->yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + "$$ = $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 = 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 */ +#include "perly.act" + + } + + { + int i; + for (i=0; i< parser->yylen; i++) { + SvREFCNT_dec(ps[-i].compcv); + } + } + + 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 + number reduced by. */ + + ps->val = yyval; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; +#ifdef DEBUGGING + ps->name = (const char *)(yytname [yyr1[yyn]]); +#endif + + yyn = yyr1[yyn]; + + 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]; + ps->state = yystate; + + goto yynewstate; + + + /*------------------------------------. + | yyerrlab -- here on detecting error | + `------------------------------------*/ + yyerrlab: + /* If not already recovering from an error, report this error. */ + if (!parser->yyerrstatus) { + yyerror ("syntax error"); + } + + + 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 (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->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); + } + op_free(ps->val.opval); + } + SvREFCNT_dec(ps->compcv); + YYPOPSTACK; + } + YYABORT; + } + + YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); + parser->yychar = YYEMPTY; + + } + + /* Else will try to reuse lookahead token after shifting the error + token. */ + goto yyerrlab1; + + + /*----------------------------------------------------. + | yyerrlab1 -- error raised explicitly by an action. | + `----------------------------------------------------*/ + yyerrlab1: + parser->yyerrstatus = 3; /* Each real token shifted decrements this. */ + + for (;;) { + yyn = yypact[yystate]; + if (yyn != YYPACT_NINF) { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } + + /* Pop the current state because it cannot handle the error token. */ + 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->compcv != PL_compcv) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); + } + op_free(ps->val.opval); + } + SvREFCNT_dec(ps->compcv); + YYPOPSTACK; + yystate = ps->state; + + YY_STACK_PRINT(parser); + } + + if (yyn == YYFINAL) + YYACCEPT; + + YYDPRINTF ((Perl_debug_log, "Shifting error token, ")); + + YYPUSHSTACK; + ps->state = yyn; + ps->val = parser->yylval; + ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); + ps->savestack_ix = PL_savestack_ix; +#ifdef DEBUGGING + ps->name ="<err>"; +#endif + + goto yynewstate; + + + /*-------------------------------------. + | yyacceptlab -- YYACCEPT comes here. | + `-------------------------------------*/ + yyacceptlab: + yyresult = 0; + for (ps=parser->ps; ps > parser->stack; ps--) { + SvREFCNT_dec(ps->compcv); + } + parser->ps = parser->stack; /* disable cleanup */ + goto yyreturn; + + /*-----------------------------------. + | yyabortlab -- YYABORT comes here. | + `-----------------------------------*/ + yyabortlab: + yyresult = 1; + goto yyreturn; + + yyreturn: + LEAVE; /* force parser stack cleanup before we return */ + return yyresult; +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */