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
 437 #define dep() deprecate("\"do\" to call subroutines")
 438
 439 #ifdef PERL_IN_MADLY_C
 440 #  define IVAL(i) (i)->tk_lval.ival
 441 #  define PVAL(p) (p)->tk_lval.pval
 442 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
 443 #  define TOKEN_FREE(a) token_free(a)
 444 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
 445 #  define IF_MAD(a,b) (a)
 446 #  define DO_MAD(a) a
 447 #  define MAD
 448 #else
 449 #  define IVAL(i) (i)
 450 #  define PVAL(p) (p)
 451 #  define TOKEN_GETMAD(a,b,c)
 452 #  define TOKEN_FREE(a)
 453 #  define OP_GETMAD(a,b,c)
 454 #  define IF_MAD(a,b) (b)
 455 #  define DO_MAD(a)
 456 #  undef MAD
 457 #endif
 458
 459 /* contains all the rule actions; auto-generated from perly.y */
 460 #include "perly.act"
 461
 462     }
 463
 464     {
 465         int i;
 466         for (i=0; i< parser->yylen; i++) {
 467             SvREFCNT_dec(ps[-i].compcv);
 468         }
 469     }
 470
 471     parser->ps = ps -= (parser->yylen-1);
 472
 473     /* Now shift the result of the reduction.  Determine what state
 474           that goes to, based on the state we popped back to and the rule
 475           number reduced by.  */
 476
 477     ps->val     = yyval;
 478     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 479     ps->savestack_ix = PL_savestack_ix;
 480 #ifdef DEBUGGING
 481     ps->name    = (const char *)(yytname [yyr1[yyn]]);
 482 #endif
 483
 484     yyn = yyr1[yyn];
 485
 486     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
 487     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
 488         yystate = yytable[yystate];
 489     else
 490         yystate = yydefgoto[yyn - YYNTOKENS];
 491     ps->state = yystate;
 492
 493     goto yynewstate;
 494
 495
 496   /*------------------------------------.
 497   | yyerrlab -- here on detecting error |
 498   `------------------------------------*/
 499   yyerrlab:
 500     /* If not already recovering from an error, report this error.  */
 501     if (!parser->yyerrstatus) {
 502         yyerror ("syntax error");
 503     }
 504
 505
 506     if (parser->yyerrstatus == 3) {
 507         /* If just tried and failed to reuse lookahead token after an
 508               error, discard it.  */
 509
 510         /* Return failure if at end of input.  */
 511         if (parser->yychar == YYEOF) {
 512             /* Pop the error token.  */
 513             SvREFCNT_dec(ps->compcv);
 514             YYPOPSTACK;
 515             /* Pop the rest of the stack.  */
 516             while (ps > parser->stack) {
 517                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 518                 LEAVE_SCOPE(ps->savestack_ix);
 519                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
 520                         && ps->val.opval)
 521                 {
 522                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 523                     if (ps->compcv != PL_compcv) {
 524                         PL_compcv = ps->compcv;
 525                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 526                     }
 527                     op_free(ps->val.opval);
 528                 }
 529                 SvREFCNT_dec(ps->compcv);
 530                 YYPOPSTACK;
 531             }
 532             YYABORT;
 533         }
 534
 535         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
 536         parser->yychar = YYEMPTY;
 537
 538     }
 539
 540     /* Else will try to reuse lookahead token after shifting the error
 541           token.  */
 542     goto yyerrlab1;
 543
 544
 545   /*----------------------------------------------------.
 546   | yyerrlab1 -- error raised explicitly by an action.  |
 547   `----------------------------------------------------*/
 548   yyerrlab1:
 549     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
 550
 551     for (;;) {
 552         yyn = yypact[yystate];
 553         if (yyn != YYPACT_NINF) {
 554             yyn += YYTERROR;
 555             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
 556                 yyn = yytable[yyn];
 557                 if (0 < yyn)
 558                     break;
 559             }
 560         }
 561
 562         /* Pop the current state because it cannot handle the error token.  */
 563         if (ps == parser->stack)
 564             YYABORT;
 565
 566         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
 567         LEAVE_SCOPE(ps->savestack_ix);
 568         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
 569             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
 570             if (ps->compcv != PL_compcv) {
 571                 PL_compcv = ps->compcv;
 572                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
 573             }
 574             op_free(ps->val.opval);
 575         }
 576         SvREFCNT_dec(ps->compcv);
 577         YYPOPSTACK;
 578         yystate = ps->state;
 579
 580         YY_STACK_PRINT(parser);
 581     }
 582
 583     if (yyn == YYFINAL)
 584         YYACCEPT;
 585
 586     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
 587
 588     YYPUSHSTACK;
 589     ps->state   = yyn;
 590     ps->val     = parser->yylval;
 591     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 592     ps->savestack_ix = PL_savestack_ix;
 593 #ifdef DEBUGGING
 594     ps->name    ="<err>";
 595 #endif
 596
 597     goto yynewstate;
 598
 599
 600   /*-------------------------------------.
 601   | yyacceptlab -- YYACCEPT comes here.  |
 602   `-------------------------------------*/
 603   yyacceptlab:
 604     yyresult = 0;
 605     for (ps=parser->ps; ps > parser->stack; ps--) {
 606         SvREFCNT_dec(ps->compcv);
 607     }
 608     parser->ps = parser->stack; /* disable cleanup */
 609     goto yyreturn;
 610
 611   /*-----------------------------------.
 612   | yyabortlab -- YYABORT comes here.  |
 613   `-----------------------------------*/
 614   yyabortlab:
 615     yyresult = 1;
 616     goto yyreturn;
 617
 618   yyreturn:
 619     LEAVE;      /* force parser stack cleanup before we return */
 620     return yyresult;
 621 }
 622
 623 /*
 624  * Local variables:
 625  * c-indentation-style: bsd
 626  * c-basic-offset: 4
 627  * indent-tabs-mode: nil
 628  * End:
 629  *
 630  * ex: set ts=8 sts=4 sw=4 et:
 631  */