This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
optimising yyparse: replace stack_size with a ptr
[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 #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
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
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
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
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
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     parser->yyerrstatus = 0;
284     parser->yylen = 0;
285     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
286     parser->stack_max1 = parser->stack + YYINITDEPTH - 1;
287     ps = parser->ps = parser->stack;
288     ps->state = 0;
289     SAVEDESTRUCTOR_X(S_clear_yystack, parser);
290
291 /*------------------------------------------------------------.
292 | yynewstate -- Push a new state, which is found in yystate.  |
293 `------------------------------------------------------------*/
294   yynewstate:
295
296     yystate = ps->state;
297
298     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
299
300     parser->yylen = 0;
301
302     {
303         /* grow the stack? We always leave 1 spare slot,
304          * in case of a '' -> 'foo' reduction.
305          * Note that stack_max1 points to the (top-1)th allocated stack
306          * element to make this check fast */
307
308         if (ps >= parser->stack_max1) {
309             Size_t pos = ps - parser->stack;
310             Size_t newsize = 2 * (parser->stack_max1 + 2 - parser->stack);
311             /* this will croak on insufficient memory */
312             Renew(parser->stack, newsize, yy_stack_frame);
313             ps = parser->ps = parser->stack + pos;
314             parser->stack_max1 = parser->stack + newsize - 1;
315
316             YYDPRINTF((Perl_debug_log,
317                             "parser stack size increased to %lu frames\n",
318                             (unsigned long int)newsize));
319         }
320     }
321
322 /* Do appropriate processing given the current state.  */
323 /* Read a lookahead token if we need one and don't already have one.  */
324
325     /* First try to decide what to do without reference to lookahead token.  */
326
327     yyn = yypact[yystate];
328     if (yyn == YYPACT_NINF)
329         goto yydefault;
330
331     /* Not known => get a lookahead token if don't already have one.  */
332
333     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
334     if (parser->yychar == YYEMPTY) {
335         YYDPRINTF ((Perl_debug_log, "Reading a token:\n"));
336         parser->yychar = yylex();
337     }
338
339     if (parser->yychar <= YYEOF) {
340         parser->yychar = yytoken = YYEOF;
341         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
342     }
343     else {
344         /* perly.tab is shipped based on an ASCII system, so need to index it
345          * with characters translated to ASCII.  Although it's not designed for
346          * this purpose, we can use NATIVE_TO_UNI here.  It returns its
347          * argument on ASCII platforms, and on EBCDIC translates native to
348          * ascii in the 0-255 range, leaving everything else unchanged.  This
349          * jibes with yylex() returning some bare characters in that range, but
350          * all tokens it returns are either 0, or above 255.  There could be a
351          * problem if NULs weren't 0, or were ever returned as raw chars by
352          * yylex() */
353         yytoken = YYTRANSLATE (NATIVE_TO_UNI(parser->yychar));
354         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
355     }
356
357     /* If the proper action on seeing token YYTOKEN is to reduce or to
358           detect an error, take that action.  */
359     yyn += yytoken;
360     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
361         goto yydefault;
362     yyn = yytable[yyn];
363     if (yyn <= 0) {
364         if (yyn == 0 || yyn == YYTABLE_NINF)
365             goto yyerrlab;
366         yyn = -yyn;
367         goto yyreduce;
368     }
369
370     if (yyn == YYFINAL)
371         YYACCEPT;
372
373     /* Shift the lookahead token.  */
374     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
375
376     /* Discard the token being shifted unless it is eof.  */
377     if (parser->yychar != YYEOF)
378         parser->yychar = YYEMPTY;
379
380     YYPUSHSTACK;
381     ps->state   = yyn;
382     ps->val     = parser->yylval;
383     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
384     ps->savestack_ix = PL_savestack_ix;
385 #ifdef DEBUGGING
386     ps->name    = (const char *)(yytname[yytoken]);
387 #endif
388
389     /* Count tokens shifted since error; after three, turn off error
390           status.  */
391     if (parser->yyerrstatus)
392         parser->yyerrstatus--;
393
394     goto yynewstate;
395
396
397   /*-----------------------------------------------------------.
398   | yydefault -- do the default action for the current state.  |
399   `-----------------------------------------------------------*/
400   yydefault:
401     yyn = yydefact[yystate];
402     if (yyn == 0)
403         goto yyerrlab;
404     goto yyreduce;
405
406
407   /*-----------------------------.
408   | yyreduce -- Do a reduction.  |
409   `-----------------------------*/
410   yyreduce:
411     /* yyn is the number of a rule to reduce with.  */
412     parser->yylen = yyr2[yyn];
413
414     /* If YYLEN is nonzero, implement the default value of the action:
415       "$$ = $1".
416
417       Otherwise, the following line sets YYVAL to garbage.
418       This behavior is undocumented and Bison
419       users should not rely upon it.  Assigning to YYVAL
420       unconditionally makes the parser a bit smaller, and it avoids a
421       GCC warning that YYVAL may be used uninitialized.  */
422     yyval = ps[1-parser->yylen].val;
423
424     YY_STACK_PRINT(parser);
425     YY_REDUCE_PRINT (yyn);
426
427     switch (yyn) {
428
429 /* contains all the rule actions; auto-generated from perly.y */
430 #include "perly.act"
431
432     }
433
434     {
435         int i;
436         for (i=0; i< parser->yylen; i++) {
437             SvREFCNT_dec(ps[-i].compcv);
438         }
439     }
440
441     parser->ps = ps -= (parser->yylen-1);
442
443     /* Now shift the result of the reduction.  Determine what state
444           that goes to, based on the state we popped back to and the rule
445           number reduced by.  */
446
447     ps->val     = yyval;
448     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
449     ps->savestack_ix = PL_savestack_ix;
450 #ifdef DEBUGGING
451     ps->name    = (const char *)(yytname [yyr1[yyn]]);
452 #endif
453
454     yyn = yyr1[yyn];
455
456     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
457     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
458         yystate = yytable[yystate];
459     else
460         yystate = yydefgoto[yyn - YYNTOKENS];
461     ps->state = yystate;
462
463     goto yynewstate;
464
465
466   /*------------------------------------.
467   | yyerrlab -- here on detecting error |
468   `------------------------------------*/
469   yyerrlab:
470     /* If not already recovering from an error, report this error.  */
471     if (!parser->yyerrstatus) {
472         yyerror ("syntax error");
473     }
474
475
476     if (parser->yyerrstatus == 3) {
477         /* If just tried and failed to reuse lookahead token after an
478               error, discard it.  */
479
480         /* Return failure if at end of input.  */
481         if (parser->yychar == YYEOF) {
482             /* Pop the error token.  */
483             SvREFCNT_dec(ps->compcv);
484             YYPOPSTACK;
485             /* Pop the rest of the stack.  */
486             while (ps > parser->stack) {
487                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
488                 LEAVE_SCOPE(ps->savestack_ix);
489                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
490                         && ps->val.opval)
491                 {
492                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
493                     if (ps->compcv != PL_compcv) {
494                         PL_compcv = ps->compcv;
495                         PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
496                     }
497                     op_free(ps->val.opval);
498                 }
499                 SvREFCNT_dec(ps->compcv);
500                 YYPOPSTACK;
501             }
502             YYABORT;
503         }
504
505         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
506         parser->yychar = YYEMPTY;
507
508     }
509
510     /* Else will try to reuse lookahead token after shifting the error
511           token.  */
512     goto yyerrlab1;
513
514
515   /*----------------------------------------------------.
516   | yyerrlab1 -- error raised explicitly by an action.  |
517   `----------------------------------------------------*/
518   yyerrlab1:
519     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
520
521     for (;;) {
522         yyn = yypact[yystate];
523         if (yyn != YYPACT_NINF) {
524             yyn += YYTERROR;
525             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
526                 yyn = yytable[yyn];
527                 if (0 < yyn)
528                     break;
529             }
530         }
531
532         /* Pop the current state because it cannot handle the error token.  */
533         if (ps == parser->stack)
534             YYABORT;
535
536         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
537         LEAVE_SCOPE(ps->savestack_ix);
538         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
539             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
540             if (ps->compcv != PL_compcv) {
541                 PL_compcv = ps->compcv;
542                 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
543             }
544             op_free(ps->val.opval);
545         }
546         SvREFCNT_dec(ps->compcv);
547         YYPOPSTACK;
548         yystate = ps->state;
549
550         YY_STACK_PRINT(parser);
551     }
552
553     if (yyn == YYFINAL)
554         YYACCEPT;
555
556     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
557
558     YYPUSHSTACK;
559     ps->state   = yyn;
560     ps->val     = parser->yylval;
561     ps->compcv  = (CV*)SvREFCNT_inc(PL_compcv);
562     ps->savestack_ix = PL_savestack_ix;
563 #ifdef DEBUGGING
564     ps->name    ="<err>";
565 #endif
566
567     goto yynewstate;
568
569
570   /*-------------------------------------.
571   | yyacceptlab -- YYACCEPT comes here.  |
572   `-------------------------------------*/
573   yyacceptlab:
574     yyresult = 0;
575     for (ps=parser->ps; ps > parser->stack; ps--) {
576         SvREFCNT_dec(ps->compcv);
577     }
578     parser->ps = parser->stack; /* disable cleanup */
579     goto yyreturn;
580
581   /*-----------------------------------.
582   | yyabortlab -- YYABORT comes here.  |
583   `-----------------------------------*/
584   yyabortlab:
585     yyresult = 1;
586     goto yyreturn;
587
588   yyreturn:
589     LEAVE;      /* force parser stack cleanup before we return */
590     return yyresult;
591 }
592
593 /*
594  * ex: set ts=8 sts=4 sw=4 et:
595  */