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 #include "feature.h"
  32
  33 typedef unsigned char yytype_uint8;
  34 typedef signed char yytype_int8;
  35 typedef unsigned short int yytype_uint16;
  36 typedef short int yytype_int16;
  37 typedef signed char yysigned_char;
  38
  39 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  40 #define YYINITDEPTH 200
  41
  42 #ifdef YYDEBUG
  43 #  undef YYDEBUG
  44 #endif
  45 #ifdef DEBUGGING
  46 #  define YYDEBUG 1
  47 #else
  48 #  define YYDEBUG 0
  49 #endif
  50
  51 #ifndef YY_NULL
  52 # define YY_NULL 0
  53 #endif
  54
  55 /* contains all the parser state tables; auto-generated from perly.y */
  56 #include "perly.tab"
  57
  58 # define YYSIZE_T size_t
  59
  60 #define YYEOF           0
  61 #define YYTERROR        1
  62
  63 #define YYACCEPT        goto yyacceptlab
  64 #define YYABORT         goto yyabortlab
  65 #define YYERROR         goto yyerrlab1
  66
  67 /* Enable debugging if requested.  */
  68 #ifdef DEBUGGING
  69
  70 #  define yydebug (DEBUG_p_TEST)
  71
  72 #  define YYFPRINTF PerlIO_printf
  73
  74 #  define YYDPRINTF(Args)                       \
  75 do {                                            \
  76     if (yydebug)                                \
  77         YYFPRINTF Args;                         \
  78 } while (0)
  79
  80 #  define YYDSYMPRINTF(Title, Token, Value)                     \
  81 do {                                                            \
  82     if (yydebug) {                                              \
  83         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
  84         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
  85         YYFPRINTF (Perl_debug_log, "\n");                       \
  86     }                                                           \
  87 } while (0)
  88
  89 /*--------------------------------.
  90 | Print this symbol on YYOUTPUT.  |
  91 `--------------------------------*/
  92
  93 static void
  94 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
  95 {
  96     if (yytype < YYNTOKENS) {
  97         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
  98 #   ifdef YYPRINT
  99         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
 100 #   else
 101         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
 102 #   endif
 103     }
 104     else
 105         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
 106
 107     YYFPRINTF (yyoutput, ")");
 108 }
 109
 110
 111 /*  yy_stack_print()
 112  *  print the top 8 items on the parse stack.
 113  */
 114
 115 static void
 116 yy_stack_print (pTHX_ const yy_parser *parser)
 117 {
 118     const yy_stack_frame *ps, *min;
 119
 120     min = parser->ps - 8 + 1;
 121     if (min <= parser->stack)
 122         min = parser->stack + 1;
 123
 124     PerlIO_printf(Perl_debug_log, "\nindex:");
 125     for (ps = min; ps <= parser->ps; ps++)
 126         PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack));
 127
 128     PerlIO_printf(Perl_debug_log, "\nstate:");
 129     for (ps = min; ps <= parser->ps; ps++)
 130         PerlIO_printf(Perl_debug_log, " %8d", ps->state);
 131
 132     PerlIO_printf(Perl_debug_log, "\ntoken:");
 133     for (ps = min; ps <= parser->ps; ps++)
 134         PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
 135
 136     PerlIO_printf(Perl_debug_log, "\nvalue:");
 137     for (ps = min; ps <= parser->ps; ps++) {
 138         switch (yy_type_tab[yystos[ps->state]]) {
 139         case toketype_opval:
 140             PerlIO_printf(Perl_debug_log, " %8.8s",
 141                   ps->val.opval
 142                     ? PL_op_name[ps->val.opval->op_type]
 143                     : "(Nullop)"
 144             );
 145             break;
 146 #ifndef PERL_IN_MADLY_C
 147         case toketype_i_tkval:
 148 #endif
 149         case toketype_ival:
 150             PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
 151             break;
 152         default:
 153             PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
 154         }
 155     }
 156     PerlIO_printf(Perl_debug_log, "\n\n");
 157 }
 158
 159 #  define YY_STACK_PRINT(parser)        \
 160 do {                                    \
 161     if (yydebug && DEBUG_v_TEST)        \
 162         yy_stack_print (aTHX_ parser);  \
 163 } while (0)
 164
 165
 166 /*------------------------------------------------.
 167 | Report that the YYRULE is going to be reduced.  |
 168 `------------------------------------------------*/
 169
 170 static void
 171 yy_reduce_print (pTHX_ int yyrule)
 172 {
 173     int yyi;
 174     const unsigned int yylineno = yyrline[yyrule];
 175     YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
 176                           yyrule - 1, yylineno);
 177     /* Print the symbols being reduced, and their result.  */
 178     for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
 179         YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
 180     YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
 181 }
 182
 183 #  define YY_REDUCE_PRINT(Rule)         \
 184 do {                                    \
 185     if (yydebug)                        \
 186         yy_reduce_print (aTHX_ Rule);           \
 187 } while (0)
 188
 189 #else /* !DEBUGGING */
 190 #  define YYDPRINTF(Args)
 191 #  define YYDSYMPRINTF(Title, Token, Value)
 192 #  define YY_STACK_PRINT(parser)
 193 #  define YY_REDUCE_PRINT(Rule)
 194 #endif /* !DEBUGGING */
 195
 196 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
 197  * parse stack, thus avoiding leaks if we die  */
 198
 199 static void
 200 S_clear_yystack(pTHX_  const yy_parser *parser)
 201 {
 202     yy_stack_frame *ps     = parser->ps;
 203     int i = 0;
 204
 205     if (!parser->stack)
 206         return;
 207
 208     YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
 209
 210     for (i=0; i< parser->yylen; i++) {
 211         SvREFCNT_dec(ps[-i].compcv);
 212     }
 213     ps -= parser->yylen;
 214
 215     /* now free whole the stack, including the just-reduced ops */
 216
 217     while (ps > parser->stack) {
 218         LEAVE_SCOPE(ps->savestack_ix);
 219         if (yy_type_tab[yystos[ps->state]] == toketype_opval
 220             && ps->val.opval)
 221         {
 222             if (ps->compcv != PL_compcv) {
 223                 PL_compcv = ps->compcv;
 224                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 225                 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
 226             }
 227             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 228             op_free(ps->val.opval);
 229         }
 230         SvREFCNT_dec(ps->compcv);
 231         ps--;
 232     }
 233
 234     Safefree(parser->stack);
 235 }
 236
 237
 238 /*----------.
 239 | yyparse.  |
 240 `----------*/
 241
 242 int
 243 #ifdef PERL_IN_MADLY_C
 244 Perl_madparse (pTHX_ int gramtype)
 245 #else
 246 Perl_yyparse (pTHX_ int gramtype)
 247 #endif
 248 {
 249     dVAR;
 250     int yystate;
 251     int yyn;
 252     int yyresult;
 253
 254     /* Lookahead token as an internal (translated) token number.  */
 255     int yytoken = 0;
 256
 257     yy_parser *parser;      /* the parser object */
 258     yy_stack_frame  *ps;   /* current parser stack frame */
 259
 260 #define YYPOPSTACK   parser->ps = --ps
 261 #define YYPUSHSTACK  parser->ps = ++ps
 262
 263     /* The variable used to return semantic value and location from the
 264           action routines: ie $$.  */
 265     YYSTYPE yyval;
 266
 267 #ifndef PERL_IN_MADLY_C
 268 #  ifdef PERL_MAD
 269     if (PL_madskills)
 270         return madparse(gramtype);
 271 #  endif
 272 #endif
 273
 274     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
 275
 276     parser = PL_parser;
 277
 278     ENTER;  /* force parser state cleanup/restoration before we return */
 279     SAVEPPTR(parser->yylval.pval);
 280     SAVEINT(parser->yychar);
 281     SAVEINT(parser->yyerrstatus);
 282     SAVEINT(parser->stack_size);
 283     SAVEINT(parser->yylen);
 284     SAVEVPTR(parser->stack);
 285     SAVEVPTR(parser->ps);
 286
 287     /* initialise state for this parse */
 288     parser->yychar = gramtype;
 289     parser->yyerrstatus = 0;
 290     parser->stack_size = YYINITDEPTH;
 291     parser->yylen = 0;
 292     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 293     ps = parser->ps = parser->stack;
 294     ps->state = 0;
 295     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
 296
 297 /*------------------------------------------------------------.
 298 | yynewstate -- Push a new state, which is found in yystate.  |
 299 `------------------------------------------------------------*/
 300   yynewstate:
 301
 302     yystate = ps->state;
 303
 304     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 305
 306     parser->yylen = 0;
 307
 308     {
 309         size_t size = ps - parser->stack + 1;
 310
 311         /* grow the stack? We always leave 1 spare slot,
 312          * in case of a '' -> 'foo' reduction */
 313
 314         if (size >= (size_t)parser->stack_size - 1) {
 315             /* this will croak on insufficient memory */
 316             parser->stack_size *= 2;
 317             Renew(parser->stack, parser->stack_size, yy_stack_frame);
 318             ps = parser->ps = parser->stack + size -1;
 319
 320             YYDPRINTF((Perl_debug_log,
 321                             "parser stack size increased to %lu frames\n",
 322                             (unsigned long int)parser->stack_size));
 323         }
 324     }
 325
 326 /* Do appropriate processing given the current state.  */
 327 /* Read a lookahead token if we need one and don't already have one.  */
 328
 329     /* First try to decide what to do without reference to lookahead token.  */
 330
 331     yyn = yypact[yystate];
 332     if (yyn == YYPACT_NINF)
 333         goto yydefault;
 334
 335     /* Not known => get a lookahead token if don't already have one.  */
 336
 337     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
 338     if (parser->yychar == YYEMPTY) {
 339         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
 340 #ifdef PERL_IN_MADLY_C
 341         parser->yychar = PL_madskills ? madlex() : yylex();
 342 #else
 343         parser->yychar = yylex();
 344 #endif
 345
 346 /* perly.tab is shipped based on an ASCII system; if it were to be regenerated
 347  * on a platform that doesn't use ASCII, this translation back would need to be
 348  * removed */
 349 #  ifdef EBCDIC
 350         if (parser->yychar >= 0 && parser->yychar < 255) {
 351             parser->yychar = NATIVE_TO_LATIN1(parser->yychar);
 352         }
 353 #  endif
 354     }
 355
 356     if (parser->yychar <= YYEOF) {
 357         parser->yychar = yytoken = YYEOF;
 358         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
 359     }
 360     else {
 361         yytoken = YYTRANSLATE (parser->yychar);
 362         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
 363     }
 364
 365     /* If the proper action on seeing token YYTOKEN is to reduce or to
 366           detect an error, take that action.  */
 367     yyn += yytoken;
 368     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
 369         goto yydefault;
 370     yyn = yytable[yyn];
 371     if (yyn <= 0) {
 372         if (yyn == 0 || yyn == YYTABLE_NINF)
 373             goto yyerrlab;
 374         yyn = -yyn;
 375         goto yyreduce;
 376     }
 377
 378     if (yyn == YYFINAL)
 379         YYACCEPT;
 380
 381     /* Shift the lookahead token.  */
 382     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
 383
 384     /* Discard the token being shifted unless it is eof.  */
 385     if (parser->yychar != YYEOF)
 386         parser->yychar = YYEMPTY;
 387
 388     YYPUSHSTACK;
 389     ps->state   = yyn;
 390     ps->val     = parser->yylval;
 391     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 392     ps->savestack_ix = PL_savestack_ix;
 393 #ifdef DEBUGGING
 394     ps->name    = (const char *)(yytname[yytoken]);
 395 #endif
 396
 397     /* Count tokens shifted since error; after three, turn off error
 398           status.  */
 399     if (parser->yyerrstatus)
 400         parser->yyerrstatus--;
 401
 402     goto yynewstate;
 403
 404
 405   /*-----------------------------------------------------------.
 406   | yydefault -- do the default action for the current state.  |
 407   `-----------------------------------------------------------*/
 408   yydefault:
 409     yyn = yydefact[yystate];
 410     if (yyn == 0)
 411         goto yyerrlab;
 412     goto yyreduce;
 413
 414
 415   /*-----------------------------.
 416   | yyreduce -- Do a reduction.  |
 417   `-----------------------------*/
 418   yyreduce:
 419     /* yyn is the number of a rule to reduce with.  */
 420     parser->yylen = yyr2[yyn];
 421
 422     /* If YYLEN is nonzero, implement the default value of the action:
 423       "$$ = $1".
 424
 425       Otherwise, the following line sets YYVAL to garbage.
 426       This behavior is undocumented and Bison
 427       users should not rely upon it.  Assigning to YYVAL
 428       unconditionally makes the parser a bit smaller, and it avoids a
 429       GCC warning that YYVAL may be used uninitialized.  */
 430     yyval = ps[1-parser->yylen].val;
 431
 432     YY_STACK_PRINT(parser);
 433     YY_REDUCE_PRINT (yyn);
 434
 435     switch (yyn) {
 436
 437 #ifdef PERL_IN_MADLY_C
 438 #  define IVAL(i) (i)->tk_lval.ival
 439 #  define PVAL(p) (p)->tk_lval.pval
 440 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
 441 #  define TOKEN_FREE(a) token_free(a)
 442 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
 443 #  define IF_MAD(a,b) (a)
 444 #  define DO_MAD(a) a
 445 #  define MAD
 446 #else
 447 #  define IVAL(i) (i)
 448 #  define PVAL(p) (p)
 449 #  define TOKEN_GETMAD(a,b,c)
 450 #  define TOKEN_FREE(a)
 451 #  define OP_GETMAD(a,b,c)
 452 #  define IF_MAD(a,b) (b)
 453 #  define DO_MAD(a)
 454 #  undef MAD
 455 #endif
 456
 457 /* contains all the rule actions; auto-generated from perly.y */
 458 #include "perly.act"
 459
 460     }
 461
 462     {
 463         int i;
 464         for (i=0; i< parser->yylen; i++) {
 465             SvREFCNT_dec(ps[-i].compcv);
 466         }
 467     }
 468
 469     parser->ps = ps -= (parser->yylen-1);
 470
 471     /* Now shift the result of the reduction.  Determine what state
 472           that goes to, based on the state we popped back to and the rule
 473           number reduced by.  */
 474
 475     ps->val     = yyval;
 476     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 477     ps->savestack_ix = PL_savestack_ix;
 478 #ifdef DEBUGGING
 479     ps->name    = (const char *)(yytname [yyr1[yyn]]);
 480 #endif
 481
 482     yyn = yyr1[yyn];
 483
 484     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
 485     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
 486         yystate = yytable[yystate];
 487     else
 488         yystate = yydefgoto[yyn - YYNTOKENS];
 489     ps->state = yystate;
 490
 491     goto yynewstate;
 492
 493
 494   /*------------------------------------.
 495   | yyerrlab -- here on detecting error |
 496   `------------------------------------*/
 497   yyerrlab:
 498     /* If not already recovering from an error, report this error.  */
 499     if (!parser->yyerrstatus) {
 500         yyerror ("syntax error");
 501     }
 502
 503
 504     if (parser->yyerrstatus == 3) {
 505         /* If just tried and failed to reuse lookahead token after an
 506               error, discard it.  */
 507
 508         /* Return failure if at end of input.  */
 509         if (parser->yychar == YYEOF) {
 510             /* Pop the error token.  */
 511             SvREFCNT_dec(ps->compcv);
 512             YYPOPSTACK;
 513             /* Pop the rest of the stack.  */
 514             while (ps > parser->stack) {
 515                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 516                 LEAVE_SCOPE(ps->savestack_ix);
 517                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
 518                         && ps->val.opval)
 519                 {
 520                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 521                     if (ps->compcv != PL_compcv) {
 522                         PL_compcv = ps->compcv;
 523                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 524                     }
 525                     op_free(ps->val.opval);
 526                 }
 527                 SvREFCNT_dec(ps->compcv);
 528                 YYPOPSTACK;
 529             }
 530             YYABORT;
 531         }
 532
 533         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
 534         parser->yychar = YYEMPTY;
 535
 536     }
 537
 538     /* Else will try to reuse lookahead token after shifting the error
 539           token.  */
 540     goto yyerrlab1;
 541
 542
 543   /*----------------------------------------------------.
 544   | yyerrlab1 -- error raised explicitly by an action.  |
 545   `----------------------------------------------------*/
 546   yyerrlab1:
 547     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
 548
 549     for (;;) {
 550         yyn = yypact[yystate];
 551         if (yyn != YYPACT_NINF) {
 552             yyn += YYTERROR;
 553             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 554                 yyn = yytable[yyn];
 555                 if (0 < yyn)
 556                     break;
 557             }
 558         }
 559
 560         /* Pop the current state because it cannot handle the error token.  */
 561         if (ps == parser->stack)
 562             YYABORT;
 563
 564         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 565         LEAVE_SCOPE(ps->savestack_ix);
 566         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
 567             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 568             if (ps->compcv != PL_compcv) {
 569                 PL_compcv = ps->compcv;
 570                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 571             }
 572             op_free(ps->val.opval);
 573         }
 574         SvREFCNT_dec(ps->compcv);
 575         YYPOPSTACK;
 576         yystate = ps->state;
 577
 578         YY_STACK_PRINT(parser);
 579     }
 580
 581     if (yyn == YYFINAL)
 582         YYACCEPT;
 583
 584     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 585
 586     YYPUSHSTACK;
 587     ps->state   = yyn;
 588     ps->val     = parser->yylval;
 589     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 590     ps->savestack_ix = PL_savestack_ix;
 591 #ifdef DEBUGGING
 592     ps->name    ="<err>";
 593 #endif
 594
 595     goto yynewstate;
 596
 597
 598   /*-------------------------------------.
 599   | yyacceptlab -- YYACCEPT comes here.  |
 600   `-------------------------------------*/
 601   yyacceptlab:
 602     yyresult = 0;
 603     for (ps=parser->ps; ps > parser->stack; ps--) {
 604         SvREFCNT_dec(ps->compcv);
 605     }
 606     parser->ps = parser->stack; /* disable cleanup */
 607     goto yyreturn;
 608
 609   /*-----------------------------------.
 610   | yyabortlab -- YYABORT comes here.  |
 611   `-----------------------------------*/
 612   yyabortlab:
 613     yyresult = 1;
 614     goto yyreturn;
 615
 616   yyreturn:
 617     LEAVE;      /* force parser stack cleanup before we return */
 618     return yyresult;
 619 }
 620
 621 /*
 622  * Local variables:
 623  * c-indentation-style: bsd
 624  * c-basic-offset: 4
 625  * indent-tabs-mode: nil
 626  * End:
 627  *
 628  * ex: set ts=8 sts=4 sw=4 et:
 629  */