the unopened test should use a file handle distinct from "OTHER"
[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 #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     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-ones 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  */