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