3 * Copyright (c) 2004, 2005, 2006, 2007, 2008 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;
37 /* YYINITDEPTH -- initial size of the parser's stacks. */
38 #define YYINITDEPTH 200
46 /* contains all the parser state tables; auto-generated from perly.y */
49 # define YYSIZE_T size_t
54 #define YYACCEPT goto yyacceptlab
55 #define YYABORT goto yyabortlab
56 #define YYERROR goto yyerrlab1
58 /* Enable debugging if requested. */
61 # define yydebug (DEBUG_p_TEST)
63 # define YYFPRINTF PerlIO_printf
65 # define YYDPRINTF(Args) \
71 # define YYDSYMPRINTF(Title, Token, Value) \
74 YYFPRINTF (Perl_debug_log, "%s ", Title); \
75 yysymprint (aTHX_ Perl_debug_log, Token, Value); \
76 YYFPRINTF (Perl_debug_log, "\n"); \
80 /*--------------------------------.
81 | Print this symbol on YYOUTPUT. |
82 `--------------------------------*/
85 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
87 if (yytype < YYNTOKENS) {
88 YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
90 YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
92 YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
96 YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
98 YYFPRINTF (yyoutput, ")");
103 * print the top 8 items on the parse stack.
107 yy_stack_print (pTHX_ const yy_parser *parser)
109 const yy_stack_frame *ps, *min;
111 min = parser->ps - 8 + 1;
112 if (min <= parser->stack)
113 min = parser->stack + 1;
115 PerlIO_printf(Perl_debug_log, "\nindex:");
116 for (ps = min; ps <= parser->ps; ps++)
117 PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack));
119 PerlIO_printf(Perl_debug_log, "\nstate:");
120 for (ps = min; ps <= parser->ps; ps++)
121 PerlIO_printf(Perl_debug_log, " %8d", ps->state);
123 PerlIO_printf(Perl_debug_log, "\ntoken:");
124 for (ps = min; ps <= parser->ps; ps++)
125 PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
127 PerlIO_printf(Perl_debug_log, "\nvalue:");
128 for (ps = min; ps <= parser->ps; ps++) {
129 switch (yy_type_tab[yystos[ps->state]]) {
131 PerlIO_printf(Perl_debug_log, " %8.8s",
133 ? PL_op_name[ps->val.opval->op_type]
137 #ifndef PERL_IN_MADLY_C
138 case toketype_p_tkval:
139 PerlIO_printf(Perl_debug_log, " %8.8s",
140 ps->val.pval ? ps->val.pval : "(NULL)");
143 case toketype_i_tkval:
146 PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
149 PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
152 PerlIO_printf(Perl_debug_log, "\n\n");
155 # define YY_STACK_PRINT(parser) \
157 if (yydebug && DEBUG_v_TEST) \
158 yy_stack_print (aTHX_ parser); \
162 /*------------------------------------------------.
163 | Report that the YYRULE is going to be reduced. |
164 `------------------------------------------------*/
167 yy_reduce_print (pTHX_ int yyrule)
170 const unsigned int yylineno = yyrline[yyrule];
171 YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
172 yyrule - 1, yylineno);
173 /* Print the symbols being reduced, and their result. */
174 for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
175 YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
176 YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
179 # define YY_REDUCE_PRINT(Rule) \
182 yy_reduce_print (aTHX_ Rule); \
185 #else /* !DEBUGGING */
186 # define YYDPRINTF(Args)
187 # define YYDSYMPRINTF(Title, Token, Value)
188 # define YY_STACK_PRINT(parser)
189 # define YY_REDUCE_PRINT(Rule)
190 #endif /* !DEBUGGING */
192 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
193 * parse stack, thus avoiding leaks if we die */
196 S_clear_yystack(pTHX_ const yy_parser *parser)
198 yy_stack_frame *ps = parser->ps;
204 YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
206 /* Freeing ops on the stack, and the op_latefree / op_latefreed /
209 * When we pop tokens off the stack during error recovery, or when
210 * we pop all the tokens off the stack after a die during a shift or
211 * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
212 * newFOO() functions), then it's possible that some of these tokens are
213 * of type opval, pointing to an OP. All these ops are orphans; each is
214 * its own miniature subtree that has not yet been attached to a
215 * larger tree. In this case, we should clearly free the op (making
216 * sure, for each op we free that we have PL_comppad pointing to the
217 * right place for freeing any SVs attached to the op in threaded
220 * However, there is a particular problem if we die in newFOO() called
221 * by a reducing action; e.g.
224 * { $$ = newFOO($1,$2,$3) }
227 * OP *newFOO { ....; if (...) croak; .... }
229 * In this case, when we come to clean bar baz and boz off the stack,
230 * we don't know whether newFOO() has already:
233 * * attached them to part of a larger tree
234 * * attached them to PL_compcv
235 * * attached them to PL_compcv then freed it (as in BEGIN {die } )
237 * To get round this problem, we set the flag op_latefree on every op
238 * that gets pushed onto the parser stack. If op_free() sees this
239 * flag, it clears the op and frees any children,, but *doesn't* free
240 * the op itself; instead it sets the op_latefreed flag. This means
241 * that we can safely call op_free() multiple times on each stack op.
242 * So, when clearing the stack, we first, for each op that was being
243 * reduced, call op_free with op_latefree=1. This ensures that all ops
244 * hanging off these op are freed, but the reducing ops themselces are
245 * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
246 * and free them. A little thought should convince you that this
247 * two-part approach to the reducing ops should handle the first three
248 * cases above safely.
250 * In the case of attaching to PL_compcv (currently just newATTRSUB
251 * does this), then we set the op_attached flag on the op that has
252 * been so attached, then avoid doing the final op_free during
253 * cleanup, on the assumption that it will happen (or has already
254 * happened) when PL_compcv is freed.
256 * Note this is fairly fragile mechanism. A more robust approach
257 * would be to use two of these flag bits as 2-bit reference count
258 * field for each op, indicating whether it is pointed to from:
262 * but this would involve reworking all code (core and external) that
263 * manipulate op trees.
265 * XXX DAPM 17/1/07 I've decided its too fragile for now, and so have
268 #define DISABLE_STACK_FREE
271 #ifdef DISABLE_STACK_FREE
272 for (i=0; i< parser->yylen; i++) {
273 SvREFCNT_dec(ps[-i].compcv);
277 /* clear any reducing ops (1st pass) */
279 for (i=0; i< parser->yylen; i++) {
280 LEAVE_SCOPE(ps[-i].savestack_ix);
281 if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
282 && ps[-i].val.opval) {
283 if ( ! (ps[-i].val.opval->op_attached
284 && !ps[-i].val.opval->op_latefreed))
286 if (ps[-i].compcv != PL_compcv) {
287 PL_compcv = ps[-i].compcv;
288 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
290 op_free(ps[-i].val.opval);
296 /* now free whole the stack, including the just-reduced ops */
298 while (ps > parser->stack) {
299 LEAVE_SCOPE(ps->savestack_ix);
300 if (yy_type_tab[yystos[ps->state]] == toketype_opval
303 if (ps->compcv != PL_compcv) {
304 PL_compcv = ps->compcv;
305 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
307 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
308 #ifndef DISABLE_STACK_FREE
309 ps->val.opval->op_latefree = 0;
310 if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
312 op_free(ps->val.opval);
314 SvREFCNT_dec(ps->compcv);
318 Safefree(parser->stack);
327 #ifdef PERL_IN_MADLY_C
328 Perl_madparse (pTHX_ int gramtype)
330 Perl_yyparse (pTHX_ int gramtype)
334 register int yystate;
338 /* Lookahead token as an internal (translated) token number. */
341 register yy_parser *parser; /* the parser object */
342 register yy_stack_frame *ps; /* current parser stack frame */
344 #define YYPOPSTACK parser->ps = --ps
345 #define YYPUSHSTACK parser->ps = ++ps
347 /* The variable used to return semantic value and location from the
348 action routines: ie $$. */
351 #ifndef PERL_IN_MADLY_C
354 return madparse(gramtype);
358 YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
362 ENTER; /* force parser state cleanup/restoration before we return */
363 SAVEPPTR(parser->yylval.pval);
364 SAVEINT(parser->yychar);
365 SAVEINT(parser->yyerrstatus);
366 SAVEINT(parser->stack_size);
367 SAVEINT(parser->yylen);
368 SAVEVPTR(parser->stack);
369 SAVEVPTR(parser->ps);
371 /* initialise state for this parse */
372 parser->yychar = gramtype;
373 parser->yyerrstatus = 0;
374 parser->stack_size = YYINITDEPTH;
376 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
377 ps = parser->ps = parser->stack;
379 SAVEDESTRUCTOR_X(S_clear_yystack, parser);
381 /*------------------------------------------------------------.
382 | yynewstate -- Push a new state, which is found in yystate. |
383 `------------------------------------------------------------*/
388 YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
390 #ifndef DISABLE_STACK_FREE
391 if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) {
392 ps->val.opval->op_latefree = 1;
393 ps->val.opval->op_latefreed = 0;
400 size_t size = ps - parser->stack + 1;
402 /* grow the stack? We always leave 1 spare slot,
403 * in case of a '' -> 'foo' reduction */
405 if (size >= (size_t)parser->stack_size - 1) {
406 /* this will croak on insufficient memory */
407 parser->stack_size *= 2;
408 Renew(parser->stack, parser->stack_size, yy_stack_frame);
409 ps = parser->ps = parser->stack + size -1;
411 YYDPRINTF((Perl_debug_log,
412 "parser stack size increased to %lu frames\n",
413 (unsigned long int)parser->stack_size));
417 /* Do appropriate processing given the current state. */
418 /* Read a lookahead token if we need one and don't already have one. */
420 /* First try to decide what to do without reference to lookahead token. */
422 yyn = yypact[yystate];
423 if (yyn == YYPACT_NINF)
426 /* Not known => get a lookahead token if don't already have one. */
428 /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
429 if (parser->yychar == YYEMPTY) {
430 YYDPRINTF ((Perl_debug_log, "Reading a token: "));
431 #ifdef PERL_IN_MADLY_C
432 parser->yychar = PL_madskills ? madlex() : yylex();
434 parser->yychar = yylex();
438 if (parser->yychar >= 0 && parser->yychar < 255) {
439 parser->yychar = NATIVE_TO_ASCII(parser->yychar);
444 if (parser->yychar <= YYEOF) {
445 parser->yychar = yytoken = YYEOF;
446 YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
449 yytoken = YYTRANSLATE (parser->yychar);
450 YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
453 /* If the proper action on seeing token YYTOKEN is to reduce or to
454 detect an error, take that action. */
456 if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
460 if (yyn == 0 || yyn == YYTABLE_NINF)
469 /* Shift the lookahead token. */
470 YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
472 /* Discard the token being shifted unless it is eof. */
473 if (parser->yychar != YYEOF)
474 parser->yychar = YYEMPTY;
478 ps->val = parser->yylval;
479 ps->compcv = (CV*)SvREFCNT_inc(PL_compcv);
480 ps->savestack_ix = PL_savestack_ix;
482 ps->name = (const char *)(yytname[yytoken]);
485 /* Count tokens shifted since error; after three, turn off error
487 if (parser->yyerrstatus)
488 parser->yyerrstatus--;
493 /*-----------------------------------------------------------.
494 | yydefault -- do the default action for the current state. |
495 `-----------------------------------------------------------*/
497 yyn = yydefact[yystate];
503 /*-----------------------------.
504 | yyreduce -- Do a reduction. |
505 `-----------------------------*/
507 /* yyn is the number of a rule to reduce with. */
508 parser->yylen = yyr2[yyn];
510 /* If YYLEN is nonzero, implement the default value of the action:
513 Otherwise, the following line sets YYVAL to garbage.
514 This behavior is undocumented and Bison
515 users should not rely upon it. Assigning to YYVAL
516 unconditionally makes the parser a bit smaller, and it avoids a
517 GCC warning that YYVAL may be used uninitialized. */
518 yyval = ps[1-parser->yylen].val;
520 YY_STACK_PRINT(parser);
521 YY_REDUCE_PRINT (yyn);
526 #define dep() deprecate("\"do\" to call subroutines")
528 #ifdef PERL_IN_MADLY_C
529 # define IVAL(i) (i)->tk_lval.ival
530 # define PVAL(p) (p)->tk_lval.pval
531 # define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
532 # define TOKEN_FREE(a) token_free(a)
533 # define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
534 # define IF_MAD(a,b) (a)
540 # define TOKEN_GETMAD(a,b,c)
541 # define TOKEN_FREE(a)
542 # define OP_GETMAD(a,b,c)
543 # define IF_MAD(a,b) (b)
548 /* contains all the rule actions; auto-generated from perly.y */
553 /* any just-reduced ops with the op_latefreed flag cleared need to be
554 * freed; the rest need the flag resetting */
557 for (i=0; i< parser->yylen; i++) {
558 #ifndef DISABLE_STACK_FREE
559 if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
562 ps[-i].val.opval->op_latefree = 0;
563 if (ps[-i].val.opval->op_latefreed)
564 op_free(ps[-i].val.opval);
567 SvREFCNT_dec(ps[-i].compcv);
571 parser->ps = ps -= (parser->yylen-1);
573 /* Now shift the result of the reduction. Determine what state
574 that goes to, based on the state we popped back to and the rule
575 number reduced by. */
578 ps->compcv = (CV*)SvREFCNT_inc(PL_compcv);
579 ps->savestack_ix = PL_savestack_ix;
581 ps->name = (const char *)(yytname [yyr1[yyn]]);
586 yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
587 if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
588 yystate = yytable[yystate];
590 yystate = yydefgoto[yyn - YYNTOKENS];
596 /*------------------------------------.
597 | yyerrlab -- here on detecting error |
598 `------------------------------------*/
600 /* If not already recovering from an error, report this error. */
601 if (!parser->yyerrstatus) {
602 yyerror ("syntax error");
606 if (parser->yyerrstatus == 3) {
607 /* If just tried and failed to reuse lookahead token after an
608 error, discard it. */
610 /* Return failure if at end of input. */
611 if (parser->yychar == YYEOF) {
612 /* Pop the error token. */
613 SvREFCNT_dec(ps->compcv);
615 /* Pop the rest of the stack. */
616 while (ps > parser->stack) {
617 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
618 LEAVE_SCOPE(ps->savestack_ix);
619 if (yy_type_tab[yystos[ps->state]] == toketype_opval
622 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
623 if (ps->compcv != PL_compcv) {
624 PL_compcv = ps->compcv;
625 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
627 ps->val.opval->op_latefree = 0;
628 op_free(ps->val.opval);
630 SvREFCNT_dec(ps->compcv);
636 YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
637 if (yy_type_tab[yytoken] == toketype_opval)
638 op_free(parser->yylval.opval);
639 parser->yychar = YYEMPTY;
643 /* Else will try to reuse lookahead token after shifting the error
648 /*----------------------------------------------------.
649 | yyerrlab1 -- error raised explicitly by an action. |
650 `----------------------------------------------------*/
652 parser->yyerrstatus = 3; /* Each real token shifted decrements this. */
655 yyn = yypact[yystate];
656 if (yyn != YYPACT_NINF) {
658 if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
665 /* Pop the current state because it cannot handle the error token. */
666 if (ps == parser->stack)
669 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
670 LEAVE_SCOPE(ps->savestack_ix);
671 if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
672 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
673 if (ps->compcv != PL_compcv) {
674 PL_compcv = ps->compcv;
675 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
677 ps->val.opval->op_latefree = 0;
678 op_free(ps->val.opval);
680 SvREFCNT_dec(ps->compcv);
684 YY_STACK_PRINT(parser);
690 YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
694 ps->val = parser->yylval;
695 ps->compcv = (CV*)SvREFCNT_inc(PL_compcv);
696 ps->savestack_ix = PL_savestack_ix;
704 /*-------------------------------------.
705 | yyacceptlab -- YYACCEPT comes here. |
706 `-------------------------------------*/
709 for (ps=parser->ps; ps > parser->stack; ps--) {
710 SvREFCNT_dec(ps->compcv);
712 parser->ps = parser->stack; /* disable cleanup */
715 /*-----------------------------------.
716 | yyabortlab -- YYABORT comes here. |
717 `-----------------------------------*/
723 LEAVE; /* force parser stack cleanup before we return */
729 * c-indentation-style: bsd
731 * indent-tabs-mode: t
734 * ex: set ts=8 sts=4 sw=4 noet: