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