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