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