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