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
yysymprint(pTHX_ PerlIO * const yyoutput,int yytype,const YYSTYPE * const yyvaluep)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
yy_stack_print(pTHX_ const yy_parser * parser)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
yy_reduce_print(pTHX_ int yyrule)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
S_clear_yystack(pTHX_ const yy_parser * parser)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
Perl_yyparse(pTHX_ int gramtype)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 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