perly.y.save

/* $RCSfile: perly.y,v $$Revision: 4.1 $$Date: 92/08/07 18:26:16 $
 *
 *    Copyright (c) 1991, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 * $Log:	perly.y,v $
 * Revision 4.1  92/08/07  18:26:16  lwall
 * 
 * Revision 4.0.1.5  92/06/11  21:12:50  lwall
 * patch34: expectterm incorrectly set to indicate start of program or block
 * 
 * Revision 4.0.1.4  92/06/08  17:33:25  lwall
 * patch20: one of the backdoors to expectterm was on the wrong reduction
 * 
 * Revision 4.0.1.3  92/06/08  15:18:16  lwall
 * patch20: an expression may now start with a bareword
 * patch20: relaxed requirement for semicolon at the end of a block
 * patch20: added ... as variant on ..
 * patch20: fixed double debug break in foreach with implicit array assignment
 * patch20: if {block} {block} didn't work any more
 * patch20: deleted some minor memory leaks
 * 
 * Revision 4.0.1.2  91/11/05  18:17:38  lwall
 * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
 * patch11: once-thru blocks didn't display right in the debugger
 * patch11: debugger got confused over nested subroutine definitions
 * 
 * Revision 4.0.1.1  91/06/07  11:42:34  lwall
 * patch4: new copyright notice
 * 
 * Revision 4.0  91/03/20  01:38:40  lwall
 * 4.0 baseline.
 * 
 */

%{
#include "EXTERN.h"
#include "perl.h"

/*SUPPRESS 530*/
/*SUPPRESS 593*/
/*SUPPRESS 595*/

%}

%start prog

%union {
    int	ival;
    char *cval;
    OP *opval;
    COP *copval;
    struct compcmd compval;
    GV *stabval;
    FF *formval;
}

%token <ival> '{' ')'

%token <opval> WORD
%token <cval> LABEL
%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT DOLSHARP
%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
%token <ival> FLIST2 SUB LOCAL DELETE FUNC
%token <ival> RELOP EQOP MULOP ADDOP PACKAGE
%token <formval> FORMLIST
%token <opval> THING STRING

%type <ival> prog decl format remember crp
%type <copval> block lineseq line loop cond sideff nexpr else
%type <opval> expr sexpr term scalar ary hsh arylen star amper
%type <opval> listexpr indirob
%type <opval> texpr listop
%type <cval> label
%type <compval> compblock

%nonassoc <ival> LSTOP
%left ','
%right '='
%right '?' ':'
%nonassoc DOTDOT
%left OROR
%left ANDAND
%left <ival> BITOROP
%left <ival> BITANDOP
%nonassoc EQOP
%nonassoc RELOP
%nonassoc <ival> UNIOP
%left <ival> SHIFTOP
%left ADDOP
%left MULOP
%left <ival> MATCHOP
%right '!' '~' UMINUS
%right <ival> POWOP
%nonassoc INC DEC
%left '('

%% /* RULES */

prog	:	/* NULL */
		{
#if defined(YYDEBUG) && defined(DEBUGGING)
		    yydebug = (debug & 1);
#endif
		    expectterm = 2;
		}
	/*CONTINUED*/	lineseq
			{ if (in_eval)
				eval_root = block_head($2);
			    else
				main_root = block_head($2); }
	;

compblock:	block CONTINUE block
			{ $$.comp_true = $1; $$.comp_alt = $3; }
	|	block else
			{ $$.comp_true = $1; $$.comp_alt = $2; }
	;

else	:	/* NULL */
			{ $$ = Nullcop; }
	|	ELSE block
			{ $$ = $2; }
	|	ELSIF '(' expr ')' compblock
			{ cmdline = $1;
			    $$ = newCCOP(OP_ELSIF,1,$3,$5); }
	;

block	:	'{' remember lineseq '}'
			{ $$ = block_head($3);
			  if (cmdline > (line_t)$1)
			      cmdline = $1;
			  if (savestack->av_fill > $2)
			    leave_scope($2);
			  expectterm = 2; }
	;

remember:	/* NULL */	/* in case they push a package name */
			{ $$ = savestack->av_fill; }
	;

lineseq	:	/* NULL */
			{ $$ = Nullcop; }
	|	lineseq line
			{ $$ = append_elem(OP_LINESEQ,$1,$2); }
	;

line	:	decl
			{ $$ = Nullcop; }
	|	label cond
			{ $$ = add_label($1,$2); }
	|	loop	/* loops add their own labels */
	|	label ';'
			{ if ($1 != Nullch) {
			      $$ = add_label($1, newACOP(Nullgv, Nullop) );
			    }
			    else {
			      $$ = Nullcop;
			      cmdline = NOLINE;
			    }
			    expectterm = 2; }
	|	label sideff ';'
			{ $$ = add_label($1,$2);
			  expectterm = 2; }
	;

sideff	:	error
			{ $$ = Nullcop; }
	|	expr
			{ $$ = newACOP(Nullgv, $1); }
	|	expr IF expr
			{ $$ = addcond(
			       newACOP(Nullgv, Nullop, $1), $3); }
	|	expr UNLESS expr
			{ $$ = addcond(invert(
			       newACOP(Nullgv, Nullop, $1)), $3); }
	|	expr WHILE expr
			{ $$ = addloop(
			       newACOP(Nullgv, Nullop, $1), $3); }
	|	expr UNTIL expr
			{ $$ = addloop(invert(
			       newACOP(Nullgv, Nullop, $1)), $3); }
	;

cond	:	IF '(' expr ')' compblock
			{ cmdline = $1;
			    $$ = newICOP(OP_IF,$3,$5); }
	|	UNLESS '(' expr ')' compblock
			{ cmdline = $1;
			    $$ = invert(newICOP(OP_IF,$3,$5)); }
	|	IF block compblock
			{ cmdline = $1;
			    $$ = newICOP(OP_IF,$2,$3); }
	|	UNLESS block compblock
			{ cmdline = $1;
			    $$ = invert(newICOP(OP_IF,$2,$3)); }
	;

loop	:	label WHILE '(' texpr ')' compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    newCCOP(OP_WHILE,1,$4,$6) )); }
	|	label UNTIL '(' expr ')' compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    invert(newCCOP(OP_WHILE,1,$4,$6)) )); }
	|	label WHILE block compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    newCCOP(OP_WHILE, 1, $3,$4) )); }
	|	label UNTIL block compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    invert(newCCOP(OP_WHILE,1,$3,$4)) )); }
	|	label FOR scalar '(' expr crp compblock
			{ cmdline = $2;
			    /*
			     * The following gobbledygook catches EXPRs that
			     * aren't explicit array refs and translates
			     *		foreach VAR (EXPR) {
			     * into
			     *		@ary = EXPR;
			     *		foreach VAR (@ary) {
			     * where @ary is a hidden array made by newGVgen().
			     * (Note that @ary may become a local array if
			     * it is determined that it might be called
			     * recursively.  See cmd_tosave().)
			     */
			    if ($5->op_type != OP_ARRAY) {
				scrstab = gv_AVadd(newGVgen());
				$$ = append_elem(OP_LINESEQ,
				    newACOP(Nullgv,
				      newBINOP(OP_ASSIGN,
					listref(newUNOP(OP_ARRAY,
					  gv_to_op(A_STAB,scrstab))),
					forcelist($5))),
				    wopt(over($3,add_label($1,
				      newCCOP(OP_WHILE, 0,
					newUNOP(OP_ARRAY,
					  gv_to_op(A_STAB,scrstab)),
					$7)))));
				$$->cop_line = $2;
				$$->cop_head->cop_line = $2;
			    }
			    else {
				$$ = wopt(over($3,add_label($1,
				newCCOP(OP_WHILE,1,$5,$7) )));
			    }
			}
	|	label FOR '(' expr crp compblock
			{ cmdline = $2;
			    if ($4->op_type != OP_ARRAY) {
				scrstab = gv_AVadd(newGVgen());
				$$ = append_elem(OP_LINESEQ,
				    newACOP(Nullgv,
				      newBINOP(OP_ASSIGN,
					listref(newUNOP(OP_ARRAY,
					  gv_to_op(A_STAB,scrstab))),
					forcelist($4))),
				    wopt(over(defstab,add_label($1,
				      newCCOP(OP_WHILE, 0,
					newUNOP(OP_ARRAY,
					  gv_to_op(A_STAB,scrstab)),
					$6)))));
				$$->cop_line = $2;
				$$->cop_head->cop_line = $2;
			    }
			    else {	/* lisp, anyone? */
				$$ = wopt(over(defstab,add_label($1,
				newCCOP(OP_WHILE,1,$4,$6) )));
			    }
			}
	|	label FOR '(' nexpr ';' texpr ';' nexpr ')' block
			/* basically fake up an initialize-while lineseq */
			{   yyval.compval.comp_true = $10;
			    yyval.compval.comp_alt = $8;
			    cmdline = $2;
			    $$ = append_elem(OP_LINESEQ,$4,wopt(add_label($1,
				newCCOP(OP_WHILE,1,$6,yyval.compval) ))); }
	|	label compblock	/* a block is a loop that happens once */
			{ $$ = add_label($1,newCCOP(OP_BLOCK,1,Nullop,$2)); }
	;

nexpr	:	/* NULL */
			{ $$ = Nullcop; }
	|	sideff
	;

texpr	:	/* NULL means true */
			{ (void)scan_num("1"); $$ = yylval.op; }
	|	expr
	;

label	:	/* empty */
			{ $$ = Nullch; }
	|	LABEL
	;

decl	:	format
			{ $$ = 0; }
	|	subrout
			{ $$ = 0; }
	|	package
			{ $$ = 0; }
	;

format	:	FORMAT WORD '=' FORMLIST
			{ if (strEQ($2,"stdout"))
			    newFORM(newGV("STDOUT",TRUE),$4);
			  else if (strEQ($2,"stderr"))
			    newFORM(newGV("STDERR",TRUE),$4);
			  else
			    newFORM(newGV($2,TRUE),$4);
			  Safefree($2); $2 = Nullch; }
	|	FORMAT '=' FORMLIST
			{ newFORM(newGV("STDOUT",TRUE),$3); }
	;

subrout	:	SUB WORD block
			{ newSUB($2,$3);
			  cmdline = NOLINE;
			  if (savestack->av_fill > $1)
			    leave_scope($1); }
	;

package :	PACKAGE WORD ';'
			{ char tmpbuf[256];
			  GV *tmpstab;

			  save_hptr(&curstash);
			  save_item(curstname);
			  sv_setpv(curstname,$2);
			  sprintf(tmpbuf,"'_%s",$2);
			  tmpstab = newGV(tmpbuf,TRUE);
			  if (!GvHV(tmpstab))
			      GvHV(tmpstab) = newHV(0);
			  curstash = GvHV(tmpstab);
			  if (!curstash->hv_name)
			      curstash->hv_name = savestr($2);
			  curstash->hv_coeffsize = 0;
			  Safefree($2); $2 = Nullch;
			  cmdline = NOLINE;
			  expectterm = 2;
			}
	;

expr	:	expr ',' sexpr
			{ $$ = append_elem(OP_LIST, $1, $3); }
	|	sexpr
	;

sexpr	:	sexpr '=' sexpr
			{ $$ = newBINOP(OP_ASSIGN, ref($1), $3); }
	|	sexpr POWOP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4); }
	|	sexpr MULOP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4); }
	|	sexpr ADDOP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4);}
	|	sexpr SHIFTOP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4); }
	|	sexpr BITANDOP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4); }
	|	sexpr BITOROP '=' sexpr
			{ $$ = newBINOP($2, ref($1), $4); }


	|	sexpr POWOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr MULOP sexpr
			{ if ($2 == OP_REPEAT)
			      $1 = forcelist($1);
			    $$ = newBINOP($2, $1, $3);
			    if ($2 == OP_REPEAT) {
				if ($$[1].op_type != A_EXPR ||
				  $$[1].op_ptr.op_op->op_type != OP_LIST)
				    $$[1].op_flags &= ~AF_ARYOK;
			    } }
	|	sexpr ADDOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr SHIFTOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr RELOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr EQOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr BITANDOP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr BITOROP sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr DOTDOT sexpr
			{ $$ = newBINOP($2, $1, $3); }
	|	sexpr ANDAND sexpr
			{ $$ = newBINOP(OP_AND, $1, $3); }
	|	sexpr OROR sexpr
			{ $$ = newBINOP(OP_OR, $1, $3); }
	|	sexpr '?' sexpr ':' sexpr
			{ $$ = newCONDOP(OP_COND_EXPR, $1, $3, $5); }
	|	sexpr MATCHOP sexpr
			{ $$ = bind_match($2, $1, $3); }
	|	term
			{ $$ = $1; }
	;

term	:	'-' term %prec UMINUS
			{ $$ = newUNOP(OP_NEGATE, $2); }
	|	'+' term %prec UMINUS
			{ $$ = $2; }
	|	'!' term
			{ $$ = newUNOP(OP_NOT, $2); }
	|	'~' term
			{ $$ = newUNOP(OP_COMPLEMENT, $2);}
	|	term INC
			{ $$ = newUNOP(OP_POSTINC,ref($1)); }
	|	term DEC
			{ $$ = newUNOP(OP_POSTDEC,ref($1)); }
	|	INC term
			{ $$ = newUNOP(OP_PREINC,ref($2)); }
	|	DEC term
			{ $$ = newUNOP(OP_PREDEC,ref($2)); }
	|	LOCAL '(' expr crp
			{ $$ = localize(forcelist($3)); }
	|	'(' expr crp
			{ $$ = $2; }
	|	'(' ')'
			{ $$ = Nullop; }	/* XXX may be insufficient */
	|	scalar	%prec '('
			{ $$ = gv_to_op(A_STAB,$1); }
	|	star	%prec '('
			{ $$ = gv_to_op(A_STAR,$1); }
	|	scalar '[' expr ']'	%prec '('
			{ $$ = newBINOP(OP_AELEM,
				gv_to_op(A_STAB,gv_AVadd($1)), $3); }
	|	hsh 	%prec '('
			{ $$ = newUNOP(OP_HASH, gv_to_op(A_STAB,$1)); }
	|	ary 	%prec '('
			{ $$ = newUNOP(OP_ARRAY, gv_to_op(A_STAB,$1)); }
	|	arylen 	%prec '('
			{ $$ = newUNOP(OP_ARYLEN, gv_to_op(A_STAB,$1)); }
	|	scalar '{' expr ';' '}'	%prec '('
			{ $$ = newBINOP(OP_HELEM,
				gv_to_op(A_STAB,gv_HVadd($1)),
				jmaybe($3));
			    expectterm = FALSE; }
	|	'(' expr crp '[' expr ']'	%prec '('
			{ $$ = newSLICEOP(OP_LSLICE, Nullop,
				forcelist($5),
				forcelist($2)); }
	|	'(' ')' '[' expr ']'	%prec '('
			{ $$ = newSLICEOP(OP_LSLICE, Nullop,
				forcelist($4), Nullop); }
	|	ary '[' expr ']'	%prec '('
			{ $$ = newBINOP(OP_ASLICE,
				gv_to_op(A_STAB,gv_AVadd($1)),
				forcelist($3)); }
	|	ary '{' expr ';' '}'	%prec '('
			{ $$ = newBINOP(OP_HSLICE,
				gv_to_op(A_STAB,gv_HVadd($1)),
				forcelist($3));
			    expectterm = FALSE; }
	|	DELETE scalar '{' expr ';' '}'	%prec '('
			{ $$ = newBINOP(OP_DELETE,
				gv_to_op(A_STAB,gv_HVadd($2)),
				jmaybe($4));
			    expectterm = FALSE; }
	|	DELETE '(' scalar '{' expr ';' '}' ')'	%prec '('
			{ $$ = newBINOP(OP_DELETE,
				gv_to_op(A_STAB,gv_HVadd($3)),
				jmaybe($5));
			    expectterm = FALSE; }
	|	THING	%prec '('
			{ $$ = $1; }

	|	amper
			{ $$ = newUNIOP(OP_SUBR,
				gv_to_op(A_STAB,$1)); }
	|	amper '(' ')'
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_STAB,$1),
				flatten(Nullop)); }
	|	amper '(' expr crp
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_STAB,$1),
				$3); }

	|	DO sexpr	%prec UNIOP
			{ $$ = newUNOP(OP_DOFILE,$2);
			  allgvs = TRUE;}
	|	DO block	%prec '('
			{ $$ = $2; }
	|	DO WORD '(' ')'
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_WORD,newGV($2,MULTI)),
				Nullop);
			    Safefree($2); $2 = Nullch;
			    $$->op_flags |= AF_DEPR; }
	|	DO WORD '(' expr crp
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_WORD,newGV($2,MULTI)),
				$4); Safefree($2); $2 = Nullch;
			    $$->op_flags |= AF_DEPR; }
	|	DO scalar '(' ')'
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_STAB,$2),
				flatten(Nullop));
			    $$->op_flags |= AF_DEPR; }
	|	DO scalar '(' expr crp
			{ $$ = newBINOP(OP_SUBR,
				gv_to_op(A_STAB,$2),
				$4);
			    $$->op_flags |= AF_DEPR; }
	|	LOOPEX
			{ $$ = newOP($1); }
	|	LOOPEX WORD
			{ $$ = newUNIOP($1,pv_to_op($2)); }
	|	UNIOP
			{ $$ = newOP($1); }
	|	UNIOP block
			{ $$ = newUNOP($1,$2); }
	|	UNIOP sexpr
			{ $$ = newUNOP($1,$2); }
	|	FUNC0
			{ $$ = newOP($1); }
	|	FUNC0 '(' ')'
			{ $$ = newOP($1); }
	|	FUNC1 '(' ')'
			{ $$ = newOP($1); }
	|	FUNC1 '(' expr ')'
			{ $$ = newUNIOP($1,$3); }
	|	WORD
	|	listop
	;

listop	:	LSTOP listexpr
			{ $$ = newUNOP($1, $2); }
	|	FUNC '(' listexpr ')'
			{ $$ = newUNOP($1, $3); }
	;

listexpr:	/* NULL */
			{ $$ = newNULLLIST(); }
	|	expr
			{ $$ = $1; }
	|	indirob expr
			{ $$ = prepend_elem(OP_LIST, $1, $2); }
	;

amper	:	'&' indirob
			{ $$ = $2; }
	;

scalar	:	'$' indirob
			{ $$ = $2; }
	;

ary	:	'@' indirob
			{ $$ = $2; }
	;

hsh	:	'%' indirob
			{ $$ = $2; }
	;

arylen	:	DOLSHARP indirob
			{ $$ = $2; }
	;

star	:	'*' indirob
			{ $$ = $2; }
	;

indirob	:	WORD
			{ $$ = newINDIROB($1); }
	|	scalar
			{ $$ = newINDIROB($1); }
	|	block
			{ $$ = newINDIROB($1); }
	;

crp	:	',' ')'
			{ $$ = 1; }
	|	')'
			{ $$ = 0; }
	;

%% /* PROGRAM */