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