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