[perl5.git] / cons.c

/* $Header: cons.c,v 3.0.1.10 91/01/11 17:33:33 lwall Locked $
 *
 *    Copyright (c) 1989, Larry Wall
 *
 *    You may distribute under the terms of the GNU General Public License
 *    as specified in the README file that comes with the perl 3.0 kit.
 *
 * $Log:	cons.c,v $
 * Revision 3.0.1.10  91/01/11  17:33:33  lwall
 * patch42: the perl debugger was dumping core frequently
 * patch42: the postincrement to preincrement optimizer was overzealous
 * patch42: foreach didn't localize its temp array properly
 * 
 * Revision 3.0.1.9  90/11/10  01:10:50  lwall
 * patch38: random cleanup
 * 
 * Revision 3.0.1.8  90/10/15  15:41:09  lwall
 * patch29: added caller
 * patch29: scripts now run at almost full speed under the debugger
 * patch29: the debugger now understands packages and evals
 * patch29: package behavior is now more consistent
 * 
 * Revision 3.0.1.7  90/08/09  02:35:52  lwall
 * patch19: did preliminary work toward debugging packages and evals
 * patch19: Added support for linked-in C subroutines
 * patch19: Numeric literals are now stored only in floating point
 * patch19: Added -c switch to do compilation only
 * 
 * Revision 3.0.1.6  90/03/27  15:35:21  lwall
 * patch16: formats didn't work inside eval
 * patch16: $foo++ now optimized to ++$foo where value not required
 * 
 * Revision 3.0.1.5  90/03/12  16:23:10  lwall
 * patch13: perl -d coredumped on scripts with subs that did explicit return
 * 
 * Revision 3.0.1.4  90/02/28  16:44:00  lwall
 * patch9: subs which return by both mechanisms can clobber local return data
 * patch9: changed internal SUB label to _SUB_
 * patch9: line numbers were bogus during certain portions of foreach evaluation
 * 
 * Revision 3.0.1.3  89/12/21  19:20:25  lwall
 * patch7: made nested or recursive foreach work right
 * 
 * Revision 3.0.1.2  89/11/17  15:08:53  lwall
 * patch5: nested foreach on same array didn't work
 * 
 * Revision 3.0.1.1  89/10/26  23:09:01  lwall
 * patch1: numeric switch optimization was broken
 * patch1: unless was broken when run under the debugger
 * 
 * Revision 3.0  89/10/18  15:10:23  lwall
 * 3.0 baseline
 * 
 */

#include "EXTERN.h"
#include "perl.h"
#include "perly.h"

extern char *tokename[];
extern int yychar;

static int cmd_tosave();
static int arg_tosave();
static int spat_tosave();

static bool saw_return;

SUBR *
make_sub(name,cmd)
char *name;
CMD *cmd;
{
    register SUBR *sub;
    STAB *stab = stabent(name,TRUE);

    Newz(101,sub,1,SUBR);
    if (stab_sub(stab)) {
	if (dowarn) {
	    CMD *oldcurcmd = curcmd;

	    if (cmd)
		curcmd = cmd;
	    warn("Subroutine %s redefined",name);
	    curcmd = oldcurcmd;
	}
	if (stab_sub(stab)->cmd) {
	    cmd_free(stab_sub(stab)->cmd);
	    afree(stab_sub(stab)->tosave);
	}
	Safefree(stab_sub(stab));
    }
    sub->filestab = curcmd->c_filestab;
    saw_return = FALSE;
    tosave = anew(Nullstab);
    tosave->ary_fill = 0;	/* make 1 based */
    (void)cmd_tosave(cmd,FALSE);	/* this builds the tosave array */
    sub->tosave = tosave;
    if (saw_return) {
	struct compcmd mycompblock;

	mycompblock.comp_true = cmd;
	mycompblock.comp_alt = Nullcmd;
	cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
	saw_return = FALSE;
	cmd->c_flags |= CF_TERM;
    }
    sub->cmd = cmd;
    stab_sub(stab) = sub;
    if (perldb) {
	STR *str;
	STR *tmpstr = str_static(&str_undef);

	sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr,
	  (long)subline);
	str = str_make(buf,0);
	str_cat(str,"-");
	sprintf(buf,"%ld",(long)curcmd->c_line);
	str_cat(str,buf);
	name = str_get(subname);
	stab_fullname(tmpstr,stab);
	hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0);
	str_set(subname,"main");
    }
    subline = 0;
    return sub;
}

SUBR *
make_usub(name, ix, subaddr, filename)
char *name;
int ix;
int (*subaddr)();
char *filename;
{
    register SUBR *sub;
    STAB *stab = stabent(name,allstabs);

    if (!stab)				/* unused function */
	return;
    Newz(101,sub,1,SUBR);
    if (stab_sub(stab)) {
	if (dowarn)
	    warn("Subroutine %s redefined",name);
	if (stab_sub(stab)->cmd) {
	    cmd_free(stab_sub(stab)->cmd);
	    afree(stab_sub(stab)->tosave);
	}
	Safefree(stab_sub(stab));
    }
    sub->filestab = fstab(filename);
    sub->usersub = subaddr;
    sub->userindex = ix;
    stab_sub(stab) = sub;
    return sub;
}

make_form(stab,fcmd)
STAB *stab;
FCMD *fcmd;
{
    if (stab_form(stab)) {
	FCMD *tmpfcmd;
	FCMD *nextfcmd;

	for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) {
	    nextfcmd = tmpfcmd->f_next;
	    if (tmpfcmd->f_expr)
		arg_free(tmpfcmd->f_expr);
	    if (tmpfcmd->f_unparsed)
		str_free(tmpfcmd->f_unparsed);
	    if (tmpfcmd->f_pre)
		Safefree(tmpfcmd->f_pre);
	    Safefree(tmpfcmd);
	}
    }
    stab_form(stab) = fcmd;
}

CMD *
block_head(tail)
register CMD *tail;
{
    CMD *head;
    register int opt;
    register int last_opt = 0;
    register STAB *last_stab = Nullstab;
    register int count = 0;
    register CMD *switchbeg = Nullcmd;

    if (tail == Nullcmd) {
	return tail;
    }
    head = tail->c_head;

    for (tail = head; tail; tail = tail->c_next) {

	/* save one measly dereference at runtime */
	if (tail->c_type == C_IF) {
	    if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next))
		tail->c_flags |= CF_TERM;
	}
	else if (tail->c_type == C_EXPR) {
	    ARG *arg;

	    if (tail->ucmd.acmd.ac_expr)
		arg = tail->ucmd.acmd.ac_expr;
	    else
		arg = tail->c_expr;
	    if (arg) {
		if (arg->arg_type == O_RETURN)
		    tail->c_flags |= CF_TERM;
		else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
		    tail->c_flags |= CF_TERM;
	    }
	}
	if (!tail->c_next)
	    tail->c_flags |= CF_TERM;

	if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE)
	    opt_arg(tail,1, tail->c_type == C_EXPR);

	/* now do a little optimization on case-ish structures */
	switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) {
	case CFT_ANCHOR:
	    if (stabent("*",FALSE)) {	/* bad assumption here!!! */
		opt = 0;
		break;
	    }
	    /* FALL THROUGH */
	case CFT_STROP:
	    opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0;
	    break;
	case CFT_CCLASS:
	    opt = CFT_STROP;
	    break;
	case CFT_NUMOP:
	    opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP);
	    if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE))
		opt = 0;
	    break;
	default:
	    opt = 0;
	}
	if (opt && opt == last_opt && tail->c_stab == last_stab)
	    count++;
	else {
	    if (count >= 3) {		/* is this the breakeven point? */
		if (last_opt == CFT_NUMOP)
		    make_nswitch(switchbeg,count);
		else
		    make_cswitch(switchbeg,count);
	    }
	    if (opt) {
		count = 1;
		switchbeg = tail;
	    }
	    else
		count = 0;
	}
	last_opt = opt;
	last_stab = tail->c_stab;
    }
    if (count >= 3) {		/* is this the breakeven point? */
	if (last_opt == CFT_NUMOP)
	    make_nswitch(switchbeg,count);
	else
	    make_cswitch(switchbeg,count);
    }
    return head;
}

/* We've spotted a sequence of CMDs that all test the value of the same
 * spat.  Thus we can insert a SWITCH in front and jump directly
 * to the correct one.
 */
make_cswitch(head,count)
register CMD *head;
int count;
{
    register CMD *cur;
    register CMD **loc;
    register int i;
    register int min = 255;
    register int max = 0;

    /* make a new head in the exact same spot */
    New(102,cur, 1, CMD);
#ifdef STRUCTCOPY
    *cur = *head;
#else
    Copy(head,cur,1,CMD);
#endif
    Zero(head,1,CMD);
    head->c_type = C_CSWITCH;
    head->c_next = cur;		/* insert new cmd at front of list */
    head->c_stab = cur->c_stab;

    Newz(103,loc,258,CMD*);
    loc++;				/* lie a little */
    while (count--) {
	if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) {
	    for (i = 0; i <= 255; i++) {
		if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) {
		    loc[i] = cur;
		    if (i < min)
			min = i;
		    if (i > max)
			max = i;
		}
	    }
	}
	else {
	    i = *cur->c_short->str_ptr & 255;
	    if (!loc[i]) {
		loc[i] = cur;
		if (i < min)
		    min = i;
		if (i > max)
		    max = i;
	    }
	}
	cur = cur->c_next;
    }
    max++;
    if (min > 0)
	Copy(&loc[min],&loc[0], max - min, CMD*);
    loc--;
    min--;
    max -= min;
    for (i = 0; i <= max; i++)
	if (!loc[i])
	    loc[i] = cur;
    Renew(loc,max+1,CMD*);	/* chop it down to size */
    head->ucmd.scmd.sc_offset = min;
    head->ucmd.scmd.sc_max = max;
    head->ucmd.scmd.sc_next = loc;
}

make_nswitch(head,count)
register CMD *head;
int count;
{
    register CMD *cur = head;
    register CMD **loc;
    register int i;
    register int min = 32767;
    register int max = -32768;
    int origcount = count;
    double value;		/* or your money back! */
    short changed;		/* so triple your money back! */

    while (count--) {
	i = (int)str_gnum(cur->c_short);
	value = (double)i;
	if (value != cur->c_short->str_u.str_nval)
	    return;		/* fractional values--just forget it */
	changed = i;
	if (changed != i)
	    return;		/* too big for a short */
	if (cur->c_slen == O_LE)
	    i++;
	else if (cur->c_slen == O_GE)	/* we only do < or > here */
	    i--;
	if (i < min)
	    min = i;
	if (i > max)
	    max = i;
	cur = cur->c_next;
    }
    count = origcount;
    if (max - min > count * 2 + 10)		/* too sparse? */
	return;

    /* now make a new head in the exact same spot */
    New(104,cur, 1, CMD);
#ifdef STRUCTCOPY
    *cur = *head;
#else
    Copy(head,cur,1,CMD);
#endif
    Zero(head,1,CMD);
    head->c_type = C_NSWITCH;
    head->c_next = cur;		/* insert new cmd at front of list */
    head->c_stab = cur->c_stab;

    Newz(105,loc, max - min + 3, CMD*);
    loc++;
    max -= min;
    max++;
    while (count--) {
	i = (int)str_gnum(cur->c_short);
	i -= min;
	switch(cur->c_slen) {
	case O_LE:
	    i++;
	case O_LT:
	    for (i--; i >= -1; i--)
		if (!loc[i])
		    loc[i] = cur;
	    break;
	case O_GE:
	    i--;
	case O_GT:
	    for (i++; i <= max; i++)
		if (!loc[i])
		    loc[i] = cur;
	    break;
	case O_EQ:
	    if (!loc[i])
		loc[i] = cur;
	    break;
	}
	cur = cur->c_next;
    }
    loc--;
    min--;
    max++;
    for (i = 0; i <= max; i++)
	if (!loc[i])
	    loc[i] = cur;
    head->ucmd.scmd.sc_offset = min;
    head->ucmd.scmd.sc_max = max;
    head->ucmd.scmd.sc_next = loc;
}

CMD *
append_line(head,tail)
register CMD *head;
register CMD *tail;
{
    if (tail == Nullcmd)
	return head;
    if (!tail->c_head)			/* make sure tail is well formed */
	tail->c_head = tail;
    if (head != Nullcmd) {
	tail = tail->c_head;		/* get to start of tail list */
	if (!head->c_head)
	    head->c_head = head;	/* start a new head list */
	while (head->c_next) {
	    head->c_next->c_head = head->c_head;
	    head = head->c_next;	/* get to end of head list */
	}
	head->c_next = tail;		/* link to end of old list */
	tail->c_head = head->c_head;	/* propagate head pointer */
    }
    while (tail->c_next) {
	tail->c_next->c_head = tail->c_head;
	tail = tail->c_next;
    }
    return tail;
}

CMD *
dodb(cur)
CMD *cur;
{
    register CMD *cmd;
    register CMD *head = cur->c_head;
    STR *str;

    if (!head)
	head = cur;
    if (!head->c_line)
	return cur;
    str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE);
    if (str == &str_undef || str->str_nok)
	return cur;
    str->str_u.str_nval = (double)head->c_line;
    str->str_nok = 1;
    Newz(106,cmd,1,CMD);
    str_magic(str, curcmd->c_filestab, 0, Nullch, 0);
    str->str_magic->str_u.str_cmd = cmd;
    cmd->c_type = C_EXPR;
    cmd->ucmd.acmd.ac_stab = Nullstab;
    cmd->ucmd.acmd.ac_expr = Nullarg;
    cmd->c_expr = make_op(O_SUBR, 2,
	stab2arg(A_WORD,DBstab),
	Nullarg,
	Nullarg);
    cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0;
    cmd->c_line = head->c_line;
    cmd->c_label = head->c_label;
    cmd->c_filestab = curcmd->c_filestab;
    cmd->c_stash = curstash;
    return append_line(cmd, cur);
}

CMD *
make_acmd(type,stab,cond,arg)
int type;
STAB *stab;
ARG *cond;
ARG *arg;
{
    register CMD *cmd;

    Newz(107,cmd,1,CMD);
    cmd->c_type = type;
    cmd->ucmd.acmd.ac_stab = stab;
    cmd->ucmd.acmd.ac_expr = arg;
    cmd->c_expr = cond;
    if (cond)
	cmd->c_flags |= CF_COND;
    if (cmdline == NOLINE)
	cmd->c_line = curcmd->c_line;
    else {
	cmd->c_line = cmdline;
	cmdline = NOLINE;
    }
    cmd->c_filestab = curcmd->c_filestab;
    cmd->c_stash = curstash;
    if (perldb)
	cmd = dodb(cmd);
    return cmd;
}

CMD *
make_ccmd(type,arg,cblock)
int type;
ARG *arg;
struct compcmd cblock;
{
    register CMD *cmd;

    Newz(108,cmd, 1, CMD);
    cmd->c_type = type;
    cmd->c_expr = arg;
    cmd->ucmd.ccmd.cc_true = cblock.comp_true;
    cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
    if (arg)
	cmd->c_flags |= CF_COND;
    if (cmdline == NOLINE)
	cmd->c_line = curcmd->c_line;
    else {
	cmd->c_line = cmdline;
	cmdline = NOLINE;
    }
    cmd->c_filestab = curcmd->c_filestab;
    cmd->c_stash = curstash;
    if (perldb)
	cmd = dodb(cmd);
    return cmd;
}

CMD *
make_icmd(type,arg,cblock)
int type;
ARG *arg;
struct compcmd cblock;
{
    register CMD *cmd;
    register CMD *alt;
    register CMD *cur;
    register CMD *head;
    struct compcmd ncblock;

    Newz(109,cmd, 1, CMD);
    head = cmd;
    cmd->c_type = type;
    cmd->c_expr = arg;
    cmd->ucmd.ccmd.cc_true = cblock.comp_true;
    cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
    if (arg)
	cmd->c_flags |= CF_COND;
    if (cmdline == NOLINE)
	cmd->c_line = curcmd->c_line;
    else {
	cmd->c_line = cmdline;
	cmdline = NOLINE;
    }
    cmd->c_filestab = curcmd->c_filestab;
    cmd->c_stash = curstash;
    cur = cmd;
    alt = cblock.comp_alt;
    while (alt && alt->c_type == C_ELSIF) {
	cur = alt;
	alt = alt->ucmd.ccmd.cc_alt;
    }
    if (alt) {			/* a real life ELSE at the end? */
	ncblock.comp_true = alt;
	ncblock.comp_alt = Nullcmd;
	alt = append_line(cur,make_ccmd(C_ELSE,Nullarg,ncblock));
	cur->ucmd.ccmd.cc_alt = alt;
    }
    else
	alt = cur;		/* no ELSE, so cur is proxy ELSE */

    cur = cmd;
    while (cmd) {		/* now point everyone at the ELSE */
	cur = cmd;
	cmd = cur->ucmd.ccmd.cc_alt;
	cur->c_head = head;
	if (cur->c_type == C_ELSIF)
	    cur->c_type = C_IF;
	if (cur->c_type == C_IF)
	    cur->ucmd.ccmd.cc_alt = alt;
	if (cur == alt)
	    break;
	cur->c_next = cmd;
    }
    if (perldb)
	cur = dodb(cur);
    return cur;
}

void
opt_arg(cmd,fliporflop,acmd)
register CMD *cmd;
int fliporflop;
int acmd;
{
    register ARG *arg;
    int opt = CFT_EVAL;
    int sure = 0;
    ARG *arg2;
    int context = 0;	/* 0 = normal, 1 = before &&, 2 = before || */
    int flp = fliporflop;

    if (!cmd)
	return;
    if (!(arg = cmd->c_expr)) {
	cmd->c_flags &= ~CF_COND;
	return;
    }

    /* Can we turn && and || into if and unless? */

    if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) &&
      (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
	dehoist(arg,1);
	arg[2].arg_type &= A_MASK;	/* don't suppress eval */
	dehoist(arg,2);
	cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg;
	cmd->c_expr = arg[1].arg_ptr.arg_arg;
	if (arg->arg_type == O_OR)
	    cmd->c_flags ^= CF_INVERT;		/* || is like unless */
	arg->arg_len = 0;
	free_arg(arg);
	arg = cmd->c_expr;
    }

    /* Turn "if (!expr)" into "unless (expr)" */

    if (!(cmd->c_flags & CF_TERM)) {		/* unless return value wanted */
	while (arg->arg_type == O_NOT) {
	    dehoist(arg,1);
	    cmd->c_flags ^= CF_INVERT;		/* flip sense of cmd */
	    cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */
	    free_arg(arg);
	    arg = cmd->c_expr;			/* here we go again */
	}
    }

    if (!arg->arg_len) {		/* sanity check */
	cmd->c_flags |= opt;
	return;
    }

    /* for "cond .. cond" we set up for the initial check */

    if (arg->arg_type == O_FLIP)
	context |= 4;

    /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */

  morecontext:
    if (arg->arg_type == O_AND)
	context |= 1;
    else if (arg->arg_type == O_OR)
	context |= 2;
    if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) {
	arg = arg[flp].arg_ptr.arg_arg;
	flp = 1;
	if (arg->arg_type == O_AND || arg->arg_type == O_OR)
	    goto morecontext;
    }
    if ((context & 3) == 3)
	return;

    if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
	cmd->c_flags |= opt;
	if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)
	  && cmd->c_expr->arg_type == O_ITEM) {
	    arg[flp].arg_flags &= ~AF_POST;	/* prefer ++$foo to $foo++ */
	    arg[flp].arg_flags |= AF_PRE;	/*  if value not wanted */
	}
	return;				/* side effect, can't optimize */
    }

    if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
      arg->arg_type == O_AND || arg->arg_type == O_OR) {
	if ((arg[flp].arg_type & A_MASK) == A_SINGLE) {
	    opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
	    cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str);
	    goto literal;
	}
	else if ((arg[flp].arg_type & A_MASK) == A_STAB ||
	  (arg[flp].arg_type & A_MASK) == A_LVAL) {
	    cmd->c_stab  = arg[flp].arg_ptr.arg_stab;
	    opt = CFT_REG;
	  literal:
	    if (!context) {	/* no && or ||? */
		free_arg(arg);
		cmd->c_expr = Nullarg;
	    }
	    if (!(context & 1))
		cmd->c_flags |= CF_EQSURE;
	    if (!(context & 2))
		cmd->c_flags |= CF_NESURE;
	}
    }
    else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
	     arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
	if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
		(arg[2].arg_type & A_MASK) == A_SPAT &&
		arg[2].arg_ptr.arg_spat->spat_short ) {
	    cmd->c_stab  = arg[1].arg_ptr.arg_stab;
	    cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short);
	    cmd->c_slen  = arg[2].arg_ptr.arg_spat->spat_slen;
	    if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL &&
		!(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) &&
		(arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
		sure |= CF_EQSURE;		/* (SUBST must be forced even */
						/* if we know it will work.) */
	    if (arg->arg_type != O_SUBST) {
		arg[2].arg_ptr.arg_spat->spat_short = Nullstr;
		arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */
	    }
	    sure |= CF_NESURE;		/* normally only sure if it fails */
	    if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST)
		cmd->c_flags |= CF_FIRSTNEG;
	    if (context & 1) {		/* only sure if thing is false */
		if (cmd->c_flags & CF_FIRSTNEG)
		    sure &= ~CF_NESURE;
		else
		    sure &= ~CF_EQSURE;
	    }
	    else if (context & 2) {	/* only sure if thing is true */
		if (cmd->c_flags & CF_FIRSTNEG)
		    sure &= ~CF_EQSURE;
		else
		    sure &= ~CF_NESURE;
	    }
	    if (sure & (CF_EQSURE|CF_NESURE)) {	/* if we know anything*/
		if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST)
		    opt = CFT_SCAN;
		else
		    opt = CFT_ANCHOR;
		if (sure == (CF_EQSURE|CF_NESURE)	/* really sure? */
		    && arg->arg_type == O_MATCH
		    && context & 4
		    && fliporflop == 1) {
		    spat_free(arg[2].arg_ptr.arg_spat);
		    arg[2].arg_ptr.arg_spat = Nullspat;	/* don't do twice */
		}
		cmd->c_flags |= sure;
	    }
	}
    }
    else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE ||
	     arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
	if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
	    if (arg[2].arg_type == A_SINGLE) {
		char *junk = str_get(arg[2].arg_ptr.arg_str);

		cmd->c_stab  = arg[1].arg_ptr.arg_stab;
		cmd->c_short = str_smake(arg[2].arg_ptr.arg_str);
		cmd->c_slen  = cmd->c_short->str_cur+1;
		switch (arg->arg_type) {
		case O_SLT: case O_SGT:
		    sure |= CF_EQSURE;
		    cmd->c_flags |= CF_FIRSTNEG;
		    break;
		case O_SNE:
		    cmd->c_flags |= CF_FIRSTNEG;
		    /* FALL THROUGH */
		case O_SEQ:
		    sure |= CF_NESURE|CF_EQSURE;
		    break;
		}
		if (context & 1) {	/* only sure if thing is false */
		    if (cmd->c_flags & CF_FIRSTNEG)
			sure &= ~CF_NESURE;
		    else
			sure &= ~CF_EQSURE;
		}
		else if (context & 2) { /* only sure if thing is true */
		    if (cmd->c_flags & CF_FIRSTNEG)
			sure &= ~CF_EQSURE;
		    else
			sure &= ~CF_NESURE;
		}
		if (sure & (CF_EQSURE|CF_NESURE)) {
		    opt = CFT_STROP;
		    cmd->c_flags |= sure;
		}
	    }
	}
    }
    else if (arg->arg_type == O_EQ || arg->arg_type == O_NE ||
	     arg->arg_type == O_LE || arg->arg_type == O_GE ||
	     arg->arg_type == O_LT || arg->arg_type == O_GT) {
	if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
	    if (arg[2].arg_type == A_SINGLE) {
		cmd->c_stab  = arg[1].arg_ptr.arg_stab;
		if (dowarn) {
		    STR *str = arg[2].arg_ptr.arg_str;

		    if ((!str->str_nok && !looks_like_number(str)))
			warn("Possible use of == on string value");
		}
		cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str));
		cmd->c_slen = arg->arg_type;
		sure |= CF_NESURE|CF_EQSURE;
		if (context & 1) {	/* only sure if thing is false */
		    sure &= ~CF_EQSURE;
		}
		else if (context & 2) { /* only sure if thing is true */
		    sure &= ~CF_NESURE;
		}
		if (sure & (CF_EQSURE|CF_NESURE)) {
		    opt = CFT_NUMOP;
		    cmd->c_flags |= sure;
		}
	    }
	}
    }
    else if (arg->arg_type == O_ASSIGN &&
	     (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
	     arg[1].arg_ptr.arg_stab == defstab &&
	     arg[2].arg_type == A_EXPR ) {
	arg2 = arg[2].arg_ptr.arg_arg;
	if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
	    opt = CFT_GETS;
	    cmd->c_stab = arg2[1].arg_ptr.arg_stab;
	    if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) {
		free_arg(arg2);
		free_arg(arg);
		cmd->c_expr = Nullarg;
	    }
	}
    }
    else if (arg->arg_type == O_CHOP &&
	     (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
	opt = CFT_CHOP;
	cmd->c_stab = arg[1].arg_ptr.arg_stab;
	free_arg(arg);
	cmd->c_expr = Nullarg;
    }
    if (context & 4)
	opt |= CF_FLIP;
    cmd->c_flags |= opt;

    if (cmd->c_flags & CF_FLIP) {
	if (fliporflop == 1) {
	    arg = cmd->c_expr;	/* get back to O_FLIP arg */
	    New(110,arg[3].arg_ptr.arg_cmd, 1, CMD);
	    Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD);
	    New(111,arg[4].arg_ptr.arg_cmd,1,CMD);
	    Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD);
	    opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
	    arg->arg_len = 2;		/* this is a lie */
	}
	else {
	    if ((opt & CF_OPTIMIZE) == CFT_EVAL)
		cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP;
	}
    }
}

CMD *
add_label(lbl,cmd)
char *lbl;
register CMD *cmd;
{
    if (cmd)
	cmd->c_label = lbl;
    return cmd;
}

CMD *
addcond(cmd, arg)
register CMD *cmd;
register ARG *arg;
{
    cmd->c_expr = arg;
    cmd->c_flags |= CF_COND;
    return cmd;
}

CMD *
addloop(cmd, arg)
register CMD *cmd;
register ARG *arg;
{
    void while_io();

    cmd->c_expr = arg;
    cmd->c_flags |= CF_COND|CF_LOOP;

    if (!(cmd->c_flags & CF_INVERT))
	while_io(cmd);		/* add $_ =, if necessary */

    if (cmd->c_type == C_BLOCK)
	cmd->c_flags &= ~CF_COND;
    else {
	arg = cmd->ucmd.acmd.ac_expr;
	if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
	    cmd->c_flags &= ~CF_COND;  /* "do {} while" happens at least once */
	if (arg && arg->arg_type == O_SUBR)
	    cmd->c_flags &= ~CF_COND;  /* likewise for "do subr() while" */
    }
    return cmd;
}

CMD *
invert(cmd)
CMD *cmd;
{
    register CMD *targ = cmd;
    if (targ->c_head)
	targ = targ->c_head;
    if (targ->c_flags & CF_DBSUB)
	targ = targ->c_next;
    targ->c_flags ^= CF_INVERT;
    return cmd;
}

yyerror(s)
char *s;
{
    char tmpbuf[258];
    char tmp2buf[258];
    char *tname = tmpbuf;

    if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
      oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
	while (isspace(*oldoldbufptr))
	    oldoldbufptr++;
	strncpy(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr);
	tmp2buf[bufptr - oldoldbufptr] = '\0';
	sprintf(tname,"next 2 tokens \"%s\"",tmp2buf);
    }
    else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
      oldbufptr != bufptr) {
	while (isspace(*oldbufptr))
	    oldbufptr++;
	strncpy(tmp2buf, oldbufptr, bufptr - oldbufptr);
	tmp2buf[bufptr - oldbufptr] = '\0';
	sprintf(tname,"next token \"%s\"",tmp2buf);
    }
    else if (yychar > 256)
	tname = "next token ???";
    else if (!yychar)
	(void)strcpy(tname,"at EOF");
    else if (yychar < 32)
	(void)sprintf(tname,"next char ^%c",yychar+64);
    else if (yychar == 127)
	(void)strcpy(tname,"at EOF");
    else
	(void)sprintf(tname,"next char %c",yychar);
    (void)sprintf(buf, "%s in file %s at line %d, %s\n",
      s,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname);
    if (curcmd->c_line == multi_end && multi_start < multi_end)
	sprintf(buf+strlen(buf),
	  "  (Might be a runaway multi-line %c%c string starting on line %d)\n",
	  multi_open,multi_close,multi_start);
    if (in_eval)
	str_cat(stab_val(stabent("@",TRUE)),buf);
    else
	fputs(buf,stderr);
    if (++error_count >= 10)
	fatal("%s has too many errors.\n",
	stab_val(curcmd->c_filestab)->str_ptr);
}

void
while_io(cmd)
register CMD *cmd;
{
    register ARG *arg = cmd->c_expr;
    STAB *asgnstab;

    /* hoist "while (<channel>)" up into command block */

    if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
	cmd->c_flags &= ~CF_OPTIMIZE;	/* clear optimization type */
	cmd->c_flags |= CFT_GETS;	/* and set it to do the input */
	cmd->c_stab = arg[1].arg_ptr.arg_stab;
	if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) {
	    cmd->c_expr = l(make_op(O_ASSIGN, 2,	/* fake up "$_ =" */
	       stab2arg(A_LVAL,defstab), arg, Nullarg));
	}
	else {
	    free_arg(arg);
	    cmd->c_expr = Nullarg;
	}
    }
    else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
	cmd->c_flags &= ~CF_OPTIMIZE;	/* clear optimization type */
	cmd->c_flags |= CFT_INDGETS;	/* and set it to do the input */
	cmd->c_stab = arg[1].arg_ptr.arg_stab;
	free_arg(arg);
	cmd->c_expr = Nullarg;
    }
    else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
	if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
	    asgnstab = cmd->c_stab;
	else
	    asgnstab = defstab;
	cmd->c_expr = l(make_op(O_ASSIGN, 2,	/* fake up "$foo =" */
	   stab2arg(A_LVAL,asgnstab), arg, Nullarg));
	cmd->c_flags &= ~CF_OPTIMIZE;	/* clear optimization type */
    }
}

CMD *
wopt(cmd)
register CMD *cmd;
{
    register CMD *tail;
    CMD *newtail;
    register int i;

    if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE)
	opt_arg(cmd,1, cmd->c_type == C_EXPR);

    while_io(cmd);		/* add $_ =, if necessary */

    /* First find the end of the true list */

    tail = cmd->ucmd.ccmd.cc_true;
    if (tail == Nullcmd)
	return cmd;
    New(112,newtail, 1, CMD);	/* guaranteed continue */
    for (;;) {
	/* optimize "next" to point directly to continue block */
	if (tail->c_type == C_EXPR &&
	    tail->ucmd.acmd.ac_expr &&
	    tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
	    (tail->ucmd.acmd.ac_expr->arg_len == 0 ||
	     (cmd->c_label &&
	      strEQ(cmd->c_label,
		    tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
	{
	    arg_free(tail->ucmd.acmd.ac_expr);
	    tail->c_type = C_NEXT;
	    if (cmd->ucmd.ccmd.cc_alt != Nullcmd)
		tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt;
	    else
		tail->ucmd.ccmd.cc_alt = newtail;
	    tail->ucmd.ccmd.cc_true = Nullcmd;
	}
	else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) {
	    if (cmd->ucmd.ccmd.cc_alt != Nullcmd)
		tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt;
	    else
		tail->ucmd.ccmd.cc_alt = newtail;
	}
	else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) {
	    if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
		for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
		    if (!tail->ucmd.scmd.sc_next[i])
			tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt;
	    }
	    else {
		for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
		    if (!tail->ucmd.scmd.sc_next[i])
			tail->ucmd.scmd.sc_next[i] = newtail;
	    }
	}

	if (!tail->c_next)
	    break;
	tail = tail->c_next;
    }

    /* if there's a continue block, link it to true block and find end */

    if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
	tail->c_next = cmd->ucmd.ccmd.cc_alt;
	tail = tail->c_next;
	for (;;) {
	    /* optimize "next" to point directly to continue block */
	    if (tail->c_type == C_EXPR &&
		tail->ucmd.acmd.ac_expr &&
		tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
		(tail->ucmd.acmd.ac_expr->arg_len == 0 ||
		 (cmd->c_label &&
		  strEQ(cmd->c_label,
			tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
	    {
		arg_free(tail->ucmd.acmd.ac_expr);
		tail->c_type = C_NEXT;
		tail->ucmd.ccmd.cc_alt = newtail;
		tail->ucmd.ccmd.cc_true = Nullcmd;
	    }
	    else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) {
		tail->ucmd.ccmd.cc_alt = newtail;
	    }
	    else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) {
		for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
		    if (!tail->ucmd.scmd.sc_next[i])
			tail->ucmd.scmd.sc_next[i] = newtail;
	    }

	    if (!tail->c_next)
		break;
	    tail = tail->c_next;
	}
	for ( ; tail->c_next; tail = tail->c_next) ;
    }

    /* Here's the real trick: link the end of the list back to the beginning,
     * inserting a "last" block to break out of the loop.  This saves one or
     * two procedure calls every time through the loop, because of how cmd_exec
     * does tail recursion.
     */

    tail->c_next = newtail;
    tail = newtail;
    if (!cmd->ucmd.ccmd.cc_alt)
	cmd->ucmd.ccmd.cc_alt = tail;	/* every loop has a continue now */

#ifndef lint
    (void)bcopy((char *)cmd, (char *)tail, sizeof(CMD));
#endif
    tail->c_type = C_EXPR;
    tail->c_flags ^= CF_INVERT;		/* turn into "last unless" */
    tail->c_next = tail->ucmd.ccmd.cc_true;	/* loop directly back to top */
    tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg);
    tail->ucmd.acmd.ac_stab = Nullstab;
    return cmd;
}

CMD *
over(eachstab,cmd)
STAB *eachstab;
register CMD *cmd;
{
    /* hoist "for $foo (@bar)" up into command block */

    cmd->c_flags &= ~CF_OPTIMIZE;	/* clear optimization type */
    cmd->c_flags |= CFT_ARRAY;		/* and set it to do the iteration */
    cmd->c_stab = eachstab;
    cmd->c_short = str_new(0);		/* just to save a field in struct cmd */
    cmd->c_short->str_u.str_useful = -1;

    return cmd;
}

cmd_free(cmd)
register CMD *cmd;
{
    register CMD *tofree;
    register CMD *head = cmd;

    while (cmd) {
	if (cmd->c_type != C_WHILE) {	/* WHILE block is duplicated */
	    if (cmd->c_label)
		Safefree(cmd->c_label);
	    if (cmd->c_short)
		str_free(cmd->c_short);
	    if (cmd->c_spat)
		spat_free(cmd->c_spat);
	    if (cmd->c_expr)
		arg_free(cmd->c_expr);
	}
	switch (cmd->c_type) {
	case C_WHILE:
	case C_BLOCK:
	case C_ELSE:
	case C_IF:
	    if (cmd->ucmd.ccmd.cc_true)
		cmd_free(cmd->ucmd.ccmd.cc_true);
	    break;
	case C_EXPR:
	    if (cmd->ucmd.acmd.ac_expr)
		arg_free(cmd->ucmd.acmd.ac_expr);
	    break;
	}
	tofree = cmd;
	cmd = cmd->c_next;
	if (tofree != head)		/* to get Saber to shut up */
	    Safefree(tofree);
	if (cmd && cmd == head)		/* reached end of while loop */
	    break;
    }
    Safefree(head);
}

arg_free(arg)
register ARG *arg;
{
    register int i;

    for (i = 1; i <= arg->arg_len; i++) {
	switch (arg[i].arg_type & A_MASK) {
	case A_NULL:
	    break;
	case A_LEXPR:
	    if (arg->arg_type == O_AASSIGN &&
	      arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) {
		char *name = 
		  stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab);

		if (strnEQ("_GEN_",name, 5))	/* array for foreach */
		    hdelete(defstash,name,strlen(name));
	    }
	    /* FALL THROUGH */
	case A_EXPR:
	    arg_free(arg[i].arg_ptr.arg_arg);
	    break;
	case A_CMD:
	    cmd_free(arg[i].arg_ptr.arg_cmd);
	    break;
	case A_WORD:
	case A_STAB:
	case A_LVAL:
	case A_READ:
	case A_GLOB:
	case A_ARYLEN:
	case A_LARYLEN:
	case A_ARYSTAB:
	case A_LARYSTAB:
	    break;
	case A_SINGLE:
	case A_DOUBLE:
	case A_BACKTICK:
	    str_free(arg[i].arg_ptr.arg_str);
	    break;
	case A_SPAT:
	    spat_free(arg[i].arg_ptr.arg_spat);
	    break;
	}
    }
    free_arg(arg);
}

spat_free(spat)
register SPAT *spat;
{
    register SPAT *sp;
    HENT *entry;

    if (spat->spat_runtime)
	arg_free(spat->spat_runtime);
    if (spat->spat_repl) {
	arg_free(spat->spat_repl);
    }
    if (spat->spat_short) {
	str_free(spat->spat_short);
    }
    if (spat->spat_regexp) {
	regfree(spat->spat_regexp);
    }

    /* now unlink from spat list */

    for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) {
	register HASH *stash;
	STAB *stab = (STAB*)entry->hent_val;

	if (!stab)
	    continue;
	stash = stab_hash(stab);
	if (!stash || stash->tbl_spatroot == Null(SPAT*))
	    continue;
	if (stash->tbl_spatroot == spat)
	    stash->tbl_spatroot = spat->spat_next;
	else {
	    for (sp = stash->tbl_spatroot;
	      sp && sp->spat_next != spat;
	      sp = sp->spat_next)
		;
	    if (sp)
		sp->spat_next = spat->spat_next;
	}
    }
    Safefree(spat);
}

/* Recursively descend a command sequence and push the address of any string
 * that needs saving on recursion onto the tosave array.
 */

static int
cmd_tosave(cmd,willsave)
register CMD *cmd;
int willsave;				/* willsave passes down the tree */
{
    register CMD *head = cmd;
    int shouldsave = FALSE;		/* shouldsave passes up the tree */
    int tmpsave;
    register CMD *lastcmd = Nullcmd;

    while (cmd) {
	if (cmd->c_spat)
	    shouldsave |= spat_tosave(cmd->c_spat);
	if (cmd->c_expr)
	    shouldsave |= arg_tosave(cmd->c_expr,willsave);
	switch (cmd->c_type) {
	case C_WHILE:
	    if (cmd->ucmd.ccmd.cc_true) {
		tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave);

		/* Here we check to see if the temporary array generated for
		 * a foreach needs to be localized because of recursion.
		 */
		if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) {
		    if (lastcmd &&
		      lastcmd->c_type == C_EXPR &&
		      lastcmd->c_expr) {
			ARG *arg = lastcmd->c_expr;

			if (arg->arg_type == O_ASSIGN &&
			    arg[1].arg_type == A_LEXPR &&
			    arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY &&
			    strnEQ("_GEN_",
			      stab_name(
				arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab),
			      5)) {	/* array generated for foreach */
			    (void)localize(arg);
			}
		    }

		    /* in any event, save the iterator */

		    (void)apush(tosave,cmd->c_short);
		}
		shouldsave |= tmpsave;
	    }
	    break;
	case C_BLOCK:
	case C_ELSE:
	case C_IF:
	    if (cmd->ucmd.ccmd.cc_true)
		shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave);
	    break;
	case C_EXPR:
	    if (cmd->ucmd.acmd.ac_expr)
		shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave);
	    break;
	}
	lastcmd = cmd;
	cmd = cmd->c_next;
	if (cmd && cmd == head)		/* reached end of while loop */
	    break;
    }
    return shouldsave;
}

static int
arg_tosave(arg,willsave)
register ARG *arg;
int willsave;
{
    register int i;
    int shouldsave = FALSE;

    for (i = arg->arg_len; i >= 1; i--) {
	switch (arg[i].arg_type & A_MASK) {
	case A_NULL:
	    break;
	case A_LEXPR:
	case A_EXPR:
	    shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave);
	    break;
	case A_CMD:
	    shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave);
	    break;
	case A_WORD:
	case A_STAB:
	case A_LVAL:
	case A_READ:
	case A_GLOB:
	case A_ARYLEN:
	case A_SINGLE:
	case A_DOUBLE:
	case A_BACKTICK:
	    break;
	case A_SPAT:
	    shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat);
	    break;
	}
    }
    switch (arg->arg_type) {
    case O_RETURN:
	saw_return = TRUE;
	break;
    case O_EVAL:
    case O_SUBR:
	shouldsave = TRUE;
	break;
    }
    if (willsave)
	(void)apush(tosave,arg->arg_ptr.arg_str);
    return shouldsave;
}

static int
spat_tosave(spat)
register SPAT *spat;
{
    int shouldsave = FALSE;

    if (spat->spat_runtime)
	shouldsave |= arg_tosave(spat->spat_runtime,FALSE);
    if (spat->spat_repl) {
	shouldsave |= arg_tosave(spat->spat_repl,FALSE);
    }

    return shouldsave;
}