3 * Copyright (c) 2004, 2005, 2006, 2007, by Larry Wall and others
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8 * Note that this file was originally generated as an output from
9 * GNU bison version 1.875, but now the code is statically maintained
10 * and edited; the bits that are dependent on perly.y are now
11 * #included from the files perly.tab and perly.act.
13 * Here is an important copyright statement from the original, generated
16 * As a special exception, when this file is copied by Bison into a
17 * Bison output file, you may use that output file without
18 * restriction. This special exception was added by the Free
19 * Software Foundation in version 1.24 of Bison.
21 * Note that this file is also #included in madly.c, to allow compilation
22 * of a second parser, Perl_madparse, that is identical to Perl_yyparse,
23 * but which includes extra code for dumping the parse tree.
24 * This is controlled by the PERL_IN_MADLY_C define.
28 #define PERL_IN_PERLY_C
31 typedef unsigned char yytype_uint8;
32 typedef signed char yytype_int8;
33 typedef unsigned short int yytype_uint16;
34 typedef short int yytype_int16;
35 typedef signed char yysigned_char;
43 /* contains all the parser state tables; auto-generated from perly.y */
46 # define YYSIZE_T size_t
51 #define YYACCEPT goto yyacceptlab
52 #define YYABORT goto yyabortlab
53 #define YYERROR goto yyerrlab1
55 /* Enable debugging if requested. */
58 # define yydebug (DEBUG_p_TEST)
60 # define YYFPRINTF PerlIO_printf
62 # define YYDPRINTF(Args) \
68 # define YYDSYMPRINTF(Title, Token, Value) \
71 YYFPRINTF (Perl_debug_log, "%s ", Title); \
72 yysymprint (aTHX_ Perl_debug_log, Token, Value); \
73 YYFPRINTF (Perl_debug_log, "\n"); \
77 /*--------------------------------.
78 | Print this symbol on YYOUTPUT. |
79 `--------------------------------*/
82 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
84 if (yytype < YYNTOKENS) {
85 YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
87 YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
89 YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
93 YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
95 YYFPRINTF (yyoutput, ")");
100 * print the top 8 items on the parse stack.
104 yy_stack_print (pTHX_ const yy_parser *parser)
106 const yy_stack_frame *ps, *min;
108 min = parser->ps - 8 + 1;
109 if (min <= parser->stack)
110 min = parser->stack + 1;
112 PerlIO_printf(Perl_debug_log, "\nindex:");
113 for (ps = min; ps <= parser->ps; ps++)
114 PerlIO_printf(Perl_debug_log, " %8d", ps - parser->stack);
116 PerlIO_printf(Perl_debug_log, "\nstate:");
117 for (ps = min; ps <= parser->ps; ps++)
118 PerlIO_printf(Perl_debug_log, " %8d", ps->state);
120 PerlIO_printf(Perl_debug_log, "\ntoken:");
121 for (ps = min; ps <= parser->ps; ps++)
122 PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
124 PerlIO_printf(Perl_debug_log, "\nvalue:");
125 for (ps = min; ps <= parser->ps; ps++) {
126 switch (yy_type_tab[yystos[ps->state]]) {
128 PerlIO_printf(Perl_debug_log, " %8.8s",
130 ? PL_op_name[ps->val.opval->op_type]
134 #ifndef PERL_IN_MADLY_C
135 case toketype_p_tkval:
136 PerlIO_printf(Perl_debug_log, " %8.8s",
137 ps->val.pval ? ps->val.pval : "(NULL)");
140 case toketype_i_tkval:
143 PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
146 PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
149 PerlIO_printf(Perl_debug_log, "\n\n");
152 # define YY_STACK_PRINT(parser) \
154 if (yydebug && DEBUG_v_TEST) \
155 yy_stack_print (aTHX_ parser); \
159 /*------------------------------------------------.
160 | Report that the YYRULE is going to be reduced. |
161 `------------------------------------------------*/
164 yy_reduce_print (pTHX_ int yyrule)
167 const unsigned int yylineno = yyrline[yyrule];
168 YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
169 yyrule - 1, yylineno);
170 /* Print the symbols being reduced, and their result. */
171 for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
172 YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
173 YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
176 # define YY_REDUCE_PRINT(Rule) \
179 yy_reduce_print (aTHX_ Rule); \
182 #else /* !DEBUGGING */
183 # define YYDPRINTF(Args)
184 # define YYDSYMPRINTF(Title, Token, Value)
185 # define YY_STACK_PRINT(parser)
186 # define YY_REDUCE_PRINT(Rule)
187 #endif /* !DEBUGGING */
189 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
190 * parse stack, thus avoiding leaks if we die */
193 S_clear_yystack(pTHX_ const yy_parser *parser)
195 yy_stack_frame *ps = parser->ps;
198 if (!parser->stack || ps == parser->stack)
201 YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
203 /* Freeing ops on the stack, and the op_latefree / op_latefreed /
206 * When we pop tokens off the stack during error recovery, or when
207 * we pop all the tokens off the stack after a die during a shift or
208 * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
209 * newFOO() functions), then it's possible that some of these tokens are
210 * of type opval, pointing to an OP. All these ops are orphans; each is
211 * its own miniature subtree that has not yet been attached to a
212 * larger tree. In this case, we should clearly free the op (making
213 * sure, for each op we free that we have PL_comppad pointing to the
214 * right place for freeing any SVs attached to the op in threaded
217 * However, there is a particular problem if we die in newFOO() called
218 * by a reducing action; e.g.
221 * { $$ = newFOO($1,$2,$3) }
224 * OP *newFOO { ....; if (...) croak; .... }
226 * In this case, when we come to clean bar baz and boz off the stack,
227 * we don't know whether newFOO() has already:
230 * * attached them to part of a larger tree
231 * * attached them to PL_compcv
232 * * attached them to PL_compcv then freed it (as in BEGIN {die } )
234 * To get round this problem, we set the flag op_latefree on every op
235 * that gets pushed onto the parser stack. If op_free() sees this
236 * flag, it clears the op and frees any children,, but *doesn't* free
237 * the op itself; instead it sets the op_latefreed flag. This means
238 * that we can safely call op_free() multiple times on each stack op.
239 * So, when clearing the stack, we first, for each op that was being
240 * reduced, call op_free with op_latefree=1. This ensures that all ops
241 * hanging off these op are freed, but the reducing ops themselces are
242 * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
243 * and free them. A little thought should convince you that this
244 * two-part approach to the reducing ops should handle the first three
245 * cases above safely.
247 * In the case of attaching to PL_compcv (currently just newATTRSUB
248 * does this), then we set the op_attached flag on the op that has
249 * been so attached, then avoid doing the final op_free during
250 * cleanup, on the assumption that it will happen (or has already
251 * happened) when PL_compcv is freed.
253 * Note this is fairly fragile mechanism. A more robust approach
254 * would be to use two of these flag bits as 2-bit reference count
255 * field for each op, indicating whether it is pointed to from:
259 * but this would involve reworking all code (core and external) that
260 * manipulate op trees.
263 /* clear any reducing ops (1st pass) */
265 for (i=0; i< parser->yylen; i++) {
266 if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
267 && ps[-i].val.opval) {
268 if ( ! (ps[-i].val.opval->op_attached
269 && !ps[-i].val.opval->op_latefreed))
271 if (ps[-i].comppad != PL_comppad) {
272 PAD_RESTORE_LOCAL(ps[-i].comppad);
274 op_free(ps[-i].val.opval);
279 /* now free whole the stack, including the just-reduced ops */
281 while (ps > parser->stack) {
282 if (yy_type_tab[yystos[ps->state]] == toketype_opval
285 if (ps->comppad != PL_comppad) {
286 PAD_RESTORE_LOCAL(ps->comppad);
288 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
289 ps->val.opval->op_latefree = 0;
290 if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
291 op_free(ps->val.opval);
297 /* delete a parser object */
299 #ifndef PERL_IN_MADLY_C
301 Perl_parser_free(pTHX_ const yy_parser *parser)
303 S_clear_yystack(aTHX_ parser);
304 Safefree(parser->stack);
305 Safefree(parser->lex_brackstack);
306 Safefree(parser->lex_casestack);
307 PL_parser = parser->old_parser;
317 #ifdef PERL_IN_MADLY_C
324 register int yystate;
328 /* Lookahead token as an internal (translated) token number. */
331 register yy_parser *parser; /* the parser object */
332 register yy_stack_frame *ps; /* current parser stack frame */
334 #define YYPOPSTACK parser->ps = --ps
335 #define YYPUSHSTACK parser->ps = ++ps
337 /* The variable used to return semantic value and location from the
338 action routines: ie $$. */
341 #ifndef PERL_IN_MADLY_C
348 YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
353 ENTER; /* force parser free before we return */
356 /*------------------------------------------------------------.
357 | yynewstate -- Push a new state, which is found in yystate. |
358 `------------------------------------------------------------*/
363 YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
365 if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) {
366 ps->val.opval->op_latefree = 1;
367 ps->val.opval->op_latefreed = 0;
373 size_t size = ps - parser->stack + 1;
375 /* grow the stack? We always leave 1 spare slot,
376 * in case of a '' -> 'foo' reduction */
378 if (size >= parser->stack_size - 1) {
379 /* this will croak on insufficient memory */
380 parser->stack_size *= 2;
381 Renew(parser->stack, parser->stack_size, yy_stack_frame);
382 ps = parser->ps = parser->stack + size -1;
384 YYDPRINTF((Perl_debug_log,
385 "parser stack size increased to %lu frames\n",
386 (unsigned long int)parser->stack_size));
390 /* Do appropriate processing given the current state. */
391 /* Read a lookahead token if we need one and don't already have one. */
393 /* First try to decide what to do without reference to lookahead token. */
395 yyn = yypact[yystate];
396 if (yyn == YYPACT_NINF)
399 /* Not known => get a lookahead token if don't already have one. */
401 /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
402 if (parser->yychar == YYEMPTY) {
403 YYDPRINTF ((Perl_debug_log, "Reading a token: "));
404 #ifdef PERL_IN_MADLY_C
405 parser->yychar = PL_madskills ? madlex() : yylex();
407 parser->yychar = yylex();
411 if (parser->yychar >= 0 && parser->yychar < 255) {
412 parser->yychar = NATIVE_TO_ASCII(parser->yychar);
417 if (parser->yychar <= YYEOF) {
418 parser->yychar = yytoken = YYEOF;
419 YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
422 yytoken = YYTRANSLATE (parser->yychar);
423 YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
426 /* If the proper action on seeing token YYTOKEN is to reduce or to
427 detect an error, take that action. */
429 if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
433 if (yyn == 0 || yyn == YYTABLE_NINF)
442 /* Shift the lookahead token. */
443 YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
445 /* Discard the token being shifted unless it is eof. */
446 if (parser->yychar != YYEOF)
447 parser->yychar = YYEMPTY;
451 ps->val = parser->yylval;
452 ps->comppad = PL_comppad;
454 ps->name = (const char *)(yytname[yytoken]);
457 /* Count tokens shifted since error; after three, turn off error
459 if (parser->yyerrstatus)
460 parser->yyerrstatus--;
465 /*-----------------------------------------------------------.
466 | yydefault -- do the default action for the current state. |
467 `-----------------------------------------------------------*/
469 yyn = yydefact[yystate];
475 /*-----------------------------.
476 | yyreduce -- Do a reduction. |
477 `-----------------------------*/
479 /* yyn is the number of a rule to reduce with. */
480 parser->yylen = yyr2[yyn];
482 /* If YYLEN is nonzero, implement the default value of the action:
485 Otherwise, the following line sets YYVAL to garbage.
486 This behavior is undocumented and Bison
487 users should not rely upon it. Assigning to YYVAL
488 unconditionally makes the parser a bit smaller, and it avoids a
489 GCC warning that YYVAL may be used uninitialized. */
490 yyval = ps[1-parser->yylen].val;
492 YY_STACK_PRINT(parser);
493 YY_REDUCE_PRINT (yyn);
498 #define dep() deprecate("\"do\" to call subroutines")
500 #ifdef PERL_IN_MADLY_C
501 # define IVAL(i) (i)->tk_lval.ival
502 # define PVAL(p) (p)->tk_lval.pval
503 # define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
504 # define TOKEN_FREE(a) token_free(a)
505 # define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
506 # define IF_MAD(a,b) (a)
512 # define TOKEN_GETMAD(a,b,c)
513 # define TOKEN_FREE(a)
514 # define OP_GETMAD(a,b,c)
515 # define IF_MAD(a,b) (b)
520 /* contains all the rule actions; auto-generated from perly.y */
525 /* any just-reduced ops with the op_latefreed flag cleared need to be
526 * freed; the rest need the flag resetting */
529 for (i=0; i< parser->yylen; i++) {
530 if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
533 ps[-i].val.opval->op_latefree = 0;
534 if (ps[-i].val.opval->op_latefreed)
535 op_free(ps[-i].val.opval);
540 parser->ps = ps -= (parser->yylen-1);
542 /* Now shift the result of the reduction. Determine what state
543 that goes to, based on the state we popped back to and the rule
544 number reduced by. */
547 ps->comppad = PL_comppad;
549 ps->name = (const char *)(yytname [yyr1[yyn]]);
554 yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
555 if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
556 yystate = yytable[yystate];
558 yystate = yydefgoto[yyn - YYNTOKENS];
564 /*------------------------------------.
565 | yyerrlab -- here on detecting error |
566 `------------------------------------*/
568 /* If not already recovering from an error, report this error. */
569 if (!parser->yyerrstatus) {
570 yyerror ("syntax error");
574 if (parser->yyerrstatus == 3) {
575 /* If just tried and failed to reuse lookahead token after an
576 error, discard it. */
578 /* Return failure if at end of input. */
579 if (parser->yychar == YYEOF) {
580 /* Pop the error token. */
582 /* Pop the rest of the stack. */
583 while (ps > parser->stack) {
584 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
585 if (yy_type_tab[yystos[ps->state]] == toketype_opval
588 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
589 if (ps->comppad != PL_comppad) {
590 PAD_RESTORE_LOCAL(ps->comppad);
592 ps->val.opval->op_latefree = 0;
593 op_free(ps->val.opval);
600 YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
601 parser->yychar = YYEMPTY;
605 /* Else will try to reuse lookahead token after shifting the error
610 /*----------------------------------------------------.
611 | yyerrlab1 -- error raised explicitly by an action. |
612 `----------------------------------------------------*/
614 parser->yyerrstatus = 3; /* Each real token shifted decrements this. */
617 yyn = yypact[yystate];
618 if (yyn != YYPACT_NINF) {
620 if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
627 /* Pop the current state because it cannot handle the error token. */
628 if (ps == parser->stack)
631 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
632 if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
633 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
634 if (ps->comppad != PL_comppad) {
635 PAD_RESTORE_LOCAL(ps->comppad);
637 ps->val.opval->op_latefree = 0;
638 op_free(ps->val.opval);
643 YY_STACK_PRINT(parser);
649 YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
653 ps->val = parser->yylval;
654 ps->comppad = PL_comppad;
662 /*-------------------------------------.
663 | yyacceptlab -- YYACCEPT comes here. |
664 `-------------------------------------*/
667 parser->ps = parser->stack; /* disable cleanup */
670 /*-----------------------------------.
671 | yyabortlab -- YYABORT comes here. |
672 `-----------------------------------*/
678 LEAVE; /* force parser free before we return */
684 * c-indentation-style: bsd
686 * indent-tabs-mode: t
689 * ex: set ts=8 sts=4 sw=4 noet: