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     for (i=0; i< parser->yylen; i++) {
 203         SvREFCNT_dec(ps[-i].compcv);
 204     }
 205     ps -= parser->yylen;
 206
 207     /* now free whole the stack, including the just-reduced ops */
 208
 209     while (ps > parser->stack) {
 210         LEAVE_SCOPE(ps->savestack_ix);
 211         if (yy_type_tab[yystos[ps->state]] == toketype_opval
 212             && ps->val.opval)
 213         {
 214             if (ps->compcv != PL_compcv) {
 215                 PL_compcv = ps->compcv;
 216                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 217             }
 218             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 219             op_free(ps->val.opval);
 220         }
 221         SvREFCNT_dec(ps->compcv);
 222         ps--;
 223     }
 224
 225     Safefree(parser->stack);
 226 }
 227
 228
 229 /*----------.
 230 | yyparse.  |
 231 `----------*/
 232
 233 int
 234 #ifdef PERL_IN_MADLY_C
 235 Perl_madparse (pTHX_ int gramtype)
 236 #else
 237 Perl_yyparse (pTHX_ int gramtype)
 238 #endif
 239 {
 240     dVAR;
 241     int yystate;
 242     int yyn;
 243     int yyresult;
 244
 245     /* Lookahead token as an internal (translated) token number.  */
 246     int yytoken = 0;
 247
 248     yy_parser *parser;      /* the parser object */
 249     yy_stack_frame  *ps;   /* current parser stack frame */
 250
 251 #define YYPOPSTACK   parser->ps = --ps
 252 #define YYPUSHSTACK  parser->ps = ++ps
 253
 254     /* The variable used to return semantic value and location from the
 255           action routines: ie $$.  */
 256     YYSTYPE yyval;
 257
 258 #ifndef PERL_IN_MADLY_C
 259 #  ifdef PERL_MAD
 260     if (PL_madskills)
 261         return madparse(gramtype);
 262 #  endif
 263 #endif
 264
 265     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
 266
 267     parser = PL_parser;
 268
 269     ENTER;  /* force parser state cleanup/restoration before we return */
 270     SAVEPPTR(parser->yylval.pval);
 271     SAVEINT(parser->yychar);
 272     SAVEINT(parser->yyerrstatus);
 273     SAVEINT(parser->stack_size);
 274     SAVEINT(parser->yylen);
 275     SAVEVPTR(parser->stack);
 276     SAVEVPTR(parser->ps);
 277
 278     /* initialise state for this parse */
 279     parser->yychar = gramtype;
 280     parser->yyerrstatus = 0;
 281     parser->stack_size = YYINITDEPTH;
 282     parser->yylen = 0;
 283     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 284     ps = parser->ps = parser->stack;
 285     ps->state = 0;
 286     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
 287
 288 /*------------------------------------------------------------.
 289 | yynewstate -- Push a new state, which is found in yystate.  |
 290 `------------------------------------------------------------*/
 291   yynewstate:
 292
 293     yystate = ps->state;
 294
 295     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 296
 297     parser->yylen = 0;
 298
 299     {
 300         size_t size = ps - parser->stack + 1;
 301
 302         /* grow the stack? We always leave 1 spare slot,
 303          * in case of a '' -> 'foo' reduction */
 304
 305         if (size >= (size_t)parser->stack_size - 1) {
 306             /* this will croak on insufficient memory */
 307             parser->stack_size *= 2;
 308             Renew(parser->stack, parser->stack_size, yy_stack_frame);
 309             ps = parser->ps = parser->stack + size -1;
 310
 311             YYDPRINTF((Perl_debug_log,
 312                             "parser stack size increased to %lu frames\n",
 313                             (unsigned long int)parser->stack_size));
 314         }
 315     }
 316
 317 /* Do appropriate processing given the current state.  */
 318 /* Read a lookahead token if we need one and don't already have one.  */
 319
 320     /* First try to decide what to do without reference to lookahead token.  */
 321
 322     yyn = yypact[yystate];
 323     if (yyn == YYPACT_NINF)
 324         goto yydefault;
 325
 326     /* Not known => get a lookahead token if don't already have one.  */
 327
 328     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
 329     if (parser->yychar == YYEMPTY) {
 330         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
 331 #ifdef PERL_IN_MADLY_C
 332         parser->yychar = PL_madskills ? madlex() : yylex();
 333 #else
 334         parser->yychar = yylex();
 335 #endif
 336
 337 #  ifdef EBCDIC
 338         if (parser->yychar >= 0 && parser->yychar < 255) {
 339             parser->yychar = NATIVE_TO_ASCII(parser->yychar);
 340         }
 341 #  endif
 342     }
 343
 344     if (parser->yychar <= YYEOF) {
 345         parser->yychar = yytoken = YYEOF;
 346         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
 347     }
 348     else {
 349         yytoken = YYTRANSLATE (parser->yychar);
 350         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
 351     }
 352
 353     /* If the proper action on seeing token YYTOKEN is to reduce or to
 354           detect an error, take that action.  */
 355     yyn += yytoken;
 356     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
 357         goto yydefault;
 358     yyn = yytable[yyn];
 359     if (yyn <= 0) {
 360         if (yyn == 0 || yyn == YYTABLE_NINF)
 361             goto yyerrlab;
 362         yyn = -yyn;
 363         goto yyreduce;
 364     }
 365
 366     if (yyn == YYFINAL)
 367         YYACCEPT;
 368
 369     /* Shift the lookahead token.  */
 370     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
 371
 372     /* Discard the token being shifted unless it is eof.  */
 373     if (parser->yychar != YYEOF)
 374         parser->yychar = YYEMPTY;
 375
 376     YYPUSHSTACK;
 377     ps->state   = yyn;
 378     ps->val     = parser->yylval;
 379     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 380     ps->savestack_ix = PL_savestack_ix;
 381 #ifdef DEBUGGING
 382     ps->name    = (const char *)(yytname[yytoken]);
 383 #endif
 384
 385     /* Count tokens shifted since error; after three, turn off error
 386           status.  */
 387     if (parser->yyerrstatus)
 388         parser->yyerrstatus--;
 389
 390     goto yynewstate;
 391
 392
 393   /*-----------------------------------------------------------.
 394   | yydefault -- do the default action for the current state.  |
 395   `-----------------------------------------------------------*/
 396   yydefault:
 397     yyn = yydefact[yystate];
 398     if (yyn == 0)
 399         goto yyerrlab;
 400     goto yyreduce;
 401
 402
 403   /*-----------------------------.
 404   | yyreduce -- Do a reduction.  |
 405   `-----------------------------*/
 406   yyreduce:
 407     /* yyn is the number of a rule to reduce with.  */
 408     parser->yylen = yyr2[yyn];
 409
 410     /* If YYLEN is nonzero, implement the default value of the action:
 411       "$$ = $1".
 412
 413       Otherwise, the following line sets YYVAL to garbage.
 414       This behavior is undocumented and Bison
 415       users should not rely upon it.  Assigning to YYVAL
 416       unconditionally makes the parser a bit smaller, and it avoids a
 417       GCC warning that YYVAL may be used uninitialized.  */
 418     yyval = ps[1-parser->yylen].val;
 419
 420     YY_STACK_PRINT(parser);
 421     YY_REDUCE_PRINT (yyn);
 422
 423     switch (yyn) {
 424
 425
 426 #define dep() deprecate("\"do\" to call subroutines")
 427
 428 #ifdef PERL_IN_MADLY_C
 429 #  define IVAL(i) (i)->tk_lval.ival
 430 #  define PVAL(p) (p)->tk_lval.pval
 431 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
 432 #  define TOKEN_FREE(a) token_free(a)
 433 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
 434 #  define IF_MAD(a,b) (a)
 435 #  define DO_MAD(a) a
 436 #  define MAD
 437 #else
 438 #  define IVAL(i) (i)
 439 #  define PVAL(p) (p)
 440 #  define TOKEN_GETMAD(a,b,c)
 441 #  define TOKEN_FREE(a)
 442 #  define OP_GETMAD(a,b,c)
 443 #  define IF_MAD(a,b) (b)
 444 #  define DO_MAD(a)
 445 #  undef MAD
 446 #endif
 447
 448 /* contains all the rule actions; auto-generated from perly.y */
 449 #include "perly.act"
 450
 451     }
 452
 453     {
 454         int i;
 455         for (i=0; i< parser->yylen; i++) {
 456             SvREFCNT_dec(ps[-i].compcv);
 457         }
 458     }
 459
 460     parser->ps = ps -= (parser->yylen-1);
 461
 462     /* Now shift the result of the reduction.  Determine what state
 463           that goes to, based on the state we popped back to and the rule
 464           number reduced by.  */
 465
 466     ps->val     = yyval;
 467     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 468     ps->savestack_ix = PL_savestack_ix;
 469 #ifdef DEBUGGING
 470     ps->name    = (const char *)(yytname [yyr1[yyn]]);
 471 #endif
 472
 473     yyn = yyr1[yyn];
 474
 475     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
 476     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
 477         yystate = yytable[yystate];
 478     else
 479         yystate = yydefgoto[yyn - YYNTOKENS];
 480     ps->state = yystate;
 481
 482     goto yynewstate;
 483
 484
 485   /*------------------------------------.
 486   | yyerrlab -- here on detecting error |
 487   `------------------------------------*/
 488   yyerrlab:
 489     /* If not already recovering from an error, report this error.  */
 490     if (!parser->yyerrstatus) {
 491         yyerror ("syntax error");
 492     }
 493
 494
 495     if (parser->yyerrstatus == 3) {
 496         /* If just tried and failed to reuse lookahead token after an
 497               error, discard it.  */
 498
 499         /* Return failure if at end of input.  */
 500         if (parser->yychar == YYEOF) {
 501             /* Pop the error token.  */
 502             SvREFCNT_dec(ps->compcv);
 503             YYPOPSTACK;
 504             /* Pop the rest of the stack.  */
 505             while (ps > parser->stack) {
 506                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 507                 LEAVE_SCOPE(ps->savestack_ix);
 508                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
 509                         && ps->val.opval)
 510                 {
 511                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 512                     if (ps->compcv != PL_compcv) {
 513                         PL_compcv = ps->compcv;
 514                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 515                     }
 516                     op_free(ps->val.opval);
 517                 }
 518                 SvREFCNT_dec(ps->compcv);
 519                 YYPOPSTACK;
 520             }
 521             YYABORT;
 522         }
 523
 524         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
 525         if (yy_type_tab[yytoken] == toketype_opval)
 526             op_free(parser->yylval.opval);
 527         parser->yychar = YYEMPTY;
 528
 529     }
 530
 531     /* Else will try to reuse lookahead token after shifting the error
 532           token.  */
 533     goto yyerrlab1;
 534
 535
 536   /*----------------------------------------------------.
 537   | yyerrlab1 -- error raised explicitly by an action.  |
 538   `----------------------------------------------------*/
 539   yyerrlab1:
 540     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
 541
 542     for (;;) {
 543         yyn = yypact[yystate];
 544         if (yyn != YYPACT_NINF) {
 545             yyn += YYTERROR;
 546             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 547                 yyn = yytable[yyn];
 548                 if (0 < yyn)
 549                     break;
 550             }
 551         }
 552
 553         /* Pop the current state because it cannot handle the error token.  */
 554         if (ps == parser->stack)
 555             YYABORT;
 556
 557         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 558         LEAVE_SCOPE(ps->savestack_ix);
 559         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
 560             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 561             if (ps->compcv != PL_compcv) {
 562                 PL_compcv = ps->compcv;
 563                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 564             }
 565             op_free(ps->val.opval);
 566         }
 567         SvREFCNT_dec(ps->compcv);
 568         YYPOPSTACK;
 569         yystate = ps->state;
 570
 571         YY_STACK_PRINT(parser);
 572     }
 573
 574     if (yyn == YYFINAL)
 575         YYACCEPT;
 576
 577     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 578
 579     YYPUSHSTACK;
 580     ps->state   = yyn;
 581     ps->val     = parser->yylval;
 582     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 583     ps->savestack_ix = PL_savestack_ix;
 584 #ifdef DEBUGGING
 585     ps->name    ="<err>";
 586 #endif
 587
 588     goto yynewstate;
 589
 590
 591   /*-------------------------------------.
 592   | yyacceptlab -- YYACCEPT comes here.  |
 593   `-------------------------------------*/
 594   yyacceptlab:
 595     yyresult = 0;
 596     for (ps=parser->ps; ps > parser->stack; ps--) {
 597         SvREFCNT_dec(ps->compcv);
 598     }
 599     parser->ps = parser->stack; /* disable cleanup */
 600     goto yyreturn;
 601
 602   /*-----------------------------------.
 603   | yyabortlab -- YYABORT comes here.  |
 604   `-----------------------------------*/
 605   yyabortlab:
 606     yyresult = 1;
 607     goto yyreturn;
 608
 609   yyreturn:
 610     LEAVE;      /* force parser stack cleanup before we return */
 611     return yyresult;
 612 }
 613
 614 /*
 615  * Local variables:
 616  * c-indentation-style: bsd
 617  * c-basic-offset: 4
 618  * indent-tabs-mode: nil
 619  * End:
 620  *
 621  * ex: set ts=8 sts=4 sw=4 et:
 622  */