perly.c

   1 /*    perly.c
   2  *
   3  *    Copyright (c) 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   4  *
   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.
   7  *
   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.
  12  *
  13  *    Here is an important copyright statement from the original, generated
  14  *    file:
  15  *
  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.
  20  *
  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.
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_PERLY_C
  29 #include "perl.h"
  30
  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;
  36
  37 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  38 #define YYINITDEPTH 200
  39
  40 #ifdef DEBUGGING
  41 #  define YYDEBUG 1
  42 #else
  43 #  define YYDEBUG 0
  44 #endif
  45
  46 /* contains all the parser state tables; auto-generated from perly.y */
  47 #include "perly.tab"
  48
  49 # define YYSIZE_T size_t
  50
  51 #define YYEOF           0
  52 #define YYTERROR        1
  53
  54 #define YYACCEPT        goto yyacceptlab
  55 #define YYABORT         goto yyabortlab
  56 #define YYERROR         goto yyerrlab1
  57
  58 /* Enable debugging if requested.  */
  59 #ifdef DEBUGGING
  60
  61 #  define yydebug (DEBUG_p_TEST)
  62
  63 #  define YYFPRINTF PerlIO_printf
  64
  65 #  define YYDPRINTF(Args)                       \
  66 do {                                            \
  67     if (yydebug)                                \
  68         YYFPRINTF Args;                         \
  69 } while (0)
  70
  71 #  define YYDSYMPRINTF(Title, Token, Value)                     \
  72 do {                                                            \
  73     if (yydebug) {                                              \
  74         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
  75         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
  76         YYFPRINTF (Perl_debug_log, "\n");                       \
  77     }                                                           \
  78 } while (0)
  79
  80 /*--------------------------------.
  81 | Print this symbol on YYOUTPUT.  |
  82 `--------------------------------*/
  83
  84 static void
  85 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
  86 {
  87     if (yytype < YYNTOKENS) {
  88         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
  89 #   ifdef YYPRINT
  90         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
  91 #   else
  92         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
  93 #   endif
  94     }
  95     else
  96         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
  97
  98     YYFPRINTF (yyoutput, ")");
  99 }
 100
 101
 102 /*  yy_stack_print()
 103  *  print the top 8 items on the parse stack.
 104  */
 105
 106 static void
 107 yy_stack_print (pTHX_ const yy_parser *parser)
 108 {
 109     const yy_stack_frame *ps, *min;
 110
 111     min = parser->ps - 8 + 1;
 112     if (min <= parser->stack)
 113         min = parser->stack + 1;
 114
 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));
 118
 119     PerlIO_printf(Perl_debug_log, "\nstate:");
 120     for (ps = min; ps <= parser->ps; ps++)
 121         PerlIO_printf(Perl_debug_log, " %8d", ps->state);
 122
 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);
 126
 127     PerlIO_printf(Perl_debug_log, "\nvalue:");
 128     for (ps = min; ps <= parser->ps; ps++) {
 129         switch (yy_type_tab[yystos[ps->state]]) {
 130         case toketype_opval:
 131             PerlIO_printf(Perl_debug_log, " %8.8s",
 132                   ps->val.opval
 133                     ? PL_op_name[ps->val.opval->op_type]
 134                     : "(Nullop)"
 135             );
 136             break;
 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)");
 141             break;
 142
 143         case toketype_i_tkval:
 144 #endif
 145         case toketype_ival:
 146             PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
 147             break;
 148         default:
 149             PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
 150         }
 151     }
 152     PerlIO_printf(Perl_debug_log, "\n\n");
 153 }
 154
 155 #  define YY_STACK_PRINT(parser)        \
 156 do {                                    \
 157     if (yydebug && DEBUG_v_TEST)        \
 158         yy_stack_print (aTHX_ parser);  \
 159 } while (0)
 160
 161
 162 /*------------------------------------------------.
 163 | Report that the YYRULE is going to be reduced.  |
 164 `------------------------------------------------*/
 165
 166 static void
 167 yy_reduce_print (pTHX_ int yyrule)
 168 {
 169     int yyi;
 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]]);
 177 }
 178
 179 #  define YY_REDUCE_PRINT(Rule)         \
 180 do {                                    \
 181     if (yydebug)                        \
 182         yy_reduce_print (aTHX_ Rule);           \
 183 } while (0)
 184
 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 */
 191
 192 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
 193  * parse stack, thus avoiding leaks if we die  */
 194
 195 static void
 196 S_clear_yystack(pTHX_  const yy_parser *parser)
 197 {
 198     yy_stack_frame *ps     = parser->ps;
 199     int i = 0;
 200
 201     if (!parser->stack)
 202         return;
 203
 204     YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
 205
 206     /* Freeing ops on the stack, and the op_latefree / op_latefreed /
 207      * op_attached flags:
 208      *
 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
 218      * builds.
 219      *
 220      * However, there is a particular problem if we die in newFOO() called
 221      * by a reducing action; e.g.
 222      *
 223      *    foo : bar baz boz
 224      *        { $$ = newFOO($1,$2,$3) }
 225      *
 226      * where
 227      *  OP *newFOO { ....; if (...) croak; .... }
 228      *
 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:
 231      *    * freed them
 232      *    * left them as is
 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 } )
 236      *
 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.
 249      *
 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.
 255      *
 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:
 259      *   * a parent op
 260      *   * the parser stack
 261      *   * a CV
 262      * but this would involve reworking all code (core and external) that
 263      * manipulate op trees.
 264      *
 265      * XXX DAPM 17/1/07 I've decided its too fragile for now, and so have
 266      * disabled it */
 267
 268 #define DISABLE_STACK_FREE
 269
 270
 271 #ifdef DISABLE_STACK_FREE
 272     for (i=0; i< parser->yylen; i++) {
 273         SvREFCNT_dec(ps[-i].compcv);
 274     }
 275     ps -= parser->yylen;
 276 #else
 277     /* clear any reducing ops (1st pass) */
 278
 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))
 285             {
 286                 if (ps[-i].compcv != PL_compcv) {
 287                     PL_compcv = ps[-i].compcv;
 288                     PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 289                 }
 290                 op_free(ps[-i].val.opval);
 291             }
 292         }
 293     }
 294 #endif
 295
 296     /* now free whole the stack, including the just-reduced ops */
 297
 298     while (ps > parser->stack) {
 299         LEAVE_SCOPE(ps->savestack_ix);
 300         if (yy_type_tab[yystos[ps->state]] == toketype_opval
 301             && ps->val.opval)
 302         {
 303             if (ps->compcv != PL_compcv) {
 304                 PL_compcv = ps->compcv;
 305                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 306             }
 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))
 311 #endif
 312                 op_free(ps->val.opval);
 313         }
 314         SvREFCNT_dec(ps->compcv);
 315         ps--;
 316     }
 317
 318     Safefree(parser->stack);
 319 }
 320
 321
 322 /*----------.
 323 | yyparse.  |
 324 `----------*/
 325
 326 int
 327 #ifdef PERL_IN_MADLY_C
 328 Perl_madparse (pTHX_ int gramtype)
 329 #else
 330 Perl_yyparse (pTHX_ int gramtype)
 331 #endif
 332 {
 333     dVAR;
 334     register int yystate;
 335     register int yyn;
 336     int yyresult;
 337
 338     /* Lookahead token as an internal (translated) token number.  */
 339     int yytoken = 0;
 340
 341     register yy_parser *parser;     /* the parser object */
 342     register yy_stack_frame  *ps;   /* current parser stack frame */
 343
 344 #define YYPOPSTACK   parser->ps = --ps
 345 #define YYPUSHSTACK  parser->ps = ++ps
 346
 347     /* The variable used to return semantic value and location from the
 348           action routines: ie $$.  */
 349     YYSTYPE yyval;
 350
 351 #ifndef PERL_IN_MADLY_C
 352 #  ifdef PERL_MAD
 353     if (PL_madskills)
 354         return madparse(gramtype);
 355 #  endif
 356 #endif
 357
 358     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
 359
 360     parser = PL_parser;
 361
 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);
 370
 371     /* initialise state for this parse */
 372     parser->yychar = gramtype;
 373     parser->yyerrstatus = 0;
 374     parser->stack_size = YYINITDEPTH;
 375     parser->yylen = 0;
 376     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 377     ps = parser->ps = parser->stack;
 378     ps->state = 0;
 379     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
 380
 381 /*------------------------------------------------------------.
 382 | yynewstate -- Push a new state, which is found in yystate.  |
 383 `------------------------------------------------------------*/
 384   yynewstate:
 385
 386     yystate = ps->state;
 387
 388     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 389
 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;
 394     }
 395 #endif
 396
 397     parser->yylen = 0;
 398
 399     {
 400         size_t size = ps - parser->stack + 1;
 401
 402         /* grow the stack? We always leave 1 spare slot,
 403          * in case of a '' -> 'foo' reduction */
 404
 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;
 410
 411             YYDPRINTF((Perl_debug_log,
 412                             "parser stack size increased to %lu frames\n",
 413                             (unsigned long int)parser->stack_size));
 414         }
 415     }
 416
 417 /* Do appropriate processing given the current state.  */
 418 /* Read a lookahead token if we need one and don't already have one.  */
 419
 420     /* First try to decide what to do without reference to lookahead token.  */
 421
 422     yyn = yypact[yystate];
 423     if (yyn == YYPACT_NINF)
 424         goto yydefault;
 425
 426     /* Not known => get a lookahead token if don't already have one.  */
 427
 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();
 433 #else
 434         parser->yychar = yylex();
 435 #endif
 436
 437 #  ifdef EBCDIC
 438         if (parser->yychar >= 0 && parser->yychar < 255) {
 439             parser->yychar = NATIVE_TO_ASCII(parser->yychar);
 440         }
 441 #  endif
 442     }
 443
 444     if (parser->yychar <= YYEOF) {
 445         parser->yychar = yytoken = YYEOF;
 446         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
 447     }
 448     else {
 449         yytoken = YYTRANSLATE (parser->yychar);
 450         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
 451     }
 452
 453     /* If the proper action on seeing token YYTOKEN is to reduce or to
 454           detect an error, take that action.  */
 455     yyn += yytoken;
 456     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
 457         goto yydefault;
 458     yyn = yytable[yyn];
 459     if (yyn <= 0) {
 460         if (yyn == 0 || yyn == YYTABLE_NINF)
 461             goto yyerrlab;
 462         yyn = -yyn;
 463         goto yyreduce;
 464     }
 465
 466     if (yyn == YYFINAL)
 467         YYACCEPT;
 468
 469     /* Shift the lookahead token.  */
 470     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
 471
 472     /* Discard the token being shifted unless it is eof.  */
 473     if (parser->yychar != YYEOF)
 474         parser->yychar = YYEMPTY;
 475
 476     YYPUSHSTACK;
 477     ps->state   = yyn;
 478     ps->val     = parser->yylval;
 479     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 480     ps->savestack_ix = PL_savestack_ix;
 481 #ifdef DEBUGGING
 482     ps->name    = (const char *)(yytname[yytoken]);
 483 #endif
 484
 485     /* Count tokens shifted since error; after three, turn off error
 486           status.  */
 487     if (parser->yyerrstatus)
 488         parser->yyerrstatus--;
 489
 490     goto yynewstate;
 491
 492
 493   /*-----------------------------------------------------------.
 494   | yydefault -- do the default action for the current state.  |
 495   `-----------------------------------------------------------*/
 496   yydefault:
 497     yyn = yydefact[yystate];
 498     if (yyn == 0)
 499         goto yyerrlab;
 500     goto yyreduce;
 501
 502
 503   /*-----------------------------.
 504   | yyreduce -- Do a reduction.  |
 505   `-----------------------------*/
 506   yyreduce:
 507     /* yyn is the number of a rule to reduce with.  */
 508     parser->yylen = yyr2[yyn];
 509
 510     /* If YYLEN is nonzero, implement the default value of the action:
 511       "$$ = $1".
 512
 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;
 519
 520     YY_STACK_PRINT(parser);
 521     YY_REDUCE_PRINT (yyn);
 522
 523     switch (yyn) {
 524
 525
 526 #define dep() deprecate("\"do\" to call subroutines")
 527
 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)
 535 #  define DO_MAD(a) a
 536 #  define MAD
 537 #else
 538 #  define IVAL(i) (i)
 539 #  define PVAL(p) (p)
 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)
 544 #  define DO_MAD(a)
 545 #  undef MAD
 546 #endif
 547
 548 /* contains all the rule actions; auto-generated from perly.y */
 549 #include "perly.act"
 550
 551     }
 552
 553     /* any just-reduced ops with the op_latefreed flag cleared need to be
 554      * freed; the rest need the flag resetting */
 555     {
 556         int i;
 557         for (i=0; i< parser->yylen; i++) {
 558 #ifndef DISABLE_STACK_FREE
 559             if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
 560                 && ps[-i].val.opval)
 561             {
 562                 ps[-i].val.opval->op_latefree = 0;
 563                 if (ps[-i].val.opval->op_latefreed)
 564                     op_free(ps[-i].val.opval);
 565             }
 566 #endif
 567             SvREFCNT_dec(ps[-i].compcv);
 568         }
 569     }
 570
 571     parser->ps = ps -= (parser->yylen-1);
 572
 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.  */
 576
 577     ps->val     = yyval;
 578     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 579     ps->savestack_ix = PL_savestack_ix;
 580 #ifdef DEBUGGING
 581     ps->name    = (const char *)(yytname [yyr1[yyn]]);
 582 #endif
 583
 584     yyn = yyr1[yyn];
 585
 586     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
 587     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
 588         yystate = yytable[yystate];
 589     else
 590         yystate = yydefgoto[yyn - YYNTOKENS];
 591     ps->state = yystate;
 592
 593     goto yynewstate;
 594
 595
 596   /*------------------------------------.
 597   | yyerrlab -- here on detecting error |
 598   `------------------------------------*/
 599   yyerrlab:
 600     /* If not already recovering from an error, report this error.  */
 601     if (!parser->yyerrstatus) {
 602         yyerror ("syntax error");
 603     }
 604
 605
 606     if (parser->yyerrstatus == 3) {
 607         /* If just tried and failed to reuse lookahead token after an
 608               error, discard it.  */
 609
 610         /* Return failure if at end of input.  */
 611         if (parser->yychar == YYEOF) {
 612             /* Pop the error token.  */
 613             SvREFCNT_dec(ps->compcv);
 614             YYPOPSTACK;
 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
 620                         && ps->val.opval)
 621                 {
 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);
 626                     }
 627                     ps->val.opval->op_latefree  = 0;
 628                     op_free(ps->val.opval);
 629                 }
 630                 SvREFCNT_dec(ps->compcv);
 631                 YYPOPSTACK;
 632             }
 633             YYABORT;
 634         }
 635
 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;
 640
 641     }
 642
 643     /* Else will try to reuse lookahead token after shifting the error
 644           token.  */
 645     goto yyerrlab1;
 646
 647
 648   /*----------------------------------------------------.
 649   | yyerrlab1 -- error raised explicitly by an action.  |
 650   `----------------------------------------------------*/
 651   yyerrlab1:
 652     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
 653
 654     for (;;) {
 655         yyn = yypact[yystate];
 656         if (yyn != YYPACT_NINF) {
 657             yyn += YYTERROR;
 658             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 659                 yyn = yytable[yyn];
 660                 if (0 < yyn)
 661                     break;
 662             }
 663         }
 664
 665         /* Pop the current state because it cannot handle the error token.  */
 666         if (ps == parser->stack)
 667             YYABORT;
 668
 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);
 676             }
 677             ps->val.opval->op_latefree  = 0;
 678             op_free(ps->val.opval);
 679         }
 680         SvREFCNT_dec(ps->compcv);
 681         YYPOPSTACK;
 682         yystate = ps->state;
 683
 684         YY_STACK_PRINT(parser);
 685     }
 686
 687     if (yyn == YYFINAL)
 688         YYACCEPT;
 689
 690     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 691
 692     YYPUSHSTACK;
 693     ps->state   = yyn;
 694     ps->val     = parser->yylval;
 695     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 696     ps->savestack_ix = PL_savestack_ix;
 697 #ifdef DEBUGGING
 698     ps->name    ="<err>";
 699 #endif
 700
 701     goto yynewstate;
 702
 703
 704   /*-------------------------------------.
 705   | yyacceptlab -- YYACCEPT comes here.  |
 706   `-------------------------------------*/
 707   yyacceptlab:
 708     yyresult = 0;
 709     for (ps=parser->ps; ps > parser->stack; ps--) {
 710         SvREFCNT_dec(ps->compcv);
 711     }
 712     parser->ps = parser->stack; /* disable cleanup */
 713     goto yyreturn;
 714
 715   /*-----------------------------------.
 716   | yyabortlab -- YYABORT comes here.  |
 717   `-----------------------------------*/
 718   yyabortlab:
 719     yyresult = 1;
 720     goto yyreturn;
 721
 722   yyreturn:
 723     LEAVE;      /* force parser stack cleanup before we return */
 724     return yyresult;
 725 }
 726
 727 /*
 728  * Local variables:
 729  * c-indentation-style: bsd
 730  * c-basic-offset: 4
 731  * indent-tabs-mode: t
 732  * End:
 733  *
 734  * ex: set ts=8 sts=4 sw=4 noet:
 735  */