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