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