This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update change 29607 to affect only Win32
[perl5.git] / perly.c
1 /*    perly.c
2  *
3  *    Copyright (c) 2004, 2005, 2006, 2007, by Larry Wall and others
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  * 
8  *    Note that this file was originally generated as an output from
9  *    GNU bison version 1.875, but now the code is statically maintained
10  *    and edited; the bits that are dependent on perly.y are now
11  *    #included from the files perly.tab and perly.act.
12  *
13  *    Here is an important copyright statement from the original, generated
14  *    file:
15  *
16  *      As a special exception, when this file is copied by Bison into a
17  *      Bison output file, you may use that output file without
18  *      restriction.  This special exception was added by the Free
19  *      Software Foundation in version 1.24 of Bison.
20  *
21  * Note that this file is also #included in madly.c, to allow compilation
22  * of a second parser, Perl_madparse, that is identical to Perl_yyparse,
23  * but which includes extra code for dumping the parse tree.
24  * This is controlled by the PERL_IN_MADLY_C define.
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_PERLY_C
29 #include "perl.h"
30
31 typedef unsigned char yytype_uint8;
32 typedef signed char yytype_int8;
33 typedef unsigned short int yytype_uint16;
34 typedef short int yytype_int16;
35 typedef signed char yysigned_char;
36
37 #ifdef DEBUGGING
38 #  define YYDEBUG 1
39 #else
40 #  define YYDEBUG 0
41 #endif
42
43 /* contains all the parser state tables; auto-generated from perly.y */
44 #include "perly.tab"
45
46 # define YYSIZE_T size_t
47
48 #define YYEOF           0
49 #define YYTERROR        1
50
51 #define YYACCEPT        goto yyacceptlab
52 #define YYABORT         goto yyabortlab
53 #define YYERROR         goto yyerrlab1
54
55 /* Enable debugging if requested.  */
56 #ifdef DEBUGGING
57
58 #  define yydebug (DEBUG_p_TEST)
59
60 #  define YYFPRINTF PerlIO_printf
61
62 #  define YYDPRINTF(Args)                       \
63 do {                                            \
64     if (yydebug)                                \
65         YYFPRINTF Args;                         \
66 } while (0)
67
68 #  define YYDSYMPRINTF(Title, Token, Value)                     \
69 do {                                                            \
70     if (yydebug) {                                              \
71         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
72         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
73         YYFPRINTF (Perl_debug_log, "\n");                       \
74     }                                                           \
75 } while (0)
76
77 /*--------------------------------.
78 | Print this symbol on YYOUTPUT.  |
79 `--------------------------------*/
80
81 static void
82 yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyvaluep)
83 {
84     if (yytype < YYNTOKENS) {
85         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
86 #   ifdef YYPRINT
87         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
88 #   else
89         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
90 #   endif
91     }
92     else
93         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
94
95     YYFPRINTF (yyoutput, ")");
96 }
97
98
99 /*  yy_stack_print()
100  *  print the top 8 items on the parse stack.
101  */
102
103 static void
104 yy_stack_print (pTHX_ const yy_parser *parser)
105 {
106     const yy_stack_frame *ps, *min;
107
108     min = parser->ps - 8 + 1;
109     if (min <= parser->stack)
110         min = parser->stack + 1;
111
112     PerlIO_printf(Perl_debug_log, "\nindex:");
113     for (ps = min; ps <= parser->ps; ps++)
114         PerlIO_printf(Perl_debug_log, " %8d", ps - parser->stack);
115
116     PerlIO_printf(Perl_debug_log, "\nstate:");
117     for (ps = min; ps <= parser->ps; ps++)
118         PerlIO_printf(Perl_debug_log, " %8d", ps->state);
119
120     PerlIO_printf(Perl_debug_log, "\ntoken:");
121     for (ps = min; ps <= parser->ps; ps++)
122         PerlIO_printf(Perl_debug_log, " %8.8s", ps->name);
123
124     PerlIO_printf(Perl_debug_log, "\nvalue:");
125     for (ps = min; ps <= parser->ps; ps++) {
126         switch (yy_type_tab[yystos[ps->state]]) {
127         case toketype_opval:
128             PerlIO_printf(Perl_debug_log, " %8.8s",
129                   ps->val.opval
130                     ? PL_op_name[ps->val.opval->op_type]
131                     : "(Nullop)"
132             );
133             break;
134 #ifndef PERL_IN_MADLY_C
135         case toketype_p_tkval:
136             PerlIO_printf(Perl_debug_log, " %8.8s",
137                   ps->val.pval ? ps->val.pval : "(NULL)");
138             break;
139
140         case toketype_i_tkval:
141 #endif
142         case toketype_ival:
143             PerlIO_printf(Perl_debug_log, " %8"IVdf, (IV)ps->val.ival);
144             break;
145         default:
146             PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)ps->val.ival);
147         }
148     }
149     PerlIO_printf(Perl_debug_log, "\n\n");
150 }
151
152 #  define YY_STACK_PRINT(parser)        \
153 do {                                    \
154     if (yydebug && DEBUG_v_TEST)        \
155         yy_stack_print (aTHX_ parser);  \
156 } while (0)
157
158
159 /*------------------------------------------------.
160 | Report that the YYRULE is going to be reduced.  |
161 `------------------------------------------------*/
162
163 static void
164 yy_reduce_print (pTHX_ int yyrule)
165 {
166     int yyi;
167     const unsigned int yylineno = yyrline[yyrule];
168     YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
169                           yyrule - 1, yylineno);
170     /* Print the symbols being reduced, and their result.  */
171     for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
172         YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
173     YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
174 }
175
176 #  define YY_REDUCE_PRINT(Rule)         \
177 do {                                    \
178     if (yydebug)                        \
179         yy_reduce_print (aTHX_ Rule);           \
180 } while (0)
181
182 #else /* !DEBUGGING */
183 #  define YYDPRINTF(Args)
184 #  define YYDSYMPRINTF(Title, Token, Value)
185 #  define YY_STACK_PRINT(parser)
186 #  define YY_REDUCE_PRINT(Rule)
187 #endif /* !DEBUGGING */
188
189 /* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
190  * parse stack, thus avoiding leaks if we die  */
191
192 static void
193 S_clear_yystack(pTHX_  const yy_parser *parser)
194 {
195     yy_stack_frame *ps     = parser->ps;
196     int i;
197
198     if (!parser->stack || ps == parser->stack)
199         return;
200
201     YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
202
203     /* Freeing ops on the stack, and the op_latefree / op_latefreed /
204      * op_attached flags:
205      *
206      * When we pop tokens off the stack during error recovery, or when
207      * we pop all the tokens off the stack after a die during a shift or
208      * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
209      * newFOO() functions), then it's possible that some of these tokens are
210      * of type opval, pointing to an OP. All these ops are orphans; each is
211      * its own miniature subtree that has not yet been attached to a
212      * larger tree. In this case, we should clearly free the op (making
213      * sure, for each op we free that we have PL_comppad pointing to the
214      * right place for freeing any SVs attached to the op in threaded
215      * builds.
216      *
217      * However, there is a particular problem if we die in newFOO() called
218      * by a reducing action; e.g.
219      *
220      *    foo : bar baz boz
221      *        { $$ = newFOO($1,$2,$3) }
222      *
223      * where
224      *  OP *newFOO { ....; if (...) croak; .... }
225      *
226      * In this case, when we come to clean bar baz and boz off the stack,
227      * we don't know whether newFOO() has already:
228      *    * freed them
229      *    * left them as is
230      *    * attached them to part of a larger tree
231      *    * attached them to PL_compcv
232      *    * attached them to PL_compcv then freed it (as in BEGIN {die } )
233      *
234      * To get round this problem, we set the flag op_latefree on every op
235      * that gets pushed onto the parser stack. If op_free() sees this
236      * flag, it clears the op and frees any children,, but *doesn't* free
237      * the op itself; instead it sets the op_latefreed flag. This means
238      * that we can safely call op_free() multiple times on each stack op.
239      * So, when clearing the stack, we first, for each op that was being
240      * reduced, call op_free with op_latefree=1. This ensures that all ops
241      * hanging off these op are freed, but the reducing ops themselces are
242      * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
243      * and free them. A little thought should convince you that this
244      * two-part approach to the reducing ops should handle the first three
245      * cases above safely.
246      *
247      * In the case of attaching to PL_compcv (currently just newATTRSUB
248      * does this), then  we set the op_attached flag on the op that has
249      * been so attached, then avoid doing the final op_free during
250      * cleanup, on the assumption that it will happen (or has already
251      * happened) when PL_compcv is freed.
252      *
253      * Note this is fairly fragile mechanism. A more robust approach
254      * would be to use two of these flag bits as 2-bit reference count
255      * field for each op, indicating whether it is pointed to from:
256      *   * a parent op
257      *   * the parser stack
258      *   * a CV
259      * but this would involve reworking all code (core and external) that
260      * manipulate op trees.
261      */
262
263     /* clear any reducing ops (1st pass) */
264
265     for (i=0; i< parser->yylen; i++) {
266         if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
267             && ps[-i].val.opval) {
268             if ( ! (ps[-i].val.opval->op_attached
269                     && !ps[-i].val.opval->op_latefreed))
270             {
271                 if (ps[-i].comppad != PL_comppad) {
272                     PAD_RESTORE_LOCAL(ps[-i].comppad);
273                 }
274                 op_free(ps[-i].val.opval);
275             }
276         }
277     }
278
279     /* now free whole the stack, including the just-reduced ops */
280
281     while (ps > parser->stack) {
282         if (yy_type_tab[yystos[ps->state]] == toketype_opval
283             && ps->val.opval)
284         {
285             if (ps->comppad != PL_comppad) {
286                 PAD_RESTORE_LOCAL(ps->comppad);
287             }
288             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
289             ps->val.opval->op_latefree  = 0;
290             if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
291                 op_free(ps->val.opval);
292         }
293         ps--;
294     }
295 }
296
297 /* delete a parser object */
298
299 #ifndef PERL_IN_MADLY_C
300 void
301 Perl_parser_free(pTHX_  const yy_parser *parser)
302 {
303     S_clear_yystack(aTHX_ parser);
304     Safefree(parser->stack);
305     PL_parser = parser->old_parser;
306 }
307 #endif
308
309 /*----------.
310 | yyparse.  |
311 `----------*/
312
313 int
314 #ifdef PERL_IN_MADLY_C
315 Perl_madparse (pTHX)
316 #else
317 Perl_yyparse (pTHX)
318 #endif
319 {
320     dVAR;
321     register int yystate;
322     register int yyn;
323     int yyresult;
324
325     /* Lookahead token as an internal (translated) token number.  */
326     int yytoken = 0;
327
328     register yy_parser *parser;     /* the parser object */
329     register yy_stack_frame  *ps;   /* current parser stack frame */
330
331 #define YYPOPSTACK   parser->ps = --ps
332 #define YYPUSHSTACK  parser->ps = ++ps
333
334     /* The variable used to return semantic value and location from the
335           action routines: ie $$.  */
336     YYSTYPE yyval;
337
338 #ifndef PERL_IN_MADLY_C
339 #  ifdef PERL_MAD
340     if (PL_madskills)
341         return madparse();
342 #  endif
343 #endif
344
345     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
346
347     parser = PL_parser;
348     ps = parser->ps;
349
350     ENTER;  /* force parser free before we return */
351     SAVEDESTRUCTOR_X(Perl_parser_free, (void*) parser);
352
353 /*------------------------------------------------------------.
354 | yynewstate -- Push a new state, which is found in yystate.  |
355 `------------------------------------------------------------*/
356   yynewstate:
357
358     yystate = ps->state;
359
360     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
361
362     if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) {
363         ps->val.opval->op_latefree  = 1;
364         ps->val.opval->op_latefreed = 0;
365     }
366
367     parser->yylen = 0;
368
369     {
370         size_t size = ps - parser->stack + 1;
371
372         /* grow the stack? We always leave 1 spare slot,
373          * in case of a '' -> 'foo' reduction */
374
375         if (size >= parser->stack_size - 1) {
376             /* this will croak on insufficient memory */
377             parser->stack_size *= 2;
378             Renew(parser->stack, parser->stack_size, yy_stack_frame);
379             ps = parser->ps = parser->stack + size -1;
380
381             YYDPRINTF((Perl_debug_log,
382                             "parser stack size increased to %lu frames\n",
383                             (unsigned long int)parser->stack_size));
384         }
385     }
386
387 /* Do appropriate processing given the current state.  */
388 /* Read a lookahead token if we need one and don't already have one.  */
389
390     /* First try to decide what to do without reference to lookahead token.  */
391
392     yyn = yypact[yystate];
393     if (yyn == YYPACT_NINF)
394         goto yydefault;
395
396     /* Not known => get a lookahead token if don't already have one.  */
397
398     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
399     if (parser->yychar == YYEMPTY) {
400         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
401 #ifdef PERL_IN_MADLY_C
402         parser->yychar = PL_madskills ? madlex() : yylex();
403 #else
404         parser->yychar = yylex();
405 #endif
406
407 #  ifdef EBCDIC
408         if (parser->yychar >= 0 && parser->yychar < 255) {
409             parser->yychar = NATIVE_TO_ASCII(parser->yychar);
410         }
411 #  endif
412     }
413
414     if (parser->yychar <= YYEOF) {
415         parser->yychar = yytoken = YYEOF;
416         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
417     }
418     else {
419         yytoken = YYTRANSLATE (parser->yychar);
420         YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval);
421     }
422
423     /* If the proper action on seeing token YYTOKEN is to reduce or to
424           detect an error, take that action.  */
425     yyn += yytoken;
426     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
427         goto yydefault;
428     yyn = yytable[yyn];
429     if (yyn <= 0) {
430         if (yyn == 0 || yyn == YYTABLE_NINF)
431             goto yyerrlab;
432         yyn = -yyn;
433         goto yyreduce;
434     }
435
436     if (yyn == YYFINAL)
437         YYACCEPT;
438
439     /* Shift the lookahead token.  */
440     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
441
442     /* Discard the token being shifted unless it is eof.  */
443     if (parser->yychar != YYEOF)
444         parser->yychar = YYEMPTY;
445
446     YYPUSHSTACK;
447     ps->state   = yyn;
448     ps->val     = parser->yylval;
449     ps->comppad = PL_comppad;
450 #ifdef DEBUGGING
451     ps->name    = (const char *)(yytname[yytoken]);
452 #endif
453
454     /* Count tokens shifted since error; after three, turn off error
455           status.  */
456     if (parser->yyerrstatus)
457         parser->yyerrstatus--;
458
459     goto yynewstate;
460
461
462   /*-----------------------------------------------------------.
463   | yydefault -- do the default action for the current state.  |
464   `-----------------------------------------------------------*/
465   yydefault:
466     yyn = yydefact[yystate];
467     if (yyn == 0)
468         goto yyerrlab;
469     goto yyreduce;
470
471
472   /*-----------------------------.
473   | yyreduce -- Do a reduction.  |
474   `-----------------------------*/
475   yyreduce:
476     /* yyn is the number of a rule to reduce with.  */
477     parser->yylen = yyr2[yyn];
478
479     /* If YYLEN is nonzero, implement the default value of the action:
480       "$$ = $1".
481
482       Otherwise, the following line sets YYVAL to garbage.
483       This behavior is undocumented and Bison
484       users should not rely upon it.  Assigning to YYVAL
485       unconditionally makes the parser a bit smaller, and it avoids a
486       GCC warning that YYVAL may be used uninitialized.  */
487     yyval = ps[1-parser->yylen].val;
488
489     YY_STACK_PRINT(parser);
490     YY_REDUCE_PRINT (yyn);
491
492     switch (yyn) {
493
494
495 #define dep() deprecate("\"do\" to call subroutines")
496
497 #ifdef PERL_IN_MADLY_C
498 #  define IVAL(i) (i)->tk_lval.ival
499 #  define PVAL(p) (p)->tk_lval.pval
500 #  define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c))
501 #  define TOKEN_FREE(a) token_free(a)
502 #  define OP_GETMAD(a,b,c) op_getmad((a),(b),(c))
503 #  define IF_MAD(a,b) (a)
504 #  define DO_MAD(a) a
505 #  define MAD
506 #else
507 #  define IVAL(i) (i)
508 #  define PVAL(p) (p)
509 #  define TOKEN_GETMAD(a,b,c)
510 #  define TOKEN_FREE(a)
511 #  define OP_GETMAD(a,b,c)
512 #  define IF_MAD(a,b) (b)
513 #  define DO_MAD(a)
514 #  undef MAD
515 #endif
516
517 /* contains all the rule actions; auto-generated from perly.y */
518 #include "perly.act"
519
520     }
521
522     /* any just-reduced ops with the op_latefreed flag cleared need to be
523      * freed; the rest need the flag resetting */
524     {
525         int i;
526         for (i=0; i< parser->yylen; i++) {
527             if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
528                 && ps[-i].val.opval)
529             {
530                 ps[-i].val.opval->op_latefree = 0;
531                 if (ps[-i].val.opval->op_latefreed)
532                     op_free(ps[-i].val.opval);
533             }
534         }
535     }
536
537     parser->ps = ps -= (parser->yylen-1);
538
539     /* Now shift the result of the reduction.  Determine what state
540           that goes to, based on the state we popped back to and the rule
541           number reduced by.  */
542
543     ps->val     = yyval;
544     ps->comppad = PL_comppad;
545 #ifdef DEBUGGING
546     ps->name    = (const char *)(yytname [yyr1[yyn]]);
547 #endif
548
549     yyn = yyr1[yyn];
550
551     yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state;
552     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state)
553         yystate = yytable[yystate];
554     else
555         yystate = yydefgoto[yyn - YYNTOKENS];
556     ps->state = yystate;
557
558     goto yynewstate;
559
560
561   /*------------------------------------.
562   | yyerrlab -- here on detecting error |
563   `------------------------------------*/
564   yyerrlab:
565     /* If not already recovering from an error, report this error.  */
566     if (!parser->yyerrstatus) {
567         yyerror ("syntax error");
568     }
569
570
571     if (parser->yyerrstatus == 3) {
572         /* If just tried and failed to reuse lookahead token after an
573               error, discard it.  */
574
575         /* Return failure if at end of input.  */
576         if (parser->yychar == YYEOF) {
577             /* Pop the error token.  */
578             YYPOPSTACK;
579             /* Pop the rest of the stack.  */
580             while (ps > parser->stack) {
581                 YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
582                 if (yy_type_tab[yystos[ps->state]] == toketype_opval
583                         && ps->val.opval)
584                 {
585                     YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
586                     if (ps->comppad != PL_comppad) {
587                         PAD_RESTORE_LOCAL(ps->comppad);
588                     }
589                     ps->val.opval->op_latefree  = 0;
590                     op_free(ps->val.opval);
591                 }
592                 YYPOPSTACK;
593             }
594             YYABORT;
595         }
596
597         YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
598         parser->yychar = YYEMPTY;
599
600     }
601
602     /* Else will try to reuse lookahead token after shifting the error
603           token.  */
604     goto yyerrlab1;
605
606
607   /*----------------------------------------------------.
608   | yyerrlab1 -- error raised explicitly by an action.  |
609   `----------------------------------------------------*/
610   yyerrlab1:
611     parser->yyerrstatus = 3;    /* Each real token shifted decrements this.  */
612
613     for (;;) {
614         yyn = yypact[yystate];
615         if (yyn != YYPACT_NINF) {
616             yyn += YYTERROR;
617             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
618                 yyn = yytable[yyn];
619                 if (0 < yyn)
620                     break;
621             }
622         }
623
624         /* Pop the current state because it cannot handle the error token.  */
625         if (ps == parser->stack)
626             YYABORT;
627
628         YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val);
629         if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) {
630             YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
631             if (ps->comppad != PL_comppad) {
632                 PAD_RESTORE_LOCAL(ps->comppad);
633             }
634             ps->val.opval->op_latefree  = 0;
635             op_free(ps->val.opval);
636         }
637         YYPOPSTACK;
638         yystate = ps->state;
639
640         YY_STACK_PRINT(parser);
641     }
642
643     if (yyn == YYFINAL)
644         YYACCEPT;
645
646     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
647
648     YYPUSHSTACK;
649     ps->state   = yyn;
650     ps->val     = parser->yylval;
651     ps->comppad = PL_comppad;
652 #ifdef DEBUGGING
653     ps->name    ="<err>";
654 #endif
655
656     goto yynewstate;
657
658
659   /*-------------------------------------.
660   | yyacceptlab -- YYACCEPT comes here.  |
661   `-------------------------------------*/
662   yyacceptlab:
663     yyresult = 0;
664     parser->ps = parser->stack; /* disable cleanup */
665     goto yyreturn;
666
667   /*-----------------------------------.
668   | yyabortlab -- YYABORT comes here.  |
669   `-----------------------------------*/
670   yyabortlab:
671     yyresult = 1;
672     goto yyreturn;
673
674   yyreturn:
675     LEAVE;                      /* force parser free before we return */
676     return yyresult;
677 }
678
679 /*
680  * Local variables:
681  * c-indentation-style: bsd
682  * c-basic-offset: 4
683  * indent-tabs-mode: t
684  * End:
685  *
686  * ex: set ts=8 sts=4 sw=4 noet:
687  */