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