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