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