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