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