perly.y

早期freebsd实现

/* $RCSfile: perly.y,v $$Revision: 4.0.1.6 $$Date: 1993/02/05 19:41:15 $
 *
 *    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.0.1.6  1993/02/05  19:41:15  lwall
 * patch36: delete with parens dumped core
 *
 * 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 "INTERN.h"
#include "perl.h"

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

STAB *scrstab;
ARG *arg4;	/* rarely used arguments to make_op() */
ARG *arg5;

%}

%start prog

%union {
    int	ival;
    char *cval;
    ARG *arg;
    CMD *cmdval;
    struct compcmd compval;
    STAB *stabval;
    FCMD *formval;
}

%token <ival> '{' ')'

%token <cval> WORD LABEL
%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT
%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 FILETEST LOCAL DELETE
%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER
%token <formval> FORMLIST
%token <stabval> REG ARYLEN ARY HSH STAR
%token <arg> SUBST PATTERN
%token <arg> RSTRING TRANS

%type <ival> prog decl format remember crp
%type <cmdval> block lineseq line loop cond sideff nexpr else
%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
%type <arg> texpr listop bareword
%type <cval> label
%type <compval> compblock

%nonassoc <ival> LISTOP
%left ','
%right '='
%right '?' ':'
%nonassoc DOTDOT
%left OROR
%left ANDAND
%left '|' '^'
%left '&'
%nonassoc EQOP
%nonassoc RELOP
%nonassoc <ival> UNIOP
%nonassoc FILETEST
%left LS RS
%left ADDOP
%left MULOP
%left MATCH NMATCH 
%right '!' '~' UMINUS
%right POW
%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 */
			{ $$ = Nullcmd; }
	|	ELSE block
			{ $$ = $2; }
	|	ELSIF '(' expr ')' compblock
			{ cmdline = $1;
			    $$ = make_ccmd(C_ELSIF,1,$3,$5); }
	;

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

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

lineseq	:	/* NULL */
			{ $$ = Nullcmd; }
	|	lineseq line
			{ $$ = append_line($1,$2); }
	;

line	:	decl
			{ $$ = Nullcmd; }
	|	label cond
			{ $$ = add_label($1,$2); }
	|	loop	/* loops add their own labels */
	|	label ';'
			{ if ($1 != Nullch) {
			      $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
				  Nullarg, Nullarg) );
			    }
			    else {
			      $$ = Nullcmd;
			      cmdline = NOLINE;
			    }
			    expectterm = 2; }
	|	label sideff ';'
			{ $$ = add_label($1,$2);
			  expectterm = 2; }
	;

sideff	:	error
			{ $$ = Nullcmd; }
	|	expr
			{ $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
	|	expr IF expr
			{ $$ = addcond(
			       make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
	|	expr UNLESS expr
			{ $$ = addcond(invert(
			       make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
	|	expr WHILE expr
			{ $$ = addloop(
			       make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
	|	expr UNTIL expr
			{ $$ = addloop(invert(
			       make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
	;

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

loop	:	label WHILE '(' texpr ')' compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    make_ccmd(C_WHILE,1,$4,$6) )); }
	|	label UNTIL '(' expr ')' compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    invert(make_ccmd(C_WHILE,1,$4,$6)) )); }
	|	label WHILE block compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); }
	|	label UNTIL block compblock
			{ cmdline = $2;
			    $$ = wopt(add_label($1,
			    invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); }
	|	label FOR REG '(' 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 genstab().
			     * (Note that @ary may become a local array if
			     * it is determined that it might be called
			     * recursively.  See cmd_tosave().)
			     */
			    if ($5->arg_type != O_ARRAY) {
				scrstab = aadd(genstab());
				$$ = append_line(
				    make_acmd(C_EXPR, Nullstab,
				      l(make_op(O_ASSIGN,2,
					listish(make_op(O_ARRAY, 1,
					  stab2arg(A_STAB,scrstab),
					  Nullarg,Nullarg )),
					listish(make_list($5)),
					Nullarg)),
				      Nullarg),
				    wopt(over($3,add_label($1,
				      make_ccmd(C_WHILE, 0,
					make_op(O_ARRAY, 1,
					  stab2arg(A_STAB,scrstab),
					  Nullarg,Nullarg ),
					$7)))));
				$$->c_line = $2;
				$$->c_head->c_line = $2;
			    }
			    else {
				$$ = wopt(over($3,add_label($1,
				make_ccmd(C_WHILE,1,$5,$7) )));
			    }
			}
	|	label FOR '(' expr crp compblock
			{ cmdline = $2;
			    if ($4->arg_type != O_ARRAY) {
				scrstab = aadd(genstab());
				$$ = append_line(
				    make_acmd(C_EXPR, Nullstab,
				      l(make_op(O_ASSIGN,2,
					listish(make_op(O_ARRAY, 1,
					  stab2arg(A_STAB,scrstab),
					  Nullarg,Nullarg )),
					listish(make_list($4)),
					Nullarg)),
				      Nullarg),
				    wopt(over(defstab,add_label($1,
				      make_ccmd(C_WHILE, 0,
					make_op(O_ARRAY, 1,
					  stab2arg(A_STAB,scrstab),
					  Nullarg,Nullarg ),
					$6)))));
				$$->c_line = $2;
				$$->c_head->c_line = $2;
			    }
			    else {	/* lisp, anyone? */
				$$ = wopt(over(defstab,add_label($1,
				make_ccmd(C_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_line($4,wopt(add_label($1,
				make_ccmd(C_WHILE,1,$6,yyval.compval) ))); }
	|	label compblock	/* a block is a loop that happens once */
			{ $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); }
	;

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

texpr	:	/* NULL means true */
			{ (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; }
	|	expr
	;

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

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

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

subrout	:	SUB WORD block
			{ make_sub($2,$3);
			  cmdline = NOLINE;
			  if (savestack->ary_fill > $1)
			    restorelist($1); }
	;

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

			  savehptr(&curstash);
			  saveitem(curstname);
			  str_set(curstname,$2);
			  sprintf(tmpbuf,"'_%s",$2);
			  tmpstab = stabent(tmpbuf,TRUE);
			  if (!stab_xhash(tmpstab))
			      stab_xhash(tmpstab) = hnew(0);
			  curstash = stab_xhash(tmpstab);
			  if (!curstash->tbl_name)
			      curstash->tbl_name = savestr($2);
			  curstash->tbl_coeffsize = 0;
			  Safefree($2); $2 = Nullch;
			  cmdline = NOLINE;
			  expectterm = 2;
			}
	;

cexpr	:	',' expr
			{ $$ = $2; }
	;

expr	:	expr ',' sexpr
			{ $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); }
	|	sexpr
	;

csexpr	:	',' sexpr
			{ $$ = $2; }
	;

sexpr	:	sexpr '=' sexpr
			{   $1 = listish($1);
			    if ($1->arg_type == O_ASSIGN && $1->arg_len == 1)
				$1->arg_type = O_ITEM;	/* a local() */
			    if ($1->arg_type == O_LIST)
				$3 = listish($3);
			    $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); }
	|	sexpr POW '=' sexpr
			{ $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); }
	|	sexpr MULOP '=' sexpr
			{ $$ = l(make_op($2, 2, $1, $4, Nullarg)); }
	|	sexpr ADDOP '=' sexpr
			{ $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));}
	|	sexpr LS '=' sexpr
			{ $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); }
	|	sexpr RS '=' sexpr
			{ $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); }
	|	sexpr '&' '=' sexpr
			{ $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); }
	|	sexpr '^' '=' sexpr
			{ $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); }
	|	sexpr '|' '=' sexpr
			{ $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); }


	|	sexpr POW sexpr
			{ $$ = make_op(O_POW, 2, $1, $3, Nullarg); }
	|	sexpr MULOP sexpr
			{ if ($2 == O_REPEAT)
			      $1 = listish($1);
			    $$ = make_op($2, 2, $1, $3, Nullarg);
			    if ($2 == O_REPEAT) {
				if ($$[1].arg_type != A_EXPR ||
				  $$[1].arg_ptr.arg_arg->arg_type != O_LIST)
				    $$[1].arg_flags &= ~AF_ARYOK;
			    } }
	|	sexpr ADDOP sexpr
			{ $$ = make_op($2, 2, $1, $3, Nullarg); }
	|	sexpr LS sexpr
			{ $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); }
	|	sexpr RS sexpr
			{ $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); }
	|	sexpr RELOP sexpr
			{ $$ = make_op($2, 2, $1, $3, Nullarg); }
	|	sexpr EQOP sexpr
			{ $$ = make_op($2, 2, $1, $3, Nullarg); }
	|	sexpr '&' sexpr
			{ $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); }
	|	sexpr '^' sexpr
			{ $$ = make_op(O_XOR, 2, $1, $3, Nullarg); }
	|	sexpr '|' sexpr
			{ $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); }
	|	sexpr DOTDOT sexpr
			{ arg4 = Nullarg;
			  $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg);
			  $$[0].arg_flags |= $2; }
	|	sexpr ANDAND sexpr
			{ $$ = make_op(O_AND, 2, $1, $3, Nullarg); }