better perldelta description for #120091/#118059
[perl.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  * Note that this file is also #included in madly.c, to allow compilation
23  * of a second parser, Perl_madparse, that is identical to Perl_yyparse,
24  * but which includes extra code for dumping the parse tree.
25  * This is controlled by the PERL_IN_MADLY_C define.
26  */
27
28 #include "EXTERN.h"
29 #define PERL_IN_PERLY_C
30 #include "perl.h"
31
32 typedef unsigned char yytype_uint8;
33 typedef signed char yytype_int8;
34 typedef unsigned short int yytype_uint16;
35 typedef short int yytype_int16;
36 typedef signed char yysigned_char;
37
38 /* YYINITDEPTH -- initial size of the parser's stacks.  */
39 #define YYINITDEPTH 200
40
41 #ifdef YYDEBUG
42 #  undef YYDEBUG
43 #endif
44 #ifdef DEBUGGING
45 #  define YYDEBUG 1
46 #else
47 #  define YYDEBUG 0
48 #endif
49
50 #ifndef YY_NULL
51 # define YY_NULL 0
52 #endif
53
54 /* contains all the parser state tables; auto-generated from perly.y */
55 #include "perly.tab"
56
57 # define YYSIZE_T size_t
58
59 #define YYEOF           0
60 #define YYTERROR        1
61
62 #define YYACCEPT        goto yyacceptlab
63 #define YYABORT         goto yyabortlab
64 #define YYERROR         goto yyerrlab1
65
66 /* Enable debugging if requested.  */
67 #ifdef DEBUGGING
68
69 #  define yydebug (DEBUG_p_TEST)
70
71 #  define YYFPRINTF PerlIO_printf
72
73 #  define YYDPRINTF(Args)                       \
74 do {                                            \
75     if (yydebug)                                \
76         YYFPRINTF Args;                         \
77 } while (0)
78
79 #  define YYDSYMPRINTF(Title, Token, Value)                     \
80 do {                                                            \
81     if (yydebug) {                                              \
82         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
83         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
84         YYFPRINTF (Perl_debug_log, "\n");                       \
85     }                                                           \
86 } while (0)
87
88 /*--------------------------------.
89 | Print this symbol on YYOUTPUT.  |
90 `--------------------------------*/
91
92 static void
93 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
94 {
95     if (yytype < YYNTOKENS) {
96         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
97 #   ifdef YYPRINT
98         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
99 #   else
100         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
101 #   endif
102     }
103     else
104         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
105
106     YYFPRINTF (yyoutput, ")");
107 }
108
109
110 /*  yy_stack_print()
111  *  print the top 8 items on the parse stack.
112  */
113
114 static void
115 yy_stack_print (pTHX_ const yy_parser *parser)
116 {
117     const yy_stack_frame *ps, *min;
118
119     min = parser->ps - 8 + 1;
120     if (min <= parser->stack)
121         min = parser->stack + 1;
122
123     PerlIO_printf(Perl_debug_log, "\nindex:");
124     for (ps = min; ps <= parser->ps; ps++)
125         PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack));
126
127     PerlIO_printf(Perl_debug_log, "\nstate:");
128     for (ps = min; ps <= parser->ps; ps++)
129         PerlIO_printf(Perl_debug_log, " %8d", ps->state);
130
131     PerlIO_printf(Perl_debug_log, "\ntoken:");
132     for (ps = min; ps <= parser->ps; ps++)
133         PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
134
135     PerlIO_printf(Perl_debug_log, "\nvalue:");
136     for (ps = min; ps <= parser->ps; ps++) {
137         switch (yy_type_tab[yystos[ps->state]]) {
138         case toketype_opval:
139             PerlIO_printf(Perl_debug_log, " %8.8s",
140                   ps->val.opval
141                     ? PL_op_name[ps->val.opval->op_type]
142                     : "(Nullop)"
143             );
144             break;
145 #ifndef PERL_IN_MADLY_C
146         case toketype_i_tkval:
147 #endif
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     for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
178         YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
179     YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
180 }
181
182 #  define YY_REDUCE_PRINT(Rule)         \
183 do {                                    \
184     if (yydebug)                        \
185         yy_reduce_print (aTHX_ Rule);           \
186 } while (0)
187
188 #else /* !DEBUGGING */
189 #  define YYDPRINTF(Args)
190 #  define YYDSYMPRINTF(Title, Token, Value)
191 #  define YY_STACK_PRINT(parser)
192 #  define YY_REDUCE_PRINT(Rule)
193 #endif /* !DEBUGGING */
194
195 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
196  * parse stack, thus avoiding leaks if we die  */
197
198 static void
199 S_clear_yystack(pTHX_  const yy_parser *parser)
200 {
201     yy_stack_frame *ps     = parser->ps;
202     int i = 0;
203
204     if (!parser->stack)
205         return;
206
207     YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
208
209     for (i=0; i< parser->yylen; i++) {
210         SvREFCNT_dec(ps[-i].compcv);
211     }
212     ps -= parser->yylen;
213
214     /* now free whole the stack, including the just-reduced ops */
215
216     while (ps > parser->stack) {
217         LEAVE_SCOPE(ps->savestack_ix);
218         if (yy_type_tab[yystos[ps->state]] == toketype_opval
219             && ps->val.opval)
220         {
221             if (ps->compcv != PL_compcv) {
222                 PL_compcv = ps->compcv;
223                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
224                 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
225             }
226             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
227             op_free(ps->val.opval);
228         }
229         SvREFCNT_dec(ps->compcv);
230         ps--;
231     }
232
233     Safefree(parser->stack);
234 }
235
236
237 /*----------.
238 | yyparse.  |
239 `----------*/
240
241 int
242 #ifdef PERL_IN_MADLY_C
243 Perl_madparse (pTHX_ int gramtype)
244 #else
245 Perl_yyparse (pTHX_ int gramtype)
246 #endif
247 {
248     dVAR;
249     int yystate;
250     int yyn;
251     int yyresult;
252
253     /* Lookahead token as an internal (translated) token number.  */
254     int yytoken = 0;
255
256     yy_parser *parser;      /* the parser object */
257     yy_stack_frame  *ps;   /* current parser stack frame */
258
259 #define YYPOPSTACK   parser->ps = --ps
260 #define YYPUSHSTACK  parser->ps = ++ps
261
262     /* The variable used to return semantic value and location from the
263           action routines: ie $$.  */
264     YYSTYPE yyval;
265
266 #ifndef PERL_IN_MADLY_C
267 #  ifdef PERL_MAD
268     if (PL_madskills)
269         return madparse(gramtype);
270 #  endif
271 #endif
272
273     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
274
275     parser = PL_parser;
276
277     ENTER;  /* force parser state cleanup/restoration before we return */
278     SAVEPPTR(parser->yylval.pval);
279     SAVEINT(parser->yychar);
280     SAVEINT(parser->yyerrstatus);
281     SAVEINT(parser->stack_size);
282     SAVEINT(parser->yylen);
283     SAVEVPTR(parser->stack);
284     SAVEVPTR(parser->ps);
285
286     /* initialise state for this parse */
287     parser->yychar = gramtype;
288     parser->yyerrstatus = 0;
289     parser->stack_size = YYINITDEPTH;
290     parser->yylen = 0;
291     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
292     ps = parser->ps = parser->stack;
293     ps->state = 0;
294     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
295
296 /*------------------------------------------------------------.
297 | yynewstate -- Push a new state, which is found in yystate.  |
298 `------------------------------------------------------------*/
299   yynewstate:
300
301     yystate = ps->state;
302
303     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
304
305     parser->yylen = 0;
306
307     {
308         size_t size = ps - parser->stack + 1;
309
310         /* grow the stack? We always leave 1 spare slot,
311          * in case of a '' -> 'foo' reduction */
312
313         if (size >= (size_t)parser->stack_size - 1) {
314             /* this will croak on insufficient memory */
315             parser->stack_size *= 2;
316             Renew(parser->stack, parser->stack_size, yy_stack_frame);
317             ps = parser->ps = parser->stack + size -1;
318
319             YYDPRINTF((Perl_debug_log,
320                             "parser stack size increased to %lu frames\n",
321                             (unsigned long int)parser->stack_size));
322         }
323     }
324
325 /* Do appropriate processing given the current state.  */
326 /* Read a lookahead token if we need one and don't already have one.  */
327
328     /* First try to decide what to do without reference to 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 one.  */
335
336     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
337     if (parser->yychar == YYEMPTY) {
338         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
339 #ifdef PERL_IN_MADLY_C
340         parser->yychar = PL_madskills ? madlex() : yylex();
341 #else
342         parser->yychar = yylex();
343 #endif
344
345 /* perly.tab is shipped based on an ASCII system; if it were to be regenerated
346  * on a platform that doesn't use ASCII, this translation back would need to be
347  * removed */
348 #  ifdef EBCDIC
349         if (parser->yychar >= 0 && parser->yychar < 255) {
350             parser->yychar = NATIVE_TO_LATIN1(parser->yychar);
351         }
352 #  endif
353     }
354
355     if (parser->yychar <= YYEOF) {
356         parser->yychar = yytoken = YYEOF;
357         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
358     }
359     else {
360         yytoken = YYTRANSLATE (parser->yychar);
361         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
362     }
363
364     /* If the proper action on seeing token YYTOKEN is to reduce or to
365           detect an error, take that action.  */
366     yyn += yytoken;
367     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
368         goto yydefault;
369     yyn = yytable[yyn];
370     if (yyn <= 0) {
371         if (yyn == 0 || yyn == YYTABLE_NINF)
372             goto yyerrlab;
373         yyn = -yyn;
374         goto yyreduce;
375     }
376
377     if (yyn == YYFINAL)
378         YYACCEPT;
379
380     /* Shift the lookahead token.  */
381     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
382
383     /* Discard the token being shifted unless it is eof.  */
384     if (parser->yychar != YYEOF)
385         parser->yychar = YYEMPTY;
386
387     YYPUSHSTACK;
388     ps->state   = yyn;
389     ps->val     = parser->yylval;
390     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
391     ps->savestack_ix = PL_savestack_ix;
392 #ifdef DEBUGGING
393     ps->name    = (const char *)(yytname[yytoken]);
394 #endif
395
396     /* Count tokens shifted since error; after three, turn off error
397           status.  */
398     if (parser->yyerrstatus)
399         parser->yyerrstatus--;
400
401     goto yynewstate;
402
403
404   /*-----------------------------------------------------------.
405   | yydefault -- do the default action for the current state.  |
406   `-----------------------------------------------------------*/
407   yydefault:
408     yyn = yydefact[yystate];
409     if (yyn == 0)
410         goto yyerrlab;
411     goto yyreduce;
412
413
414   /*-----------------------------.
415   | yyreduce -- Do a reduction.  |
416   `-----------------------------*/
417   yyreduce:
418     /* yyn is the number of a rule to reduce with.  */
419     parser->yylen = yyr2[yyn];
420
421     /* If YYLEN is nonzero, implement the default value of the action:
422       "$$ = $1".
423
424       Otherwise, the following line sets YYVAL to garbage.
425       This behavior is undocumented and Bison
426       users should not rely upon it.  Assigning to YYVAL
427       unconditionally makes the parser a bit smaller, and it avoids a
428       GCC warning that YYVAL may be used uninitialized.  */
429     yyval = ps[1-parser->yylen].val;
430
431     YY_STACK_PRINT(parser);
432     YY_REDUCE_PRINT (yyn);
433
434     switch (yyn) {
435
436
437 #define dep() deprecate("\"do\" to call subroutines")
438
439 #ifdef PERL_IN_MADLY_C
440 #  define IVAL(i) (i)->tk_lval.ival
441 #  define PVAL(p) (p)->tk_lval.pval
442 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
443 #  define TOKEN_FREE(a) token_free(a)
444 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
445 #  define IF_MAD(a,b) (a)
446 #  define DO_MAD(a) a
447 #  define MAD
448 #else
449 #  define IVAL(i) (i)
450 #  define PVAL(p) (p)
451 #  define TOKEN_GETMAD(a,b,c)
452 #  define TOKEN_FREE(a)
453 #  define OP_GETMAD(a,b,c)
454 #  define IF_MAD(a,b) (b)
455 #  define DO_MAD(a)
456 #  undef MAD
457 #endif
458
459 /* contains all the rule actions; auto-generated from perly.y */
460 #include "perly.act"
461
462     }
463
464     {
465         int i;
466         for (i=0; i< parser->yylen; i++) {
467             SvREFCNT_dec(ps[-i].compcv);
468         }
469     }
470
471     parser->ps = ps -= (parser->yylen-1);
472
473     /* Now shift the result of the reduction.  Determine what state
474           that goes to, based on the state we popped back to and the rule
475           number reduced by.  */
476
477     ps->val     = yyval;
478     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
479     ps->savestack_ix = PL_savestack_ix;
480 #ifdef DEBUGGING
481     ps->name    = (const char *)(yytname [yyr1[yyn]]);
482 #endif
483
484     yyn = yyr1[yyn];
485
486     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
487     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
488         yystate = yytable[yystate];
489     else
490         yystate = yydefgoto[yyn - YYNTOKENS];
491     ps->state = yystate;
492
493     goto yynewstate;
494
495
496   /*------------------------------------.
497   | yyerrlab -- here on detecting error |
498   `------------------------------------*/
499   yyerrlab:
500     /* If not already recovering from an error, report this error.  */
501     if (!parser->yyerrstatus) {
502         yyerror ("syntax error");
503     }
504
505
506     if (parser->yyerrstatus == 3) {
507         /* If just tried and failed to reuse lookahead token after an
508               error, discard it.  */
509
510         /* Return failure if at end of input.  */
511         if (parser->yychar == YYEOF) {
512             /* Pop the error token.  */
513             SvREFCNT_dec(ps->compcv);
514             YYPOPSTACK;
515             /* Pop the rest of the stack.  */
516             while (ps > parser->stack) {
517                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
518                 LEAVE_SCOPE(ps->savestack_ix);
519                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
520                         && ps->val.opval)
521                 {
522                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
523                     if (ps->compcv != PL_compcv) {
524                         PL_compcv = ps->compcv;
525                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
526                     }
527                     op_free(ps->val.opval);
528                 }
529                 SvREFCNT_dec(ps->compcv);
530                 YYPOPSTACK;
531             }
532             YYABORT;
533         }
534
535         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
536         parser->yychar = YYEMPTY;
537
538     }
539
540     /* Else will try to reuse lookahead token after shifting the error
541           token.  */
542     goto yyerrlab1;
543
544
545   /*----------------------------------------------------.
546   | yyerrlab1 -- error raised explicitly by an action.  |
547   `----------------------------------------------------*/
548   yyerrlab1:
549     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
550
551     for (;;) {
552         yyn = yypact[yystate];
553         if (yyn != YYPACT_NINF) {
554             yyn += YYTERROR;
555             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
556                 yyn = yytable[yyn];
557                 if (0 < yyn)
558                     break;
559             }
560         }
561
562         /* Pop the current state because it cannot handle the error token.  */
563         if (ps == parser->stack)
564             YYABORT;
565
566         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
567         LEAVE_SCOPE(ps->savestack_ix);
568         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
569             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
570             if (ps->compcv != PL_compcv) {
571                 PL_compcv = ps->compcv;
572                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
573             }
574             op_free(ps->val.opval);
575         }
576         SvREFCNT_dec(ps->compcv);
577         YYPOPSTACK;
578         yystate = ps->state;
579
580         YY_STACK_PRINT(parser);
581     }
582
583     if (yyn == YYFINAL)
584         YYACCEPT;
585
586     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
587
588     YYPUSHSTACK;
589     ps->state   = yyn;
590     ps->val     = parser->yylval;
591     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
592     ps->savestack_ix = PL_savestack_ix;
593 #ifdef DEBUGGING
594     ps->name    ="<err>";
595 #endif
596
597     goto yynewstate;
598
599
600   /*-------------------------------------.
601   | yyacceptlab -- YYACCEPT comes here.  |
602   `-------------------------------------*/
603   yyacceptlab:
604     yyresult = 0;
605     for (ps=parser->ps; ps > parser->stack; ps--) {
606         SvREFCNT_dec(ps->compcv);
607     }
608     parser->ps = parser->stack; /* disable cleanup */
609     goto yyreturn;
610
611   /*-----------------------------------.
612   | yyabortlab -- YYABORT comes here.  |
613   `-----------------------------------*/
614   yyabortlab:
615     yyresult = 1;
616     goto yyreturn;
617
618   yyreturn:
619     LEAVE;      /* force parser stack cleanup before we return */
620     return yyresult;
621 }
622
623 /*
624  * Local variables:
625  * c-indentation-style: bsd
626  * c-basic-offset: 4
627  * indent-tabs-mode: nil
628  * End:
629  *
630  * ex: set ts=8 sts=4 sw=4 et:
631  */