This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove the last STRLEN n_a;s that my compiler can reach.
[perl5.git] / perly.c
1 /*    perly.c
2  *
3  *    Copyright (c) 2004 Larry Wall
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 #included
11  *    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
22
23 /* allow stack size to grow effectively without limit */
24 #define YYMAXDEPTH 10000000
25
26 #include "EXTERN.h"
27 #define PERL_IN_PERLY_C
28 #include "perl.h"
29
30 typedef signed char yysigned_char;
31
32 #ifdef DEBUGGING
33 #  define YYDEBUG 1
34 #else
35 #  define YYDEBUG 0
36 #endif
37
38 /* contains all the parser state tables; auto-generated from perly.y */
39 #include "perly.tab"
40
41 # define YYSIZE_T size_t
42
43 #define yyerrok         (yyerrstatus = 0)
44 #define yyclearin       (yychar = YYEMPTY)
45 #define YYEMPTY         (-2)
46 #define YYEOF           0
47
48 #define YYACCEPT        goto yyacceptlab
49 #define YYABORT         goto yyabortlab
50 #define YYERROR         goto yyerrlab1
51
52
53 /* Like YYERROR except do call yyerror.  This remains here temporarily
54    to ease the transition to the new meaning of YYERROR, for GCC.
55    Once GCC version 2 has supplanted version 1, this can go.  */
56
57 #define YYFAIL          goto yyerrlab
58
59 #define YYRECOVERING()  (!!yyerrstatus)
60
61 #define YYBACKUP(Token, Value)                                  \
62 do                                                              \
63     if (yychar == YYEMPTY && yylen == 1) {                      \
64         yychar = (Token);                                       \
65         yylval = (Value);                                       \
66         yytoken = YYTRANSLATE (yychar);                         \
67         YYPOPSTACK;                                             \
68         goto yybackup;                                          \
69     }                                                           \
70     else {                                                      \
71         yyerror ("syntax error: cannot back up");               \
72         YYERROR;                                                \
73     }                                                           \
74 while (0)
75
76 #define YYTERROR        1
77 #define YYERRCODE       256
78
79 /* Enable debugging if requested.  */
80 #ifdef DEBUGGING
81
82 #  define yydebug (DEBUG_p_TEST)
83
84 #  define YYFPRINTF PerlIO_printf
85
86 #  define YYDPRINTF(Args)                       \
87 do {                                            \
88     if (yydebug)                                \
89         YYFPRINTF Args;                         \
90 } while (0)
91
92 #  define YYDSYMPRINT(Args)                     \
93 do {                                            \
94     if (yydebug)                                \
95         yysymprint Args;                        \
96 } while (0)
97
98 #  define YYDSYMPRINTF(Title, Token, Value)                     \
99 do {                                                            \
100     if (yydebug) {                                              \
101         YYFPRINTF (Perl_debug_log, "%s ", Title);               \
102         yysymprint (aTHX_ Perl_debug_log,  Token, Value);       \
103         YYFPRINTF (Perl_debug_log, "\n");                       \
104     }                                                           \
105 } while (0)
106
107 /*--------------------------------.
108 | Print this symbol on YYOUTPUT.  |
109 `--------------------------------*/
110
111 static void
112 yysymprint (pTHX_ PerlIO *yyoutput, int yytype, const YYSTYPE *yyvaluep)
113 {
114     if (yytype < YYNTOKENS) {
115         YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
116 #   ifdef YYPRINT
117         YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
118 #   else
119         YYFPRINTF (yyoutput, "0x%"UVxf, (UV)yyvaluep->ival);
120 #   endif
121     }
122     else
123         YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
124
125     YYFPRINTF (yyoutput, ")");
126 }
127
128
129 /*  yy_stack_print()
130  *  print the top 8 items on the parse stack.  The args have the same
131  *  meanings as the local vars in yyparse() of the same name */
132
133 static void
134 yy_stack_print (pTHX_ const short *yyss, const short *yyssp, const YYSTYPE *yyvs, const char**yyns)
135 {
136     int i;
137     int start = 1;
138     int count = (int)(yyssp - yyss);
139
140     if (count > 8) {
141         start = count - 8 + 1;
142         count = 8;
143     }
144
145     PerlIO_printf(Perl_debug_log, "\nindex:");
146     for (i=0; i < count; i++)
147         PerlIO_printf(Perl_debug_log, " %8d", start+i);
148     PerlIO_printf(Perl_debug_log, "\nstate:");
149     for (i=0, yyss += start; i < count; i++, yyss++)
150         PerlIO_printf(Perl_debug_log, " %8d", *yyss);
151     PerlIO_printf(Perl_debug_log, "\ntoken:");
152     for (i=0, yyns += start; i < count; i++, yyns++)
153         PerlIO_printf(Perl_debug_log, " %8.8s", *yyns);
154     PerlIO_printf(Perl_debug_log, "\nvalue:");
155     for (i=0, yyvs += start; i < count; i++, yyvs++)
156         PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)yyvs->ival);
157     PerlIO_printf(Perl_debug_log, "\n\n");
158 }
159
160 #  define YY_STACK_PRINT(yyss, yyssp, yyvs, yyns)               \
161 do {                                                            \
162     if (yydebug && DEBUG_v_TEST)                                \
163         yy_stack_print (aTHX_ (yyss), (yyssp), (yyvs), (yyns)); \
164 } while (0)
165
166
167 /*------------------------------------------------.
168 | Report that the YYRULE is going to be reduced.  |
169 `------------------------------------------------*/
170
171 static void
172 yy_reduce_print (pTHX_ int yyrule)
173 {
174     int yyi;
175     const unsigned int yylineno = yyrline[yyrule];
176     YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ",
177                           yyrule - 1, yylineno);
178     /* Print the symbols being reduced, and their result.  */
179     for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
180         YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]);
181     YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]);
182 }
183
184 #  define YY_REDUCE_PRINT(Rule)         \
185 do {                                    \
186     if (yydebug)                        \
187         yy_reduce_print (aTHX_ Rule);           \
188 } while (0)
189
190 #else /* !DEBUGGING */
191 #  define YYDPRINTF(Args)
192 #  define YYDSYMPRINT(Args)
193 #  define YYDSYMPRINTF(Title, Token, Value)
194 #  define YY_STACK_PRINT(yyss, yyssp, yyvs, yyns)
195 #  define YY_REDUCE_PRINT(Rule)
196 #endif /* !DEBUGGING */
197
198
199 /* YYINITDEPTH -- initial size of the parser's stacks.  */
200 #ifndef YYINITDEPTH
201 # define YYINITDEPTH 200
202 #endif
203
204
205 #if YYERROR_VERBOSE
206 #  ifndef yystrlen
207 #    if defined (__GLIBC__) && defined (_STRING_H)
208 #      define yystrlen strlen
209 #    else
210 /* Return the length of YYSTR.  */
211 static YYSIZE_T
212 yystrlen (const char *yystr)
213 {
214     register const char *yys = yystr;
215
216     while (*yys++ != '\0')
217         continue;
218
219     return yys - yystr - 1;
220 }
221 #    endif
222 #  endif
223
224 #  ifndef yystpcpy
225 #    if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE)
226 #      define yystpcpy stpcpy
227 #    else
228 /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
229    YYDEST.  */
230 static char *
231 yystpcpy (pTHX_ char *yydest, const char *yysrc)
232 {
233     register char *yyd = yydest;
234     register const char *yys = yysrc;
235
236     while ((*yyd++ = *yys++) != '\0')
237         continue;
238
239     return yyd - 1;
240 }
241 #    endif
242 #  endif
243
244 #endif /* !YYERROR_VERBOSE */
245
246 /*----------.
247 | yyparse.  |
248 `----------*/
249
250 int
251 Perl_yyparse (pTHX)
252 {
253     int yychar; /* The lookahead symbol.  */
254     YYSTYPE yylval; /* The semantic value of the lookahead symbol.  */
255     int yynerrs; /* Number of syntax errors so far.  */
256     register int yystate;
257     register int yyn;
258     int yyresult;
259
260     /* Number of tokens to shift before error messages enabled.  */
261     int yyerrstatus;
262     /* Lookahead token as an internal (translated) token number.  */
263     int yytoken = 0;
264
265     /* two stacks and their tools:
266           yyss: related to states,
267           yyvs: related to semantic values,
268
269           Refer to the stacks thru separate pointers, to allow yyoverflow
270           to reallocate them elsewhere.  */
271
272     /* The state stack.  */
273     short *yyss;
274     register short *yyssp;
275
276     /* The semantic value stack.  */
277     YYSTYPE *yyvs;
278     register YYSTYPE *yyvsp;
279
280     /* for ease of re-allocation and automatic freeing, have two SVs whose
281       * SvPVX points to the stacks */
282     SV *yyss_sv, *yyvs_sv;
283
284 #ifdef DEBUGGING
285     /* maintain also a stack of token/rule names for debugging with -Dpv */
286     const char **yyns, **yynsp;
287     SV *yyns_sv;
288 #  define YYPOPSTACK   (yyvsp--, yyssp--, yynsp--)
289 #else
290 #  define YYPOPSTACK   (yyvsp--, yyssp--)
291 #endif
292
293
294     YYSIZE_T yystacksize = YYINITDEPTH;
295
296     /* The variables used to return semantic value and location from the
297           action routines.  */
298     YYSTYPE yyval;
299
300
301     /* When reducing, the number of symbols on the RHS of the reduced
302           rule.  */
303     int yylen;
304
305     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
306
307     ENTER;                      /* force stack free before we return */
308     SAVEVPTR(PL_yycharp);
309     SAVEVPTR(PL_yylvalp);
310     PL_yycharp = &yychar; /* so PL_yyerror() can access it */
311     PL_yylvalp = &yylval; /* so various functions in toke.c can access it */
312
313     yyss_sv = NEWSV(73, YYINITDEPTH * sizeof(short));
314     yyvs_sv = NEWSV(73, YYINITDEPTH * sizeof(YYSTYPE));
315     SAVEFREESV(yyss_sv);
316     SAVEFREESV(yyvs_sv);
317     yyss = (short *) SvPVX(yyss_sv);
318     yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
319     /* note that elements zero of yyvs and yyns are not used */
320     yyssp = yyss;
321     yyvsp = yyvs;
322 #ifdef DEBUGGING
323     yyns_sv = NEWSV(73, YYINITDEPTH * sizeof(char *));
324     SAVEFREESV(yyns_sv);
325     /* XXX This seems strange to cast char * to char ** */
326     yyns = (const char **) SvPVX(yyns_sv);
327     yynsp = yyns;
328 #endif
329
330     yystate = 0;
331     yyerrstatus = 0;
332     yynerrs = 0;
333     yychar = YYEMPTY;           /* Cause a token to be read.  */
334
335
336
337     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
338
339     goto yysetstate;
340
341 /*------------------------------------------------------------.
342 | yynewstate -- Push a new state, which is found in yystate.  |
343 `------------------------------------------------------------*/
344   yynewstate:
345     /* In all cases, when you get here, the value and location stacks
346           have just been pushed. so pushing a state here evens the stacks.
347           */
348     yyssp++;
349
350   yysetstate:
351     *yyssp = yystate;
352
353     if (yyss + yystacksize - 1 <= yyssp) {
354          /* Get the current used size of the three stacks, in elements.  */
355          const YYSIZE_T yysize = yyssp - yyss + 1;
356
357          /* Extend the stack our own way.  */
358          if (YYMAXDEPTH <= yystacksize)
359                goto yyoverflowlab;
360          yystacksize *= 2;
361          if (YYMAXDEPTH < yystacksize)
362                yystacksize = YYMAXDEPTH;
363
364          SvGROW(yyss_sv, yystacksize * sizeof(short));
365          SvGROW(yyvs_sv, yystacksize * sizeof(YYSTYPE));
366          yyss = (short *) SvPVX(yyss_sv);
367          yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
368 #ifdef DEBUGGING
369          SvGROW(yyns_sv, yystacksize * sizeof(char *));
370          /* XXX This seems strange to cast char * to char ** */
371          yyns = (const char **) SvPVX(yyns_sv);
372          if (! yyns)
373                goto yyoverflowlab;
374          yynsp = yyns + yysize - 1;
375 #endif
376          if (!yyss || ! yyvs)
377                goto yyoverflowlab;
378
379          yyssp = yyss + yysize - 1;
380          yyvsp = yyvs + yysize - 1;
381
382
383          YYDPRINTF ((Perl_debug_log, "Stack size increased to %lu\n",
384                                    (unsigned long int) yystacksize));
385
386          if (yyss + yystacksize - 1 <= yyssp)
387                YYABORT;
388     }
389
390     goto yybackup;
391
392   /*-----------.
393   | yybackup.  |
394   `-----------*/
395   yybackup:
396
397 /* Do appropriate processing given the current state.  */
398 /* Read a lookahead token if we need one and don't already have one.  */
399 /* yyresume: */
400
401     /* First try to decide what to do without reference to lookahead token.  */
402
403     yyn = yypact[yystate];
404     if (yyn == YYPACT_NINF)
405         goto yydefault;
406
407     /* Not known => get a lookahead token if don't already have one.  */
408
409     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
410     if (yychar == YYEMPTY) {
411         YYDPRINTF ((Perl_debug_log, "Reading a token: "));
412         yychar = yylex();
413 #  ifdef EBCDIC
414         if (yychar >= 0 && yychar < 255) {
415             yychar = NATIVE_TO_ASCII(yychar);
416         }
417 #  endif
418     }
419
420     if (yychar <= YYEOF) {
421         yychar = yytoken = YYEOF;
422         YYDPRINTF ((Perl_debug_log, "Now at end of input.\n"));
423     }
424     else {
425         yytoken = YYTRANSLATE (yychar);
426         YYDSYMPRINTF ("Next token is", yytoken, &yylval);
427     }
428
429     /* If the proper action on seeing token YYTOKEN is to reduce or to
430           detect an error, take that action.  */
431     yyn += yytoken;
432     if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
433         goto yydefault;
434     yyn = yytable[yyn];
435     if (yyn <= 0) {
436         if (yyn == 0 || yyn == YYTABLE_NINF)
437             goto yyerrlab;
438         yyn = -yyn;
439         goto yyreduce;
440     }
441
442     if (yyn == YYFINAL)
443         YYACCEPT;
444
445     /* Shift the lookahead token.  */
446     YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken]));
447
448     /* Discard the token being shifted unless it is eof.  */
449     if (yychar != YYEOF)
450         yychar = YYEMPTY;
451
452     *++yyvsp = yylval;
453 #ifdef DEBUGGING
454     *++yynsp = (const char *)(yytname[yytoken]);
455 #endif
456
457
458     /* Count tokens shifted since error; after three, turn off error
459           status.  */
460     if (yyerrstatus)
461         yyerrstatus--;
462
463     yystate = yyn;
464     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
465
466     goto yynewstate;
467
468
469   /*-----------------------------------------------------------.
470   | yydefault -- do the default action for the current state.  |
471   `-----------------------------------------------------------*/
472   yydefault:
473     yyn = yydefact[yystate];
474     if (yyn == 0)
475         goto yyerrlab;
476     goto yyreduce;
477
478
479   /*-----------------------------.
480   | yyreduce -- Do a reduction.  |
481   `-----------------------------*/
482   yyreduce:
483     /* yyn is the number of a rule to reduce with.  */
484     yylen = yyr2[yyn];
485
486     /* If YYLEN is nonzero, implement the default value of the action:
487       "$$ = $1".
488
489       Otherwise, the following line sets YYVAL to garbage.
490       This behavior is undocumented and Bison
491       users should not rely upon it.  Assigning to YYVAL
492       unconditionally makes the parser a bit smaller, and it avoids a
493       GCC warning that YYVAL may be used uninitialized.  */
494     yyval = yyvsp[1-yylen];
495
496
497     YY_REDUCE_PRINT (yyn);
498     switch (yyn) {
499
500 /* contains all the rule actions; auto-generated from perly.y */
501
502 #define dep() deprecate("\"do\" to call subroutines")
503 #include "perly.act"
504
505     }
506
507     yyvsp -= yylen;
508     yyssp -= yylen;
509 #ifdef DEBUGGING
510     yynsp -= yylen;
511 #endif
512
513
514     *++yyvsp = yyval;
515 #ifdef DEBUGGING
516     *++yynsp = (const char *)(yytname [yyr1[yyn]]);
517 #endif
518
519     /* Now shift the result of the reduction.  Determine what state
520           that goes to, based on the state we popped back to and the rule
521           number reduced by.  */
522
523     yyn = yyr1[yyn];
524
525     yystate = yypgoto[yyn - YYNTOKENS] + *yyssp;
526     if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp)
527         yystate = yytable[yystate];
528     else
529         yystate = yydefgoto[yyn - YYNTOKENS];
530
531     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
532
533 #ifdef DEBUGGING
534     /* tmp push yystate for stack print; this is normally pushed later in
535      * yynewstate */
536     yyssp++;
537     *yyssp = yystate;
538     YY_STACK_PRINT (yyss, yyssp, yyvs, yyns);
539     yyssp--;
540 #endif
541
542     goto yynewstate;
543
544
545   /*------------------------------------.
546   | yyerrlab -- here on detecting error |
547   `------------------------------------*/
548   yyerrlab:
549     /* If not already recovering from an error, report this error.  */
550     if (!yyerrstatus) {
551         ++yynerrs;
552 #if YYERROR_VERBOSE
553         yyn = yypact[yystate];
554
555         if (YYPACT_NINF < yyn && yyn < YYLAST) {
556             YYSIZE_T yysize = 0;
557             const int yytype = YYTRANSLATE (yychar);
558             char *yymsg;
559             int yyx, yycount;
560
561             yycount = 0;
562             /* Start YYX at -YYN if negative to avoid negative indexes in
563                   YYCHECK.  */
564             for (yyx = yyn < 0 ? -yyn : 0;
565                       yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++)
566                 if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
567                     yysize += yystrlen (yytname[yyx]) + 15, yycount++;
568             yysize += yystrlen ("syntax error, unexpected ") + 1;
569             yysize += yystrlen (yytname[yytype]);
570             Newx(yymsg, yysize, char *);
571             if (yymsg != 0) {
572                 const char *yyp = yystpcpy (yymsg, "syntax error, unexpected ");
573                 yyp = yystpcpy (yyp, yytname[yytype]);
574
575                 if (yycount < 5) {
576                     yycount = 0;
577                     for (yyx = yyn < 0 ? -yyn : 0;
578                               yyx < (int) (sizeof (yytname) / sizeof (char *));
579                               yyx++)
580                     {
581                         if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) {
582                             const char *yyq = ! yycount ?
583                                                     ", expecting " : " or ";
584                             yyp = yystpcpy (yyp, yyq);
585                             yyp = yystpcpy (yyp, yytname[yyx]);
586                             yycount++;
587                         }
588                     }
589                 }
590                 yyerror (yymsg);
591                 YYSTACK_FREE (yymsg);
592             }
593             else
594                 yyerror ("syntax error; also virtual memory exhausted");
595         }
596         else
597 #endif /* YYERROR_VERBOSE */
598             yyerror ("syntax error");
599     }
600
601
602     if (yyerrstatus == 3) {
603         /* If just tried and failed to reuse lookahead token after an
604               error, discard it.  */
605
606         /* Return failure if at end of input.  */
607         if (yychar == YYEOF) {
608             /* Pop the error token.  */
609             YYPOPSTACK;
610             /* Pop the rest of the stack.  */
611             while (yyss < yyssp) {
612                 YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
613                 YYPOPSTACK;
614             }
615             YYABORT;
616         }
617
618         YYDSYMPRINTF ("Error: discarding", yytoken, &yylval);
619         yychar = YYEMPTY;
620
621     }
622
623     /* Else will try to reuse lookahead token after shifting the error
624           token.  */
625     goto yyerrlab1;
626
627
628   /*----------------------------------------------------.
629   | yyerrlab1 -- error raised explicitly by an action.  |
630   `----------------------------------------------------*/
631   yyerrlab1:
632     yyerrstatus = 3;    /* Each real token shifted decrements this.  */
633
634     for (;;) {
635         yyn = yypact[yystate];
636         if (yyn != YYPACT_NINF) {
637             yyn += YYTERROR;
638             if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) {
639                 yyn = yytable[yyn];
640                 if (0 < yyn)
641                     break;
642             }
643         }
644
645         /* Pop the current state because it cannot handle the error token.  */
646         if (yyssp == yyss)
647             YYABORT;
648
649         YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
650         yyvsp--;
651 #ifdef DEBUGGING
652         yynsp--;
653 #endif
654         yystate = *--yyssp;
655
656         YY_STACK_PRINT (yyss, yyssp, yyvs, yyns);
657     }
658
659     if (yyn == YYFINAL)
660         YYACCEPT;
661
662     YYDPRINTF ((Perl_debug_log, "Shifting error token, "));
663
664     *++yyvsp = yylval;
665 #ifdef DEBUGGING
666     *++yynsp ="<err>";
667 #endif
668
669     yystate = yyn;
670     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
671
672     goto yynewstate;
673
674
675   /*-------------------------------------.
676   | yyacceptlab -- YYACCEPT comes here.  |
677   `-------------------------------------*/
678   yyacceptlab:
679     yyresult = 0;
680     goto yyreturn;
681
682   /*-----------------------------------.
683   | yyabortlab -- YYABORT comes here.  |
684   `-----------------------------------*/
685   yyabortlab:
686     yyresult = 1;
687     goto yyreturn;
688
689   /*----------------------------------------------.
690   | yyoverflowlab -- parser overflow comes here.  |
691   `----------------------------------------------*/
692   yyoverflowlab:
693     yyerror ("parser stack overflow");
694     yyresult = 2;
695     /* Fall through.  */
696
697   yyreturn:
698
699     LEAVE;                      /* force stack free before we return */
700
701     return yyresult;
702 }
703
704 /*
705  * Local variables:
706  * c-indentation-style: bsd
707  * c-basic-offset: 4
708  * indent-tabs-mode: t
709  * End:
710  *
711  * ex: set ts=8 sts=4 sw=4 noet:
712  */