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             yyquit();
 493         }
 494
 495
 496         if (parser->yyerrstatus == 3) {
 497             /* If just tried and failed to reuse lookahead token after an
 498                   error, discard it.  */
 499
 500             /* Return failure if at end of input.  */
 501             if (parser->yychar == YYEOF) {
 502                 /* Pop the error token.  */
 503                 SvREFCNT_dec(ps->compcv);
 504                 YYPOPSTACK;
 505                 /* Pop the rest of the stack.  */
 506                 while (ps > parser->stack) {
 507                     YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 508                     LEAVE_SCOPE(ps->savestack_ix);
 509                     if (yy_type_tab[yystos[ps->state]] == toketype_opval
 510                             && ps->val.opval)
 511                     {
 512                         YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 513                         if (ps->compcv != PL_compcv) {
 514                             PL_compcv = ps->compcv;
 515                             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 516                         }
 517                         op_free(ps->val.opval);
 518                     }
 519                     SvREFCNT_dec(ps->compcv);
 520                     YYPOPSTACK;
 521                 }
 522                 YYABORT;
 523             }
 524
 525             YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
 526             parser->yychar = YYEMPTY;
 527
 528         }
 529
 530         /* Else will try to reuse lookahead token after shifting the error
 531               token.  */
 532         goto yyerrlab1;
 533
 534
 535       /*----------------------------------------------------.
 536       | yyerrlab1 -- error raised explicitly by an action.  |
 537       `----------------------------------------------------*/
 538       yyerrlab1:
 539         parser->yyerrstatus = 3;        /* Each real token shifted decrements this.  */
 540
 541         for (;;) {
 542             yyn = yypact[yystate];
 543             if (yyn != YYPACT_NINF) {
 544                 yyn += YYTERROR;
 545                 if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 546                     yyn = yytable[yyn];
 547                     if (0 < yyn)
 548                         break;
 549                 }
 550             }
 551
 552             /* Pop the current state because it cannot handle the error token.  */
 553             if (ps == parser->stack)
 554                 YYABORT;
 555
 556             YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 557             LEAVE_SCOPE(ps->savestack_ix);
 558             if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
 559                 YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 560                 if (ps->compcv != PL_compcv) {
 561                     PL_compcv = ps->compcv;
 562                     PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 563                 }
 564                 op_free(ps->val.opval);
 565             }
 566             SvREFCNT_dec(ps->compcv);
 567             YYPOPSTACK;
 568             yystate = ps->state;
 569
 570             YY_STACK_PRINT(parser);
 571         }
 572
 573         if (yyn == YYFINAL)
 574             YYACCEPT;
 575
 576         YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 577
 578         YYPUSHSTACK;
 579         ps->state   = yyn;
 580         ps->val     = parser->yylval;
 581         ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 582         ps->savestack_ix = PL_savestack_ix;
 583 #ifdef DEBUGGING
 584         ps->name    ="<err>";
 585 #endif
 586
 587     } /* main loop */
 588
 589
 590   /*-------------------------------------.
 591   | yyacceptlab -- YYACCEPT comes here.  |
 592   `-------------------------------------*/
 593   yyacceptlab:
 594     yyresult = 0;
 595     for (ps=parser->ps; ps > parser->stack; ps--) {
 596         SvREFCNT_dec(ps->compcv);
 597     }
 598     parser->ps = parser->stack; /* disable cleanup */
 599     goto yyreturn;
 600
 601   /*-----------------------------------.
 602   | yyabortlab -- YYABORT comes here.  |
 603   `-----------------------------------*/
 604   yyabortlab:
 605     yyresult = 1;
 606     goto yyreturn;
 607
 608   yyreturn:
 609     LEAVE;      /* force parser stack cleanup before we return */
 610     return yyresult;
 611 }
 612
 613 /*
 614  * ex: set ts=8 sts=4 sw=4 et:
 615  */