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     parser->yyerrstatus = 0;
 284     parser->yylen = 0;
 285     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 286     parser->stack_max1 = parser->stack + YYINITDEPTH - 1;
 287     ps = parser->ps = parser->stack;
 288     ps->state = 0;
 289     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
 290
 291 /*------------------------------------------------------------.
 292 | yynewstate -- Push a new state, which is found in yystate.  |
 293 `------------------------------------------------------------*/
 294   yynewstate:
 295
 296     yystate = ps->state;
 297
 298     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 299
 300     parser->yylen = 0;
 301
 302     {
 303         /* grow the stack? We always leave 1 spare slot,
 304          * in case of a '' -> 'foo' reduction.
 305          * Note that stack_max1 points to the (top-1)th allocated stack
 306          * element to make this check fast */
 307
 308         if (ps >= parser->stack_max1) {
 309             Size_t pos = ps - parser->stack;
 310             Size_t newsize = 2 * (parser->stack_max1 + 2 - parser->stack);
 311             /* this will croak on insufficient memory */
 312             Renew(parser->stack, newsize, yy_stack_frame);
 313             ps = parser->ps = parser->stack + pos;
 314             parser->stack_max1 = parser->stack + newsize - 1;
 315
 316             YYDPRINTF((Perl_debug_log,
 317                             "parser stack size increased to %lu frames\n",
 318                             (unsigned long int)newsize));
 319         }
 320     }
 321
 322 /* Do appropriate processing given the current state.  */
 323 /* Read a lookahead token if we need one and don't already have one.  */
 324
 325     /* First try to decide what to do without reference to lookahead token.  */
 326
 327     yyn = yypact[yystate];
 328     if (yyn == YYPACT_NINF)
 329         goto yydefault;
 330
 331     /* Not known => get a lookahead token if don't already have one.  */
 332
 333     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
 334     if (parser->yychar == YYEMPTY) {
 335         YYDPRINTF ((Perl_debug_log, "Reading a token:\n"));
 336         parser->yychar = yylex();
 337     }
 338
 339     if (parser->yychar <= YYEOF) {
 340         parser->yychar = yytoken = YYEOF;
 341         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
 342     }
 343     else {
 344         /* perly.tab is shipped based on an ASCII system, so need to index it
 345          * with characters translated to ASCII.  Although it's not designed for
 346          * this purpose, we can use NATIVE_TO_UNI here.  It returns its
 347          * argument on ASCII platforms, and on EBCDIC translates native to
 348          * ascii in the 0-255 range, leaving everything else unchanged.  This
 349          * jibes with yylex() returning some bare characters in that range, but
 350          * all tokens it returns are either 0, or above 255.  There could be a
 351          * problem if NULs weren't 0, or were ever returned as raw chars by
 352          * yylex() */
 353         yytoken = YYTRANSLATE (NATIVE_TO_UNI(parser->yychar));
 354         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
 355     }
 356
 357     /* If the proper action on seeing token YYTOKEN is to reduce or to
 358      * detect an error, take that action.
 359      * Casting yyn to unsigned allows a >=0 test to be included as
 360      * part of the  <=YYLAST test for speed */
 361     yyn += yytoken;
 362     if ((unsigned int)yyn > YYLAST || yycheck[yyn] != yytoken)
 363         goto yydefault;
 364     yyn = yytable[yyn];
 365     if (yyn <= 0) {
 366         if (yyn == 0 || yyn == YYTABLE_NINF)
 367             goto yyerrlab;
 368         yyn = -yyn;
 369         goto yyreduce;
 370     }
 371
 372     if (yyn == YYFINAL)
 373         YYACCEPT;
 374
 375     /* Shift the lookahead token.  */
 376     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
 377
 378     /* Discard the token being shifted unless it is eof.  */
 379     if (parser->yychar != YYEOF)
 380         parser->yychar = YYEMPTY;
 381
 382     YYPUSHSTACK;
 383     ps->state   = yyn;
 384     ps->val     = parser->yylval;
 385     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
 386     ps->savestack_ix = PL_savestack_ix;
 387 #ifdef DEBUGGING
 388     ps->name    = (const char *)(yytname[yytoken]);
 389 #endif
 390
 391     /* Count tokens shifted since error; after three, turn off error
 392           status.  */
 393     if (parser->yyerrstatus)
 394         parser->yyerrstatus--;
 395
 396     goto yynewstate;
 397
 398
 399   /*-----------------------------------------------------------.
 400   | yydefault -- do the default action for the current state.  |
 401   `-----------------------------------------------------------*/
 402   yydefault:
 403     yyn = yydefact[yystate];
 404     if (yyn == 0)
 405         goto yyerrlab;
 406     goto yyreduce;
 407
 408
 409   /*-----------------------------.
 410   | yyreduce -- Do a reduction.  |
 411   `-----------------------------*/
 412   yyreduce:
 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     goto yynewstate;
 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     goto yynewstate;
 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  */