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