perly.c

   1 /*    perly.c
   2  *
   3  *    Copyright (c) 2004, 2005, 2006, 2007, 2008,
   4  *    2009, 2010, 2011 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  *    Note that this file was originally generated as an output from
  10  *    GNU bison version 1.875, but now the code is statically maintained
  11  *    and edited; the bits that are dependent on perly.y are now
  12  *    #included from the files perly.tab and perly.act.
  13  *
  14  *    Here is an important copyright statement from the original, generated
  15  *    file:
  16  *
  17  *      As a special exception, when this file is copied by Bison into a
  18  *      Bison output file, you may use that output file without
  19  *      restriction.  This special exception was added by the Free
  20  *      Software Foundation in version 1.24 of Bison.
  21  *
  22  * Note that this file is also #included in madly.c, to allow compilation
  23  * of a second parser, Perl_madparse, that is identical to Perl_yyparse,
  24  * but which includes extra code for dumping the parse tree.
  25  * This is controlled by the PERL_IN_MADLY_C define.
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_PERLY_C
  30 #include "perl.h"
  31
  32 typedef unsigned char yytype_uint8;
  33 typedef signed char yytype_int8;
  34 typedef unsigned short int yytype_uint16;
  35 typedef short int yytype_int16;
  36 typedef signed char yysigned_char;
  37
  38 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  39 #define YYINITDEPTH 200
  40
  41 #ifdef DEBUGGING
  42 #  define YYDEBUG 1
  43 #else
  44 #  define YYDEBUG 0
  45 #endif
  46
  47 /* contains all the parser state tables; auto-generated from perly.y */
  48 #include "perly.tab"
  49
  50 # define YYSIZE_T size_t
  51
  52 #define YYEOF           0
  53 #define YYTERROR        1
  54
  55 #define YYACCEPT        goto yyacceptlab
  56 #define YYABORT         goto yyabortlab
  57 #define YYERROR         goto yyerrlab1
  58
  59 /* Enable debugging if requested.  */
  60 #ifdef DEBUGGING
  61
  62 #  define yydebug (DEBUG_p_TEST)
  63
  64 #  define YYFPRINTF PerlIO_printf
  65
  66 #  define YYDPRINTF(Args)                       \
  67 do {                                            \
  68     if (yydebug)                                \
  69         YYFPRINTF Args;                         \
  70 } while (0)
  71
  72 #  define YYDSYMPRINTF(Title, Token, Value)                     \
  73 do {                                                            \
  74     if (yydebug) {                                              \
  75         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
  76         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
  77         YYFPRINTF (Perl_debug_log, "\n");                       \
  78     }                                                           \
  79 } while (0)
  80
  81 /*--------------------------------.
  82 | Print this symbol on YYOUTPUT.  |
  83 `--------------------------------*/
  84
  85 static void
  86 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
  87 {
  88     if (yytype < YYNTOKENS) {
  89         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
  90 #   ifdef YYPRINT
  91         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
  92 #   else
  93         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
  94 #   endif
  95     }
  96     else
  97         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
  98
  99     YYFPRINTF (yyoutput, ")");
 100 }
 101
 102
 103 /*  yy_stack_print()
 104  *  print the top 8 items on the parse stack.
 105  */
 106
 107 static void
 108 yy_stack_print (pTHX_ const yy_parser *parser)
 109 {
 110     const yy_stack_frame *ps, *min;
 111
 112     min = parser->ps - 8 + 1;
 113     if (min <= parser->stack)
 114         min = parser->stack + 1;
 115
 116     PerlIO_printf(Perl_debug_log, "\nindex:");
 117     for (ps = min; ps <= parser->ps; ps++)
 118         PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack));
 119
 120     PerlIO_printf(Perl_debug_log, "\nstate:");
 121     for (ps = min; ps <= parser->ps; ps++)
 122         PerlIO_printf(Perl_debug_log, " %8d", ps->state);
 123
 124     PerlIO_printf(Perl_debug_log, "\ntoken:");
 125     for (ps = min; ps <= parser->ps; ps++)
 126         PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
 127
 128     PerlIO_printf(Perl_debug_log, "\nvalue:");
 129     for (ps = min; ps <= parser->ps; ps++) {
 130         switch (yy_type_tab[yystos[ps->state]]) {
 131         case toketype_opval:
 132             PerlIO_printf(Perl_debug_log, " %8.8s",
 133                   ps->val.opval
 134                     ? PL_op_name[ps->val.opval->op_type]
 135                     : "(Nullop)"
 136             );
 137             break;
 138 #ifndef PERL_IN_MADLY_C
 139         case toketype_i_tkval:
 140 #endif
 141         case toketype_ival:
 142             PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
 143             break;
 144         default:
 145             PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
 146         }
 147     }
 148     PerlIO_printf(Perl_debug_log, "\n\n");
 149 }
 150
 151 #  define YY_STACK_PRINT(parser)        \
 152 do {                                    \
 153     if (yydebug && DEBUG_v_TEST)        \
 154         yy_stack_print (aTHX_ parser);  \
 155 } while (0)
 156
 157
 158 /*------------------------------------------------.
 159 | Report that the YYRULE is going to be reduced.  |
 160 `------------------------------------------------*/
 161
 162 static void
 163 yy_reduce_print (pTHX_ int yyrule)
 164 {
 165     int yyi;
 166     const unsigned int yylineno = yyrline[yyrule];
 167     YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
 168                           yyrule - 1, yylineno);
 169     /* Print the symbols being reduced, and their result.  */
 170     for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
 171         YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
 172     YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
 173 }
 174
 175 #  define YY_REDUCE_PRINT(Rule)         \
 176 do {                                    \
 177     if (yydebug)                        \
 178         yy_reduce_print (aTHX_ Rule);           \
 179 } while (0)
 180
 181 #else /* !DEBUGGING */
 182 #  define YYDPRINTF(Args)
 183 #  define YYDSYMPRINTF(Title, Token, Value)
 184 #  define YY_STACK_PRINT(parser)
 185 #  define YY_REDUCE_PRINT(Rule)
 186 #endif /* !DEBUGGING */
 187
 188 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
 189  * parse stack, thus avoiding leaks if we die  */
 190
 191 static void
 192 S_clear_yystack(pTHX_  const yy_parser *parser)
 193 {
 194     yy_stack_frame *ps     = parser->ps;
 195     int i = 0;
 196
 197     if (!parser->stack)
 198         return;
 199
 200     YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
 201
 202     /* Freeing ops on the stack, and the op_latefree / op_latefreed /
 203      * op_attached flags:
 204      *
 205      * When we pop tokens off the stack during error recovery, or when
 206      * we pop all the tokens off the stack after a die during a shift or
 207      * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
 208      * newFOO() functions), then it's possible that some of these tokens are
 209      * of type opval, pointing to an OP. All these ops are orphans; each is
 210      * its own miniature subtree that has not yet been attached to a
 211      * larger tree. In this case, we should clearly free the op (making
 212      * sure, for each op we free that we have PL_comppad pointing to the
 213      * right place for freeing any SVs attached to the op in threaded
 214      * builds.
 215      *
 216      * However, there is a particular problem if we die in newFOO() called
 217      * by a reducing action; e.g.
 218      *
 219      *    foo : bar baz boz
 220      *        { $$ = newFOO($1,$2,$3) }
 221      *
 222      * where
 223      *  OP *newFOO { ....; if (...) croak; .... }
 224      *
 225      * In this case, when we come to clean bar baz and boz off the stack,
 226      * we don't know whether newFOO() has already:
 227      *    * freed them
 228      *    * left them as is
 229      *    * attached them to part of a larger tree
 230      *    * attached them to PL_compcv
 231      *    * attached them to PL_compcv then freed it (as in BEGIN {die } )
 232      *
 233      * To get round this problem, we set the flag op_latefree on every op
 234      * that gets pushed onto the parser stack. If op_free() sees this
 235      * flag, it clears the op and frees any children,, but *doesn't* free
 236      * the op itself; instead it sets the op_latefreed flag. This means
 237      * that we can safely call op_free() multiple times on each stack op.
 238      * So, when clearing the stack, we first, for each op that was being
 239      * reduced, call op_free with op_latefree=1. This ensures that all ops
 240      * hanging off these op are freed, but the reducing ops themselves are
 241      * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
 242      * and free them. A little thought should convince you that this
 243      * two-part approach to the reducing ops should handle the first three
 244      * cases above safely.
 245      *
 246      * In the case of attaching to PL_compcv (currently just newATTRSUB
 247      * does this), then  we set the op_attached flag on the op that has
 248      * been so attached, then avoid doing the final op_free during
 249      * cleanup, on the assumption that it will happen (or has already
 250      * happened) when PL_compcv is freed.
 251      *
 252      * Note this is fairly fragile mechanism. A more robust approach
 253      * would be to use two of these flag bits as 2-bit reference count
 254      * field for each op, indicating whether it is pointed to from:
 255      *   * a parent op
 256      *   * the parser stack
 257      *   * a CV
 258      * but this would involve reworking all code (core and external) that
 259      * manipulate op trees.
 260      *
 261      * XXX DAPM 17/1/07 I've decided its too fragile for now, and so have
 262      * disabled it */
 263
 264 #define DISABLE_STACK_FREE
 265
 266
 267 #ifdef DISABLE_STACK_FREE
 268     for (i=0; i< parser->yylen; i++) {
 269         SvREFCNT_dec(ps[-i].compcv);
 270     }
 271     ps -= parser->yylen;
 272 #else
 273     /* clear any reducing ops (1st pass) */
 274
 275     for (i=0; i< parser->yylen; i++) {
 276         LEAVE_SCOPE(ps[-i].savestack_ix);
 277         if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
 278             && ps[-i].val.opval) {
 279             if ( ! (ps[-i].val.opval->op_attached
 280                     && !ps[-i].val.opval->op_latefreed))
 281             {
 282                 if (ps[-i].compcv != PL_compcv) {
 283                     PL_compcv = ps[-i].compcv;
 284                     PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 285                 }
 286                 op_free(ps[-i].val.opval);
 287             }
 288         }
 289     }
 290 #endif
 291
 292     /* now free whole the stack, including the just-reduced ops */
 293
 294     while (ps > parser->stack) {
 295         LEAVE_SCOPE(ps->savestack_ix);
 296         if (yy_type_tab[yystos[ps->state]] == toketype_opval
 297             && ps->val.opval)
 298         {
 299             if (ps->compcv != PL_compcv) {
 300                 PL_compcv = ps->compcv;
 301                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 302             }
 303             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 304 #ifndef DISABLE_STACK_FREE
 305             ps->val.opval->op_latefree  = 0;
 306             if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
 307 #endif
 308                 op_free(ps->val.opval);
 309         }
 310         SvREFCNT_dec(ps->compcv);
 311         ps--;
 312     }
 313
 314     Safefree(parser->stack);
 315 }
 316
 317
 318 /*----------.
 319 | yyparse.  |
 320 `----------*/
 321
 322 int
 323 #ifdef PERL_IN_MADLY_C
 324 Perl_madparse (pTHX_ int gramtype)
 325 #else
 326 Perl_yyparse (pTHX_ int gramtype)
 327 #endif
 328 {
 329     dVAR;
 330     register int yystate;
 331     register int yyn;
 332     int yyresult;
 333
 334     /* Lookahead token as an internal (translated) token number.  */
 335     int yytoken = 0;
 336
 337     register yy_parser *parser;     /* the parser object */
 338     register yy_stack_frame  *ps;   /* current parser stack frame */
 339
 340 #define YYPOPSTACK   parser->ps = --ps
 341 #define YYPUSHSTACK  parser->ps = ++ps
 342
 343     /* The variable used to return semantic value and location from the
 344           action routines: ie $$.  */
 345     YYSTYPE yyval;
 346
 347 #ifndef PERL_IN_MADLY_C
 348 #  ifdef PERL_MAD
 349     if (PL_madskills)
 350         return madparse(gramtype);
 351 #  endif
 352 #endif
 353
 354     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
 355
 356     parser = PL_parser;
 357
 358     ENTER;  /* force parser state cleanup/restoration before we return */
 359     SAVEPPTR(parser->yylval.pval);
 360     SAVEINT(parser->yychar);
 361     SAVEINT(parser->yyerrstatus);
 362     SAVEINT(parser->stack_size);
 363     SAVEINT(parser->yylen);
 364     SAVEVPTR(parser->stack);
 365     SAVEVPTR(parser->ps);
 366
 367     /* initialise state for this parse */
 368     parser->yychar = gramtype;
 369     parser->yyerrstatus = 0;
 370     parser->stack_size = YYINITDEPTH;
 371     parser->yylen = 0;
 372     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 373     ps = parser->ps = parser->stack;
 374     ps->state = 0;
 375     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
 376
 377 /*------------------------------------------------------------.
 378 | yynewstate -- Push a new state, which is found in yystate.  |
 379 `------------------------------------------------------------*/
 380   yynewstate:
 381
 382     yystate = ps->state;
 383
 384     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 385
 386 #ifndef DISABLE_STACK_FREE
 387     if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) {
 388         ps->val.opval->op_latefree  = 1;
 389         ps->val.opval->op_latefreed = 0;
 390     }
 391 #endif
 392
 393     parser->yylen = 0;
 394
 395     {
 396         size_t size = ps - parser->stack + 1;
 397
 398         /* grow the stack? We always leave 1 spare slot,
 399          * in case of a '' -> 'foo' reduction */
 400
 401         if (size >= (size_t)parser->stack_size - 1) {
 402             /* this will croak on insufficient memory */
 403             parser->stack_size *= 2;
 404             Renew(parser->stack, parser->stack_size, yy_stack_frame);
 405             ps = parser->ps = parser->stack + size -1;
 406
 407             YYDPRINTF((Perl_debug_log,
 408                             "parser stack size increased to %lu frames\n",
 409                             (unsigned long int)parser->stack_size));
 410         }
 411     }
 412
 413 /* Do appropriate processing given the current state.  */
 414 /* Read a lookahead token if we need one and don't already have one.  */
 415
 416     /* First try to decide what to do without reference to lookahead token.  */
 417
 418     yyn = yypact[yystate];
 419     if (yyn == YYPACT_NINF)
 420         goto yydefault;
 421
 422     /* Not known => get a lookahead token if don't already have one.  */
 423
 424     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
 425     if (parser->yychar == YYEMPTY) {
 426         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
 427 #ifdef PERL_IN_MADLY_C
 428         parser->yychar = PL_madskills ? madlex() : yylex();
 429 #else
 430         parser->yychar = yylex();
 431 #endif
 432
 433 #  ifdef EBCDIC
 434         if (parser->yychar >= 0 && parser->yychar < 255) {
 435             parser->yychar = NATIVE_TO_ASCII(parser->yychar);
 436         }
 437 #  endif
 438     }
 439
 440     if (parser->yychar <= YYEOF) {
 441         parser->yychar = yytoken = YYEOF;
 442         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
 443     }
 444     else {
 445         yytoken = YYTRANSLATE (parser->yychar);
 446         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
 447     }
 448
 449     /* If the proper action on seeing token YYTOKEN is to reduce or to
 450           detect an error, take that action.  */
 451     yyn += yytoken;
 452     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
 453         goto yydefault;
 454     yyn = yytable[yyn];
 455     if (yyn <= 0) {
 456         if (yyn == 0 || yyn == YYTABLE_NINF)
 457             goto yyerrlab;
 458         yyn = -yyn;
 459         goto yyreduce;
 460     }
 461
 462     if (yyn == YYFINAL)
 463         YYACCEPT;
 464
 465     /* Shift the lookahead token.  */
 466     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
 467
 468     /* Discard the token being shifted unless it is eof.  */
 469     if (parser->yychar != YYEOF)
 470         parser->yychar = YYEMPTY;
 471
 472     YYPUSHSTACK;
 473     ps->state   = yyn;
 474     ps->val     = parser->yylval;
 475     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 476     ps->savestack_ix = PL_savestack_ix;
 477 #ifdef DEBUGGING
 478     ps->name    = (const char *)(yytname[yytoken]);
 479 #endif
 480
 481     /* Count tokens shifted since error; after three, turn off error
 482           status.  */
 483     if (parser->yyerrstatus)
 484         parser->yyerrstatus--;
 485
 486     goto yynewstate;
 487
 488
 489   /*-----------------------------------------------------------.
 490   | yydefault -- do the default action for the current state.  |
 491   `-----------------------------------------------------------*/
 492   yydefault:
 493     yyn = yydefact[yystate];
 494     if (yyn == 0)
 495         goto yyerrlab;
 496     goto yyreduce;
 497
 498
 499   /*-----------------------------.
 500   | yyreduce -- Do a reduction.  |
 501   `-----------------------------*/
 502   yyreduce:
 503     /* yyn is the number of a rule to reduce with.  */
 504     parser->yylen = yyr2[yyn];
 505
 506     /* If YYLEN is nonzero, implement the default value of the action:
 507       "$$ = $1".
 508
 509       Otherwise, the following line sets YYVAL to garbage.
 510       This behavior is undocumented and Bison
 511       users should not rely upon it.  Assigning to YYVAL
 512       unconditionally makes the parser a bit smaller, and it avoids a
 513       GCC warning that YYVAL may be used uninitialized.  */
 514     yyval = ps[1-parser->yylen].val;
 515
 516     YY_STACK_PRINT(parser);
 517     YY_REDUCE_PRINT (yyn);
 518
 519     switch (yyn) {
 520
 521
 522 #define dep() deprecate("\"do\" to call subroutines")
 523
 524 #ifdef PERL_IN_MADLY_C
 525 #  define IVAL(i) (i)->tk_lval.ival
 526 #  define PVAL(p) (p)->tk_lval.pval
 527 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
 528 #  define TOKEN_FREE(a) token_free(a)
 529 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
 530 #  define IF_MAD(a,b) (a)
 531 #  define DO_MAD(a) a
 532 #  define MAD
 533 #else
 534 #  define IVAL(i) (i)
 535 #  define PVAL(p) (p)
 536 #  define TOKEN_GETMAD(a,b,c)
 537 #  define TOKEN_FREE(a)
 538 #  define OP_GETMAD(a,b,c)
 539 #  define IF_MAD(a,b) (b)
 540 #  define DO_MAD(a)
 541 #  undef MAD
 542 #endif
 543
 544 /* contains all the rule actions; auto-generated from perly.y */
 545 #include "perly.act"
 546
 547     }
 548
 549     /* any just-reduced ops with the op_latefreed flag cleared need to be
 550      * freed; the rest need the flag resetting */
 551     {
 552         int i;
 553         for (i=0; i< parser->yylen; i++) {
 554 #ifndef DISABLE_STACK_FREE
 555             if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
 556                 && ps[-i].val.opval)
 557             {
 558                 ps[-i].val.opval->op_latefree = 0;
 559                 if (ps[-i].val.opval->op_latefreed)
 560                     op_free(ps[-i].val.opval);
 561             }
 562 #endif
 563             SvREFCNT_dec(ps[-i].compcv);
 564         }
 565     }
 566
 567     parser->ps = ps -= (parser->yylen-1);
 568
 569     /* Now shift the result of the reduction.  Determine what state
 570           that goes to, based on the state we popped back to and the rule
 571           number reduced by.  */
 572
 573     ps->val     = yyval;
 574     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 575     ps->savestack_ix = PL_savestack_ix;
 576 #ifdef DEBUGGING
 577     ps->name    = (const char *)(yytname [yyr1[yyn]]);
 578 #endif
 579
 580     yyn = yyr1[yyn];
 581
 582     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
 583     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
 584         yystate = yytable[yystate];
 585     else
 586         yystate = yydefgoto[yyn - YYNTOKENS];
 587     ps->state = yystate;
 588
 589     goto yynewstate;
 590
 591
 592   /*------------------------------------.
 593   | yyerrlab -- here on detecting error |
 594   `------------------------------------*/
 595   yyerrlab:
 596     /* If not already recovering from an error, report this error.  */
 597     if (!parser->yyerrstatus) {
 598         yyerror ("syntax error");
 599     }
 600
 601
 602     if (parser->yyerrstatus == 3) {
 603         /* If just tried and failed to reuse lookahead token after an
 604               error, discard it.  */
 605
 606         /* Return failure if at end of input.  */
 607         if (parser->yychar == YYEOF) {
 608             /* Pop the error token.  */
 609             SvREFCNT_dec(ps->compcv);
 610             YYPOPSTACK;
 611             /* Pop the rest of the stack.  */
 612             while (ps > parser->stack) {
 613                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 614                 LEAVE_SCOPE(ps->savestack_ix);
 615                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
 616                         && ps->val.opval)
 617                 {
 618                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 619                     if (ps->compcv != PL_compcv) {
 620                         PL_compcv = ps->compcv;
 621                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 622                     }
 623                     ps->val.opval->op_latefree  = 0;
 624                     op_free(ps->val.opval);
 625                 }
 626                 SvREFCNT_dec(ps->compcv);
 627                 YYPOPSTACK;
 628             }
 629             YYABORT;
 630         }
 631
 632         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
 633         if (yy_type_tab[yytoken] == toketype_opval)
 634             op_free(parser->yylval.opval);
 635         parser->yychar = YYEMPTY;
 636
 637     }
 638
 639     /* Else will try to reuse lookahead token after shifting the error
 640           token.  */
 641     goto yyerrlab1;
 642
 643
 644   /*----------------------------------------------------.
 645   | yyerrlab1 -- error raised explicitly by an action.  |
 646   `----------------------------------------------------*/
 647   yyerrlab1:
 648     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
 649
 650     for (;;) {
 651         yyn = yypact[yystate];
 652         if (yyn != YYPACT_NINF) {
 653             yyn += YYTERROR;
 654             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 655                 yyn = yytable[yyn];
 656                 if (0 < yyn)
 657                     break;
 658             }
 659         }
 660
 661         /* Pop the current state because it cannot handle the error token.  */
 662         if (ps == parser->stack)
 663             YYABORT;
 664
 665         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 666         LEAVE_SCOPE(ps->savestack_ix);
 667         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
 668             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 669             if (ps->compcv != PL_compcv) {
 670                 PL_compcv = ps->compcv;
 671                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 672             }
 673             ps->val.opval->op_latefree  = 0;
 674             op_free(ps->val.opval);
 675         }
 676         SvREFCNT_dec(ps->compcv);
 677         YYPOPSTACK;
 678         yystate = ps->state;
 679
 680         YY_STACK_PRINT(parser);
 681     }
 682
 683     if (yyn == YYFINAL)
 684         YYACCEPT;
 685
 686     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 687
 688     YYPUSHSTACK;
 689     ps->state   = yyn;
 690     ps->val     = parser->yylval;
 691     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 692     ps->savestack_ix = PL_savestack_ix;
 693 #ifdef DEBUGGING
 694     ps->name    ="<err>";
 695 #endif
 696
 697     goto yynewstate;
 698
 699
 700   /*-------------------------------------.
 701   | yyacceptlab -- YYACCEPT comes here.  |
 702   `-------------------------------------*/
 703   yyacceptlab:
 704     yyresult = 0;
 705     for (ps=parser->ps; ps > parser->stack; ps--) {
 706         SvREFCNT_dec(ps->compcv);
 707     }
 708     parser->ps = parser->stack; /* disable cleanup */
 709     goto yyreturn;
 710
 711   /*-----------------------------------.
 712   | yyabortlab -- YYABORT comes here.  |
 713   `-----------------------------------*/
 714   yyabortlab:
 715     yyresult = 1;
 716     goto yyreturn;
 717
 718   yyreturn:
 719     LEAVE;      /* force parser stack cleanup before we return */
 720     return yyresult;
 721 }
 722
 723 /*
 724  * Local variables:
 725  * c-indentation-style: bsd
 726  * c-basic-offset: 4
 727  * indent-tabs-mode: nil
 728  * End:
 729  *
 730  * ex: set ts=8 sts=4 sw=4 et:
 731  */