Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site seismo.UUCP
Posting-Version: version B 2.10.2 9/3/84; site genrad.UUCP
Path: seismo!harvard!talcott!panda!genrad!sources-request
From: sources-request@genrad.UUCP
Newsgroups: mod.sources
Subject: A BASIC interpretor (Part 1 of 4)
Message-ID: <988@genrad.UUCP>
Date: 30 Jul 85 17:43:30 GMT
Sender: john@genrad.UUCP
Lines: 2636
Approved: john@genrad.UUCP

Mod.sources:  Volume 2, Issue 23
Submitted by: ukma!david (David Herron, NPR)


#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	newbs/act.c
#	newbs/action.c
#	newbs/action.c.new
#	newbs/bsint.c
#	newbs/errors.c
#	newbs/mkrbop.c
#	newbs/operat.c.new
# This archive created: Tue Jul 30 13:02:14 1985
export PATH; PATH=/bin:$PATH
if test ! -d 'newbs'
then
	echo shar: creating directory "'newbs'"
	mkdir 'newbs'
fi
echo shar: extracting "'newbs/act.c'" '(14296 characters)'
if test -f 'newbs/act.c'
then
	echo shar: will not over-write existing file "'newbs/act.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/act.c'
/* action.c -- "action" routines for interpretor.  These are the base-level
 *	routines, pointed to by the code-list.
 */

#include "bsdefs.h"

int status = 0;

/* M_COMPILE:
 *	x print x   --to--   x,_print,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	output: "string\n"
 */
_print(l,p)
int (*l[])(),p;
{
    union value s1;
    switch(status&XMODE) {
	case M_EXECUTE:
	    s1 = pop();
	    printf("%s",s1.sval);
	    if(s1.sval != 0) free(s1.sval);
	case M_FIXUP:
	case M_COMPILE: return(p);
	default:
	    STerror("print");
    }
}

/* M_COMPILE:
 *	x rlabel name goto x     --to--    x,rlabel,lval,_goto,0,x
 *	(the 0 is for the benefit of interp())
 * M_FIXUP: nothing.
 * any other mode:
 *	stack: lval,x    --to--    x
 *	other: Thisline = lval.lval.codelist;
 *	       Thisp = lval.lval.place;
 */
_goto(l,p) int (*l[])(),p;
{
    union value lval;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE: l[p] = 0;
#endif
	case M_FIXUP: return(++p);
	default:
	    lval = pop();
	    if(lval.lval.codelist == 0) ULerror(l,p);
	    Thisline = lval.lval.codelist;
	    Thisline--;
	    Thisp = lval.lval.place;
if(dbg) printf("_goto:EXEC:to:llent:%o:pl:%d:num:%u\n",lval.lval.codelist,
	lval.lval.place,lval.lval.codelist->num);
	    return(p);
    }
}

/* M_COMPILE:
 *	x dlabel name x    --to--    x,_dlabel,&vlist entry,x
 * M_FIXUP:
 *	Make vlist entry for "name" point to current place.
 */
_dlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;
    char *s;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    s=gtok();
	    vp=gvadr(s,T_LBL);
	    l[p++] = vp;
	    return(p);
#endif
	case M_FIXUP:
	    vp=l[p++];
	    vp->val.lval.codelist = (int **)gllentry(l);
	    vp->val.lval.place = p;
	    return(p);
	default: return(++p);
    }
}

/* M_COMPILE:
 *	x rlabel name x    --to--     x,rlabel,&vlist entry,x
 * any other mode:
 *	push(vp->val)    (i.e.  pointer to location of label)
 */
_rlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;
    char *s;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    s=gtok();
	    vp=gvadr(s,T_LBL);
	    l[p++] = vp;
	    return(p);
#endif
	case M_FIXUP: return(++p);
	default:
	    vp = l[p++];
if(dbg) printf("_rlabel:M_EXECUTE:name:%s:llent:%o:place:%d\n",vp->name,
	vp->val.lval.codelist,vp->val.lval.place);
	    push(vp->val);
	    return(p);
    }
}

/* M_COMPILE:
 *	x rlabel name goto x    --to--    x,_rlabel,lval,_gosub,0,x
 *
 * M_EXECUTE:
 *	stack: lval,x   --to--   x
 *	other: saves current place (on stack) and jumps to lval.
 */
_gosub(l,p) int(*l[])(),p;
{
    union value here,there;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	    return(p);
	case M_EXECUTE:
	    there = pop();
	    here.lval.codelist = gllentry(l);
	    here.lval.place = p+1;
if(dbg) printf("_gosub:EXEC:here.l:%o:here.pl:%d:there.l:%o:there.pl:%d\n",
	here.lval.codelist,here.lval.place,there.lval.codelist,there.lval.place);
	    push(here);
	    Thisline = there.lval.codelist;
	    Thisline--;
	    Thisp = there.lval.place;
	    return(p);
	default: STerror("gosub");
    }
}

_return(l,p) int(*l[])(),p;
{
    union value loc;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	    return(p);
	case M_EXECUTE:
	    loc = pop();
	    Thisp = loc.lval.place;
	    Thisline = loc.lval.codelist;
	    Thisline--;
	    return(p);
	default:
	    STerror("return");
    }
}

/* Routines control entering and leaving of loops.
 *
 *	enter -- makes a mark that we have entered a loop, and also records
 *		 branch points for "continue" and "leave".
 *	exitlp -- undoes the mark made by enter.
 *	contin -- branches to "continue" point.
 *	leave -- branches to "leave" point.
 *
 * The following stack structure is used to record these loop markers.
 */

struct loopstack {
	struct label contlb,leavlb;
};

struct loopstack lpstk[20];
int lpstkp = -1;	/* -1 when stack is empty.
			 * always points to CURRENT loop marker.
			 */

/* M_COMPILE:
 *	x rlabel contlb rlabel leavlb enter x
 *--to--
 *	x,_rlabel,contlb,_rlabel,_leavlb,_enter,x
 *
 * M_EXECUTE:
 *	loopstack: x    --to--   <contlb,leavlb>,x
 */
_enter(l,p) int (*l[])(),p;
{
    union value loc;

    if((status&XMODE) == M_EXECUTE) {
	lpstkp++;
	loc = pop();
if(dbg) printf("_enter:EXEC:lpsp:%d:leav.list:%o:leav.pl:%d",lpstkp,
	loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].leavlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].leavlb.place = loc.lval.place;
	loc = pop();
if(dbg) printf(":cont.list:%o:cont.pl:%d\n",loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].contlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].contlb.place = loc.lval.place;
    }
    return(p);
}

/* M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x    --to--   x
 *	other: ensures that lpstkp doesnt get less that -1;
 */
_exitlp(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_EXECUTE)
	if(lpstkp >= 0)
	    lpstkp--;
	else
	    lpstkp = -1;
if(dbg) printf("_exitlp:M_%d:lpstkp:%d\n",status,lpstkp);
    return(p);
}

/* M_COMPILE:
 *	x leave x   --to--   x,_leave,0,x
 *	(the 0 is for the benefit of interp())
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: branches to leavlb.  exitlp takes care of cleaning up stack.
 */
_leave(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    if(lpstkp == -1) /* not inside a loop, ergo cannot leave a loop */
		LVerror(l,p);
	    Thisline = lpstk[lpstkp].leavlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].leavlb.place;
	    return(p);
	default: STerror("leave");
    }
}

/* M_COMPILE:
 *	x contin x    --to--    x,_contin,0,x
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: jumps to contlb.
 */
_contin(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    if(lpstkp == -1) /* cannot continue a loop we're not in */
		CNerror(l,p);
	    Thisline = lpstk[lpstkp].contlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].contlb.place;
	    return(p);
	default: STerror("contin");
    }
}



/* M_COMPILE:
 *	x rlabel name if x    --to--   x,_rlabel,vp,if,0,x
 *	(the 0 is for the benefit for interp()).
 * M_EXECUTE:
 *	stack: loc,bool,x     --to--   x
 *	p: if bool, p=p else p=loc->place
 */
_if(l,p)
int (*l[])(),p;
{
    union value bv,lv;

    switch(status&XMODE) {
	case M_EXECUTE:
	    lv = pop();
	    bv = pop();
if(dbg) printf("_if:M_EXECUTE:lv.pl:%d:p:%d:bv.iv:%D\n",lv.lval.place,
	p,bv.ival);
	    if(bv.ival == (long)0) { /* jump to else part. */
		Thisline = lv.lval.codelist;
		Thisline--;
		Thisp = lv.lval.place;
	    }
	    else p++;	/* skip the 0 so we get to the then part */
	    return(p);
	case M_FIXUP:
	case M_COMPILE: l[p++] = 0; return(p);
	default: STerror("if");
    }
}

/* M_COMPILE:
 *	var name <from>expr <to>expr <step>expr <flag>con 0 dlabel FORx rlabel FORx+1 for
 *--to--
 *	_var,vp,<from>,<to>,<step>,<flag>,0,_dlabel,lblp,_rlabel,lblp2,_for
 *
 * M_EXECUTE:
 *	stack: xitpt,vizd,step,to,from,vp,x
 *	other: if exit conditions are correct, jump to exit point.
 *		vizd is used to hold the data type for vp.  Data types
 *		are always non-zero so the test for the first visit to
 *		the loop is to see if vizd is 0.
 */
_for(l,p) int(*l[])(),p;
{
    union value xitpt,vizd,from,to,step,place;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    xitpt = pop();	vizd = pop();
	    step = pop();	to = pop();
	    from = pop();
if(dbg) printf("_for:EXEC:xit.l:%o:xit.pl:%d:viz.iv:%D:step.iv:%D:to.iv:%D:from.iv:%D:",
	xitpt.lval.codelist,xitpt.lval.place,(long)vizd.ival,(long)step.ival,(long)to.ival,(long)from.ival);
	    if(vizd.ival == 0) { /* first visit to loop */
		place = pop();
if(dbg) printf("first time:var:%s:",place.vpval->name);
		vizd.ival = place.vpval->type_of_value&T_TMASK; /* != 0 */
		place.plval = getplace(place.vpval);
		*(place.plval) = from;	/* since first time, set starting val */
if(dbg) printf("var.pl:%o:var.val:%D:",place.plval,(long)place.plval->ival);
		if(vizd.ival==T_INT && step.ival==0)
			if(to.ival < from.ival)
				step.ival = -1;
			else
				step.ival = 1;
		else if(vizd.ival==T_DBL && step.rval==0)
			if(to.rval < from.rval)
				step.rval = -1;
			else
				step.rval = 1;
	    }
	    else place = pop();
if(dbg) printf("var.place:%o:",place.plval);

	    /* The stack frame is now correctly popped off.
	     * Next, we check if the loop is finished.
	     */

	    if(vizd.ival == T_INT)
		if(step.ival<0 && place.plval->ival<to.ival) goto loop_done;
		else if(step.ival>0 && place.plval->ival>to.ival) goto loop_done;
	    else /* vizd.ival == T_DBL */
		if(step.rval<0 && place.plval->rval<to.rval) goto loop_done;
		else if(step.rval>0 && place.plval->rval>to.rval) goto loop_done;

	    /* Loop is not done yet, push back stack frame. */

if(dbg) printf("loop not done, push everything back\n");
	    push(place);	push(from);	push(to);
	    push(step);		push(vizd);	push(xitpt);
	    return(p);

	/* Come here when the loop is finished. */
loop_done:
if(dbg) printf("loop done, jump to xitpt\n");
	    Thisline = xitpt.lval.codelist;
	    Thisline--;
	    Thisp = xitpt.lval.place;
	    return(p);
	default: STerror("for");
    }
}

/* M_COMPILE:
 *	var name next rlabel FORx go@ dlabel FORx+1
 *--to--
 *	_var,vp,_next,_rlabel,lblp,_go_at,dlabel,lblp2
 *
 * M_EXECUTE:
 *	stack: same as M_EXECUTE in _for.
 *	other: adds step to (control var)->val.
 */
_next(l,p) int(*l[])(),p;
{
    union value vp,xitpt,vizd,step,to,from,place;

    switch(status&XMODE) {
	case M_COMPILE:
	case M_FIXUP: return(p);
	case M_EXECUTE:
	    vp = pop();
if(dbg) printf("_next():EXEC:var:%s",vp.vpval->name);
	    vp.plval = getplace(vp.vpval);
if(dbg) printf(":vp.pl:%o:",vp.plval);
	    xitpt = pop();	vizd = pop();	step = pop();
	    to = pop();		from = pop();	place = pop();
if(dbg) printf("pl.pl:%o:from.iv:%D:to.iv:%D:step.iv:%D:viz.iv:%D:",
	place.plval,(long)from.ival,(long)to.ival,(long)step.ival,(long)vizd.ival);
if(dbg) printf("xit.list:%o:xit.pl:%d:xit.num:%u\n",xitpt.lval.codelist,
	xitpt.lval.place,xitpt.lval.codelist->num);
	    if(place.plval != vp.plval) FNerror(l,p);
	    if(vizd.ival == T_INT)
		place.plval->ival += step.ival;
	    else
		place.plval->rval += step.rval;
	    push(place);	push(from);	push(to);	
	    push(step);		push(vizd);	push(xitpt);
	    return(p);
	default: STerror("next");
    }
}

/* variables needed for M_READ. */

struct line *dlist[DLSIZ];
int dlp = 0;
int dlindx = 2;		/* skips <_data,0> */
int dtype;		/* type of last operation. */


/* M_COMPILE:
 *	x data x     --to--    x,_data,0,x     (0 is for interp())
 * M_FIXUP:
 *	allocates a spot in dlist, stores pointer to llist entry for
 *	this line at that spot.
 * M_EXECUTE:
 *	Returns, with p pointing at the zero, making interp() return.
 */
_data(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = 0;
	    return(p);
#endif
	case M_FIXUP:
	    dlist[dlp++] = gllentry(l);
	    p++;
	case M_EXECUTE: return(p);
	default:
	    STerror("data");
    }
}

/* M_COMPILE:  x dsep x   --to--   x,_dsep,0,x
 */
_dsep(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	case M_READ:
	case M_EXECUTE: return(p);
	default: STerror("dsep");
    }
}

/* routines for changing the interpretors state. */

struct statstk {	/* for saving old states */
	int stkp;
	int stat;
} sstk[30];
int sstktop = 0;

/* M_COMPILE:
 *	x pushstate <state> x    --to--    x,pushstate,<state>,x
 * M_FIXUP:
 *	skip <state>
 * any other state:
 *	save old state and stack pointer.
 *	set state to <state>.
 */
_pushstate(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = atoi(int_in());
	    return(p);
#endif
	case M_FIXUP: return(++p);
	default:
	    sstk[sstktop].stkp = stackp;
	    sstk[sstktop].stat = status;
	    sstktop++;
	    status = l[p++];
	    return(p);
    }
}
_popstate(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	default:
	    sstktop--;
	    stackp = sstk[sstktop].stkp;
	    status = sstk[sstktop].stat&XMODE;
	    return(p);
    }
}


/* stack maintanence routines.
 */


/* M_COMPILE:
 *	x spop x    --to--    x,_spop,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	other: frees storage used by string (if any).
 */
_spop(l,p) int(*l[])(),p;
{
    union value s;

    switch(status&XMODE) {
	case M_EXECUTE:
	    s=pop();
	    if(s.sval != 0) free(s.sval);
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	default:
	    STerror("spop");
    }
}

/* M_COMPILE:
 *	x pop x    --to--    x,_pop,x
 * M_EXECUTE:
 *	stack: int,x    --to--   x
 */
_pop(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_EXECUTE: pop(); return(p);
	default:
	    STerror("pop");
    }
}

_stop(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_EXECUTE: exit(1);
	default:
	    STerror("stop");
    }
}
_end(l,p) int (*l[])(),p; { return(_stop(l,p)); }


/* operator list for the intermediate language. */
struct wlnode wlist[] = {
	"itoa",_itoa,	"print",_print,	"goto",_goto,	"if",_if,  "rtoa",_rtoa,
	"itor",_itor,	"rtoi",_rtoi,	"gosub",_gosub,  "return",_return,
	"scon",_scon,	"icon",_icon,	"i+",_iadd,	"-",_isub,
	"rcon",_rcon,	"r+",_radd,	"r-",_rsub,
	"i*",_imult,	"i/",_idiv,	"i%",_imod,	",",_comma,
	"r*",_rmult,	"r/",_rdiv,	";",_scolon,
	"i==",_ieq,	"s==",_seq,	"r==",_req,
	"i<>",_ineq,	"r<>",_rneq,	"s<>",_sneq,
	"i<=",_ileq,	"s<=",_sleq,	"r<=",_rleq,
	"i<",_ilt,	"s<",_slt,	"r<",_rlt,
	"i>=",_igeq,	"s>=",_sgeq,	"r>=",_rgeq,
	"i>",_igt,	"s>",_sgt,	"r>",_rgt,
	"or",_or,	"and",_and,	"val",_val,	"not",_not,
	"pop",_pop,	"spop",_spop,
	"stop",_stop,	"end",_end,	"var",_var,	"store",_store,
	"for",_for,	"next",_next,
	"dlabel",_dlabel,	"rlabel",_rlabel,
	"contin",_contin,  "leave",_leave,  "enter",_enter,  "exitlp",_exitlp,
	"data",_data,	"dsep",_dsep,
	"pushstate",_pushstate,		"popstate",_popstate,
    0,0
};

SHAR_EOF
if test 14296 -ne "`wc -c < 'newbs/act.c'`"
then
	echo shar: error transmitting "'newbs/act.c'" '(should have been 14296 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/action.c'" '(12253 characters)'
if test -f 'newbs/action.c'
then
	echo shar: will not over-write existing file "'newbs/action.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/action.c'
/* action.c -- "action" routines for interpretor.  These are the base-level
 *	routines, pointed to by the code-list.
 */

#include "bsdefs.h"

int status = 0;

/* M_COMPILE:
 *	x print x   --to--   x,_print,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	output: "string\n"
 */
_print(l,p)
int (*l[])(),p;
{
    union value s1;
    if((status&XMODE) == M_EXECUTE) {
	    s1 = pop();
	    printf("%s",s1.sval);
	    if(s1.sval != 0) free(s1.sval);
    }
    return(p);
}

/* M_COMPILE:
 *	x rlabel name goto x     --to--    x,rlabel,lval,_goto,0,x
 *	(the 0 is for the benefit of interp())
 * M_FIXUP: nothing.
 * any other mode:
 *	stack: lval,x    --to--    x
 *	other: Thisline = lval.lval.codelist;
 *	       Thisp = lval.lval.place;
 */
_goto(l,p) int (*l[])(),p;
{
    union value lval;

    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    lval = pop();
	    if(lval.lval.codelist == 0) ULerror(l,p);
	    Thisline = lval.lval.codelist;
	    Thisline--;
	    Thisp = lval.lval.place;
if(dbg) printf("_goto:EXEC:to:llent:%o:pl:%d:num:%u\n",lval.lval.codelist,
	lval.lval.place,lval.lval.codelist->num);
	    return(p);
    }
    return(p);
}

/* M_COMPILE:
 *	x dlabel name x    --to--    x,_dlabel,&vlist entry,x
 * M_FIXUP:
 *	Make vlist entry for "name" point to current place.
 */
_dlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;

    if((status&XMODE) == M_FIXUP) {
	    vp=l[p++];
	    vp->val.lval.codelist = (int **)gllentry(l);
	    vp->val.lval.place = p;
	    return(p);
    }
    p++; return(p);	/* skip over the vp in any other mode */
}

/* M_COMPILE:
 *	x rlabel name x    --to--     x,rlabel,&vlist entry,x
 * any other mode:
 *	push(vp->val)    (i.e.  pointer to location of label)
 */
_rlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;

    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    vp = l[p++];
if(dbg) printf("_rlabel:M_EXECUTE:name:%s:llent:%o:place:%d\n",vp->name,
	vp->val.lval.codelist,vp->val.lval.place);
	    push(vp->val);
    }
	    return(p);
}

/* M_COMPILE:
 *	x rlabel name gosub x    --to--    x,_rlabel,lval,_gosub,0,x
 *
 * M_EXECUTE:
 *	stack: lval,x   --to--   x
 *	other: saves current place (on stack) and jumps to lval.
 */
_gosub(l,p) int(*l[])(),p;
{
    union value here,there;
    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    there = pop();
	    here.lval.codelist = gllentry(l);
	    here.lval.place = p+1;
if(dbg) printf("_gosub:EXEC:here.l:%o:here.pl:%d:there.l:%o:there.pl:%d\n",
	here.lval.codelist,here.lval.place,there.lval.codelist,there.lval.place);
	    push(here);
	    Thisline = there.lval.codelist;
	    Thisline--;
	    Thisp = there.lval.place;
    }
	    return(p);
}

_return(l,p) int(*l[])(),p;
{
    union value loc;
    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    loc = pop();
	    Thisp = loc.lval.place;
	    Thisline = loc.lval.codelist;
	    Thisline--;
    }
	    return(p);
}

/* Routines control entering and leaving of loops.
 *
 *	enter -- makes a mark that we have entered a loop, and also records
 *		 branch points for "continue" and "leave".
 *	exitlp -- undoes the mark made by enter.
 *	contin -- branches to "continue" point.
 *	leave -- branches to "leave" point.
 *
 * The following stack structure is used to record these loop markers.
 */

struct loopstack {
	struct label contlb,leavlb;
};

struct loopstack lpstk[20];
int lpstkp = -1;	/* -1 when stack is empty.
			 * always points to CURRENT loop marker.
			 */

/* M_COMPILE:
 *	x rlabel contlb rlabel leavlb enter x
 *--to--
 *	x,_rlabel,contlb,_rlabel,_leavlb,_enter,x
 *
 * M_EXECUTE:
 *	loopstack: x    --to--   <contlb,leavlb>,x
 */
_enter(l,p) int (*l[])(),p;
{
    union value loc;

    if((status&XMODE) == M_EXECUTE) {
	lpstkp++;
	loc = pop();
if(dbg) printf("_enter:EXEC:lpsp:%d:leav.list:%o:leav.pl:%d",lpstkp,
	loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].leavlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].leavlb.place = loc.lval.place;
	loc = pop();
if(dbg) printf(":cont.list:%o:cont.pl:%d\n",loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].contlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].contlb.place = loc.lval.place;
    }
    return(p);
}

/* M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x    --to--   x
 *	other: ensures that lpstkp doesnt get less that -1;
 */
_exitlp(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_EXECUTE)
	if(lpstkp >= 0)
	    lpstkp--;
	else
	    lpstkp = -1;
if(dbg) printf("_exitlp:M_%d:lpstkp:%d\n",status,lpstkp);
    return(p);
}

/* M_COMPILE:
 *	x leave x   --to--   x,_leave,0,x
 *	(the 0 is for the benefit of interp())
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: branches to leavlb.  exitlp takes care of cleaning up stack.
 */
_leave(l,p) int(*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    if(lpstkp == -1) /* not inside a loop, ergo cannot leave a loop */
		LVerror(l,p);
	    Thisline = lpstk[lpstkp].leavlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].leavlb.place;
    }
	    return(p);
}

/* M_COMPILE:
 *	x contin x    --to--    x,_contin,0,x
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: jumps to contlb.
 */
_contin(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    if(lpstkp == -1) /* cannot continue a loop we're not in */
		CNerror(l,p);
	    Thisline = lpstk[lpstkp].contlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].contlb.place;
    }
	    return(p);
}



/* M_COMPILE:
 *	x rlabel name if x    --to--   x,_rlabel,vp,if,0,x
 *	(the 0 is for the benefit for interp()).
 * M_EXECUTE:
 *	stack: loc,bool,x     --to--   x
 *	p: if bool, p=p else p=loc->place
 */
_if(l,p)
int (*l[])(),p;
{
    union value bv,lv;

    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    lv = pop();
	    bv = pop();
if(dbg) printf("_if:M_EXECUTE:lv.pl:%d:p:%d:bv.iv:%D\n",lv.lval.place,
	p,bv.ival);
	    if(bv.ival == (long)0) { /* jump to else part. */
		Thisline = lv.lval.codelist;
		Thisline--;
		Thisp = lv.lval.place;
	    }
	    else p++;	/* skip the 0 so we get to the then part */
    }
	    return(p);
}

/* M_COMPILE:
 *	var name <from>expr <to>expr <step>expr <flag>con 0 dlabel FORx rlabel FORx+1 for
 *--to--
 *	_var,vp,<from>,<to>,<step>,<flag>,0,_dlabel,lblp,_rlabel,lblp2,_for
 *
 * M_EXECUTE:
 *	stack: xitpt,vizd,step,to,from,vp,x
 *	other: if exit conditions are correct, jump to exit point.
 *		vizd is used to hold the data type for vp.  Data types
 *		are always non-zero so the test for the first visit to
 *		the loop is to see if vizd is 0.
 */
_for(l,p) int(*l[])(),p;
{
    union value xitpt,vizd,from,to,step,place;

    if((status&XMODE) == M_FIXUP) return(++p);
    if((status&XMODE) == M_EXECUTE) {
	    xitpt = pop();	vizd = pop();
	    step = pop();	to = pop();
	    from = pop();
if(dbg) printf("_for:EXEC:xit.l:%o:xit.pl:%d:viz.iv:%D:step.iv:%D:to.iv:%D:from.iv:%D:",
	xitpt.lval.codelist,xitpt.lval.place,(long)vizd.ival,(long)step.ival,(long)to.ival,(long)from.ival);
	    if(vizd.ival == 0) { /* first visit to loop */
		place = pop();
if(dbg) printf("first time:var:%s:",place.vpval->name);
		vizd.ival = place.vpval->type_of_value&T_TMASK; /* != 0 */
		place.plval = getplace(place.vpval);
		*(place.plval) = from;	/* since first time, set starting val */
		if(vizd.ival == T_INT) { /* if it is an INT, convert to/from/step to INT also */
			to.ival = (long)to.rval;
			from.ival = (long)from.rval;
			step.ival = (long)step.rval;
		}
if(dbg) printf("var.pl:%o:var.val:%D:",place.plval,(long)place.plval->ival);
		if(vizd.ival==T_INT && step.ival==0)
			if(to.ival < from.ival)
				step.ival = -1;
			else
				step.ival = 1;
		else if(vizd.ival==T_DBL && step.rval==0)
			if(to.rval < from.rval)
				step.rval = -1;
			else
				step.rval = 1;
	    }
	    else place = pop();
if(dbg) printf("var.place:%o:",place.plval);

	    /* The stack frame is now correctly popped off.
	     * Next, we check if the loop is finished.
	     */

	    if(vizd.ival == T_INT)
		if(step.ival<0 && place.plval->ival<to.ival) goto loop_done;
		else if(step.ival>0 && place.plval->ival>to.ival) goto loop_done;
	    else /* vizd.ival == T_DBL */
		if(step.rval<0 && place.plval->rval<to.rval) goto loop_done;
		else if(step.rval>0 && place.plval->rval>to.rval) goto loop_done;

	    /* Loop is not done yet, push back stack frame. */

if(dbg) printf("loop not done, push everything back\n");
	    push(place);	push(from);	push(to);
	    push(step);		push(vizd);	push(xitpt);
	    return(++p);	/* skip over the 0 */

	/* Come here when the loop is finished. */
loop_done:
if(dbg) printf("loop done, jump to xitpt\n");
	    Thisline = xitpt.lval.codelist;
	    Thisline--;
	    Thisp = xitpt.lval.place;
	    return(p);	/* hit the 0 */
    }
return(p);
}

/* M_COMPILE:
 *	var name next rlabel FORx goto dlabel FORx+1
 *--to--
 *	_var,vp,_next,_rlabel,lblp,_goto,dlabel,lblp2
 *
 * M_EXECUTE:
 *	stack: same as M_EXECUTE in _for.
 *	other: adds step to (control var)->val.
 */
_next(l,p) int(*l[])(),p;
{
    union value vp,xitpt,vizd,step,to,from,place;

    if((status&XMODE) == M_EXECUTE) {
	    vp = pop();
if(dbg) printf("_next():EXEC:var:%s",vp.vpval->name);
	    vp.plval = getplace(vp.vpval);
if(dbg) printf(":vp.pl:%o:",vp.plval);
	    xitpt = pop();	vizd = pop();	step = pop();
	    to = pop();		from = pop();	place = pop();
if(dbg) printf("pl.pl:%o:from.iv:%D:to.iv:%D:step.iv:%D:viz.iv:%D:",
	place.plval,(long)from.ival,(long)to.ival,(long)step.ival,(long)vizd.ival);
if(dbg) printf("xit.list:%o:xit.pl:%d:xit.num:%u\n",xitpt.lval.codelist,
	xitpt.lval.place,xitpt.lval.codelist->num);
	    if(place.plval != vp.plval) FNerror(l,p);
	    if(vizd.ival == T_INT)
		place.plval->ival += step.ival;
	    else
		place.plval->rval += step.rval;
	    push(place);	push(from);	push(to);	
	    push(step);		push(vizd);	push(xitpt);
	    return(p);
    }
return(p);
}

/* variables needed for M_READ. */

struct line *dlist[DLSIZ];
int dlp = 0;
int dlindx = 2;		/* skips <_data,0> */
int dtype;		/* type of last operation. */


/* M_COMPILE:
 *	x data x     --to--    x,_data,0,x     (0 is for interp())
 * M_FIXUP:
 *	allocates a spot in dlist, stores pointer to llist entry for
 *	this line at that spot.
 * M_EXECUTE:
 *	Returns, with p pointing at the zero, making interp() return.
 */
_data(l,p) int(*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) {
	    dlist[dlp++] = gllentry(l);
	    p++;
    }
    return(p);
}

/* M_COMPILE:  x dsep x   --to--   x,_dsep,0,x
 */
_dsep(l,p) int(*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) ++p;
    return(p);
}

/* routines for changing the interpretors state. */

struct statstk {	/* for saving old states */
	int stkp;
	int stat;
} sstk[30];
int sstktop = 0;

/* M_COMPILE:
 *	x pushstate <state> x    --to--    x,pushstate,<state>,x
 * M_FIXUP:
 *	skip <state>
 * any other state:
 *	save old state and stack pointer.
 *	set state to <state>.
 */
_pushstate(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) return(++p);
	    sstk[sstktop].stkp = stackp;
	    sstk[sstktop].stat = status;
	    sstktop++;
	    status = l[p++];
	    return(p);
}
_popstate(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_FIXUP) return(p); /* want to stay in this mode */
	    sstktop--;
	    stackp = sstk[sstktop].stkp;
	    status = sstk[sstktop].stat&XMODE;
	    return(p);
}


/* stack maintanence routines.
 */


/* M_COMPILE:
 *	x spop x    --to--    x,_spop,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	other: frees storage used by string (if any).
 */
_spop(l,p) int(*l[])(),p;
{
    union value s;

    if((status&XMODE) == M_EXECUTE) {
	    s=pop();
	    if(s.sval != 0) free(s.sval);
    }
    return(p);
}

/* M_COMPILE:
 *	x pop x    --to--    x,_pop,x
 * M_EXECUTE:
 *	stack: int,x    --to--   x
 */
_pop(l,p) int(*l[])(),p;
{
    if((status&XMODE) == M_EXECUTE) pop();
    return(p);
}

_stop(l,p) int(*l[])(),p;
{
    if((status&XMODE) == M_EXECUTE) exit(1);
    return(p);
}
_end(l,p) int (*l[])(),p; { return(_stop(l,p)); }


SHAR_EOF
if test 12253 -ne "`wc -c < 'newbs/action.c'`"
then
	echo shar: error transmitting "'newbs/action.c'" '(should have been 12253 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/action.c.new'" '(14386 characters)'
if test -f 'newbs/action.c.new'
then
	echo shar: will not over-write existing file "'newbs/action.c.new'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/action.c.new'
/* action.c -- "action" routines for interpretor.  These are the base-level
 *	routines, pointed to by the code-list.
 */

#include "bsdefs.h"

int status = 0;

/* M_COMPILE:
 *	x print x   --to--   x,_print,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	output: "string\n"
 */
_print(l,p)
int (*l[])(),p;
{
    union value s1;
    switch(status&XMODE) {
	case M_EXECUTE:
	    s1 = pop();
	    printf("%s",s1.sval);
	    if(s1.sval != 0) free(s1.sval);
	case M_FIXUP:
	case M_COMPILE: return(p);
	default:
	    STerror("print");
    }
}

/* M_COMPILE:
 *	x rlabel name goto x     --to--    x,rlabel,lval,_goto,0,x
 *	(the 0 is for the benefit of interp())
 * M_FIXUP: nothing.
 * any other mode:
 *	stack: lval,x    --to--    x
 *	other: Thisline = lval.lval.codelist;
 *	       Thisp = lval.lval.place;
 */
_goto(l,p) int (*l[])(),p;
{
    union value lval;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE: l[p] = 0;
#endif
	case M_FIXUP: return(++p);
	default:
	    lval = pop();
	    if(lval.lval.codelist == 0) ULerror(l,p);
	    Thisline = lval.lval.codelist;
	    Thisline--;
	    Thisp = lval.lval.place;
if(dbg) printf("_goto:EXEC:to:llent:%o:pl:%d:num:%u\n",lval.lval.codelist,
	lval.lval.place,lval.lval.codelist->num);
	    return(p);
    }
}

/* M_COMPILE:
 *	x dlabel name x    --to--    x,_dlabel,&vlist entry,x
 * M_FIXUP:
 *	Make vlist entry for "name" point to current place.
 */
_dlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;
    char *s;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    s=gtok();
	    vp=gvadr(s,T_LBL);
	    l[p++] = vp;
	    return(p);
#endif
	case M_FIXUP:
	    vp=l[p++];
	    vp->val.lval.codelist = (int **)gllentry(l);
	    vp->val.lval.place = p;
	    return(p);
	default: return(++p);
    }
}

/* M_COMPILE:
 *	x rlabel name x    --to--     x,rlabel,&vlist entry,x
 * any other mode:
 *	push(vp->val)    (i.e.  pointer to location of label)
 */
_rlabel(l,p) int (*l[])(),p;
{
    struct dictnode *vp;
    char *s;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    s=gtok();
	    vp=gvadr(s,T_LBL);
	    l[p++] = vp;
	    return(p);
#endif
	case M_FIXUP: return(++p);
	default:
	    vp = l[p++];
if(dbg) printf("_rlabel:M_EXECUTE:name:%s:llent:%o:place:%d\n",vp->name,
	vp->val.lval.codelist,vp->val.lval.place);
	    push(vp->val);
	    return(p);
    }
}

/* M_COMPILE:
 *	x rlabel name goto x    --to--    x,_rlabel,lval,_gosub,0,x
 *
 * M_EXECUTE:
 *	stack: lval,x   --to--   x
 *	other: saves current place (on stack) and jumps to lval.
 */
_gosub(l,p) int(*l[])(),p;
{
    union value here,there;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	    return(p);
	case M_EXECUTE:
	    there = pop();
	    here.lval.codelist = gllentry(l);
	    here.lval.place = p+1;
if(dbg) printf("_gosub:EXEC:here.l:%o:here.pl:%d:there.l:%o:there.pl:%d\n",
      here.lval.codelist,here.lval.place,there.lval.codelist,there.lval.place);
	    push(here);
	    Thisline = there.lval.codelist;
	    Thisline--;
	    Thisp = there.lval.place;
	    return(p);
	default: STerror("gosub");
    }
}

_return(l,p) int(*l[])(),p;
{
    union value loc;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	    return(p);
	case M_EXECUTE:
	    loc = pop();
	    Thisp = loc.lval.place;
	    Thisline = loc.lval.codelist;
	    Thisline--;
	    return(p);
	default:
	    STerror("return");
    }
}

/* Routines control entering and leaving of loops.
 *
 *	enter -- makes a mark that we have entered a loop, and also records
 *		 branch points for "continue" and "leave".
 *	exitlp -- undoes the mark made by enter.
 *	contin -- branches to "continue" point.
 *	leave -- branches to "leave" point.
 *
 * The following stack structure is used to record these loop markers.
 */

struct loopstack {
	struct label contlb,leavlb;
};

struct loopstack lpstk[20];
int lpstkp = -1;	/* -1 when stack is empty.
			 * always points to CURRENT loop marker.
			 */

/* M_COMPILE:
 *	x rlabel contlb rlabel leavlb enter x
 *--to--
 *	x,_rlabel,contlb,_rlabel,_leavlb,_enter,x
 *
 * M_EXECUTE:
 *	loopstack: x    --to--   <contlb,leavlb>,x
 */
_enter(l,p) int (*l[])(),p;
{
    union value loc;

    if((status&XMODE) == M_EXECUTE) {
	lpstkp++;
	loc = pop();
if(dbg) printf("_enter:EXEC:lpsp:%d:leav.list:%o:leav.pl:%d",lpstkp,
	loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].leavlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].leavlb.place = loc.lval.place;
	loc = pop();
if(dbg) printf(":cont.list:%o:cont.pl:%d\n",loc.lval.codelist,loc.lval.place);
	lpstk[lpstkp].contlb.codelist = loc.lval.codelist;
	lpstk[lpstkp].contlb.place = loc.lval.place;
    }
    return(p);
}

/* M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x    --to--   x
 *	other: ensures that lpstkp doesnt get less that -1;
 */
_exitlp(l,p) int (*l[])(),p;
{
    if((status&XMODE) == M_EXECUTE)
	if(lpstkp >= 0)
	    lpstkp--;
	else
	    lpstkp = -1;
if(dbg) printf("_exitlp:M_%d:lpstkp:%d\n",status,lpstkp);
    return(p);
}

/* M_COMPILE:
 *	x leave x   --to--   x,_leave,0,x
 *	(the 0 is for the benefit of interp())
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: branches to leavlb.  exitlp takes care of cleaning up stack.
 */
_leave(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    if(lpstkp == -1) /* not inside a loop, ergo cannot leave a loop */
		LVerror(l,p);
	    Thisline = lpstk[lpstkp].leavlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].leavlb.place;
	    return(p);
	default: STerror("leave");
    }
}

/* M_COMPILE:
 *	x contin x    --to--    x,_contin,0,x
 *
 * M_EXECUTE:
 *	loopstack: <contlb,leavlb>,x   --to--   <contlb,leavlb>,x
 *	other: jumps to contlb.
 */
_contin(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    if(lpstkp == -1) /* cannot continue a loop we're not in */
		CNerror(l,p);
	    Thisline = lpstk[lpstkp].contlb.codelist;
	    Thisline--;
	    Thisp = lpstk[lpstkp].contlb.place;
	    return(p);
	default: STerror("contin");
    }
}



/* M_COMPILE:
 *	x rlabel name if x    --to--   x,_rlabel,vp,if,0,x
 *	(the 0 is for the benefit for interp()).
 * M_EXECUTE:
 *	stack: loc,bool,x     --to--   x
 *	p: if bool, p=p else p=loc->place
 */
_if(l,p)
int (*l[])(),p;
{
    union value bv,lv;

    switch(status&XMODE) {
	case M_EXECUTE:
	    lv = pop();
	    bv = pop();
if(dbg) printf("_if:M_EXECUTE:lv.pl:%d:p:%d:bv.iv:%D\n",lv.lval.place,
	p,bv.ival);
	    if(bv.ival == (long)0) { /* jump to else part. */
		Thisline = lv.lval.codelist;
		Thisline--;
		Thisp = lv.lval.place;
	    }
	    else p++;	/* skip the 0 so we get to the then part */
	    return(p);
	case M_FIXUP:
	case M_COMPILE: l[p++] = 0; return(p);
	default: STerror("if");
    }
}

/* M_COMPILE:
 *	var name <from>expr <to>expr <step>expr <flag>con 0 dlabel FORx rlabel FORx+1 for
 *--to--
 *	_var,vp,<from>,<to>,<step>,<flag>,0,_dlabel,lblp,_rlabel,lblp2,_for
 *
 * M_EXECUTE:
 *	stack: xitpt,vizd,step,to,from,vp,x
 *	other: if exit conditions are correct, jump to exit point.
 *		vizd is used to hold the data type for vp.  Data types
 *		are always non-zero so the test for the first visit to
 *		the loop is to see if vizd is 0.
 */
_for(l,p) int(*l[])(),p;
{
    union value xitpt,vizd,from,to,step,place;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: l[p++] = 0; return(p);
	case M_EXECUTE:
	    xitpt = pop();
	    vizd = pop();
	    step = pop();
 	    to = pop();
	    from = pop();
if(dbg)
printf("_for:EXEC:xit.l:%o:xit.pl:%d:viz.iv:%D:step.iv:%D:to.iv:%D:from.iv:%D:",
xitpt.lval.codelist,xitpt.lval.place,(long)vizd.ival,(long)step.ival,
(long)to.ival,(long)from.ival);
	    if(vizd.ival == 0) { /* first visit to loop */
		place = pop();
if(dbg) printf("first time:var:%s:",place.vpval->name);
		vizd.ival = place.vpval->type_of_value&T_TMASK; /* != 0 */
		place.plval = getplace(place.vpval);
		*(place.plval) = from;	/* since first time, set starting val */
if(dbg) printf("var.pl:%o:var.val:%D:",place.plval,(long)place.plval->ival);
		if(vizd.ival==T_INT && step.ival==0)
			if(to.ival < from.ival)
				step.ival = -1;
			else
				step.ival = 1;
		else if(vizd.ival==T_DBL && step.rval==0)
			if(to.rval < from.rval)
				step.rval = -1;
			else
				step.rval = 1;
	    }
	    else 
		place = pop();
if(dbg) printf("var.place:%o:",place.plval);

	    /* The stack frame is now correctly popped off.
	     * Next, we check if the loop is finished.
	     */

	    if(vizd.ival == T_INT)
		if(step.ival<0 && place.plval->ival<to.ival) 
			goto loop_done;
		else if(step.ival>0 && place.plval->ival>to.ival) 
			goto loop_done;
	    else /* vizd.ival == T_DBL */
		if(step.rval<0 && place.plval->rval<to.rval) 
			goto loop_done;
		else if(step.rval>0 && place.plval->rval>to.rval) 
			goto loop_done;

	    /* Loop is not done yet, push back stack frame. */

if(dbg) printf("loop not done, push everything back\n");
	    push(place);
	    push(from);
	    push(to);
	    push(step);
    	    push(vizd);
	    push(xitpt);
	    return(p);

	default: STerror("for");
    }


	 /* Come here when the loop is finished. */

loop_done:
if(dbg) printf("loop done, jump to xitpt\n");
    Thisline = xitpt.lval.codelist;
    Thisline--;
    Thisp = xitpt.lval.place;
    return(p);
}

/* M_COMPILE:
 *	var name next rlabel FORx go@ dlabel FORx+1
 *--to--
 *	_var,vp,_next,_rlabel,lblp,_go_at,dlabel,lblp2
 *
 * M_EXECUTE:
 *	stack: same as M_EXECUTE in _for.
 *	other: adds step to (control var)->val.
 */
_next(l,p) int(*l[])(),p;
{
    union value vp,xitpt,vizd,step,to,from,place;

    switch(status&XMODE) {
	case M_COMPILE:
	case M_FIXUP: return(p);
	case M_EXECUTE:
	    vp = pop();
if(dbg) printf("_next():EXEC:var:%s",vp.vpval->name);
	    vp.plval = getplace(vp.vpval);
if(dbg) printf(":vp.pl:%o:",vp.plval);
	    xitpt = pop();
	    vizd = pop();
	    step = pop();
	    to = pop();
	    from = pop();
	    place = pop();
if(dbg) printf("pl.pl:%o:from.iv:%D:to.iv:%D:step.iv:%D:viz.iv:%D:",
place.plval,(long)from.ival,(long)to.ival,(long)step.ival,(long)vizd.ival);
if(dbg) printf("xit.list:%o:xit.pl:%d:xit.num:%u\n",xitpt.lval.codelist,
xitpt.lval.place,xitpt.lval.codelist->num);
	    if(place.plval != vp.plval) 
		FNerror(l,p);
	    if(vizd.ival == T_INT)
		place.plval->ival += step.ival;
	    else
		place.plval->rval += step.rval;
	    push(place);
	    push(from);
	    push(to);	
	    push(step);
	    push(vizd);	
	    push(xitpt);
	    return(p);
	default: STerror("next");
    }
}

/* variables needed for M_READ. */

struct line *dlist[DLSIZ];
int dlp = 0;
int dlindx = 2;		/* skips <_data,0> */
int dtype;		/* type of last operation. */


/* M_COMPILE:
 *	x data x     --to--    x,_data,0,x     (0 is for interp())
 * M_FIXUP:
 *	allocates a spot in dlist, stores pointer to llist entry for
 *	this line at that spot.
 * M_EXECUTE:
 *	Returns, with p pointing at the zero, making interp() return.
 */
_data(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = 0;
	    return(p);
#endif
	case M_FIXUP:
	    dlist[dlp++] = gllentry(l);
	    p++;
	case M_EXECUTE: return(p);
	default:
	    STerror("data");
    }
}

/* M_COMPILE:  x dsep x   --to--   x,_dsep,0,x
 */
_dsep(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP:
	    l[p++] = 0;
	case M_READ:
	case M_EXECUTE: return(p);
	default: STerror("dsep");
    }
}

/* routines for changing the interpretors state. */

struct statstk {	/* for saving old states */
	int stkp;
	int stat;
} sstk[30];
int sstktop = 0;

/* M_COMPILE:
 *	x pushstate <state> x    --to--    x,pushstate,<state>,x
 * M_FIXUP:
 *	skip <state>
 * any other state:
 *	save old state and stack pointer.
 *	set state to <state>.
 */
_pushstate(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = atoi(int_in());
	    return(p);
#endif
	case M_FIXUP: return(++p);
	default:
	    sstk[sstktop].stkp = stackp;
	    sstk[sstktop].stat = status;
	    sstktop++;
	    status = l[p++];
	    return(p);
    }
}
_popstate(l,p) int (*l[])(),p;
{
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	default:
	    sstktop--;
	    stackp = sstk[sstktop].stkp;
	    status = sstk[sstktop].stat&XMODE;
	    return(p);
    }
}


/* stack maintanence routines.
 */


/* M_COMPILE:
 *	x spop x    --to--    x,_spop,x
 * M_EXECUTE:
 *	stack: string,x   --to--   x
 *	other: frees storage used by string (if any).
 */
_spop(l,p) int(*l[])(),p;
{
    union value s;

    switch(status&XMODE) {
	case M_EXECUTE:
	    s=pop();
	    if(s.sval != 0) free(s.sval);
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	default:
	    STerror("spop");
    }
}

/* M_COMPILE:
 *	x pop x    --to--    x,_pop,x
 * M_EXECUTE:
 *	stack: int,x    --to--   x
 */
_pop(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_EXECUTE: pop(); return(p);
	default:
	    STerror("pop");
    }
}

_stop(l,p) int(*l[])(),p;
{
    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_EXECUTE: exit(1);
	default:
	    STerror("stop");
    }
}
_end(l,p) int (*l[])(),p; { return(_stop(l,p)); }


/* operator list for the intermediate language. */
struct wlnode wlist[] = {
	"itoa",_itoa,	"print",_print,	"goto",_goto,	"if",_if,
	"rtoa",_rtoa,	"itor",_itor,	"rtoi",_rtoi,
	"gosub",_gosub, "return",_return,
	"icon",_icon,	"i+",_iadd,	"-",_isub,
	"rcon",_rcon,	"r+",_radd,	"r-",_rsub,
	"r*",_rmult,	"r/",_rdiv,
	"i*",_imult,	"i/",_idiv,	"i%",_imod,
	"scon",_scon,	",",_comma,	";",_scolon,
	"i==",_ieq,	"s==",_seq,	"r==",_req,
	"i<>",_ineq,	"r<>",_rneq,	"s<>",_sneq,
	"i<=",_ileq,	"s<=",_sleq,	"r<=",_rleq,
	"i<",_ilt,	"s<",_slt,	"r<",_rlt,
	"i>=",_igeq,	"s>=",_sgeq,	"r>=",_rgeq,
	"i>",_igt,	"s>",_sgt,	"r>",_rgt,
	"or",_or,	"and",_and,	"not",_not,
	"val",_val,	"var",_var,	"store",_store,
	"pop",_pop,	"spop",_spop,
	"pushstate",_pushstate,"popstate",_popstate,
	"stop",_stop,	"end",_end,
	"for",_for,	"next",_next,
	"dlabel",_dlabel,"rlabel",_rlabel,
	"contin",_contin,"leave",_leave,"enter",_enter,"exitlp",_exitlp,
	"data",_data,	"dsep",_dsep,
    0,0
};

SHAR_EOF
if test 14386 -ne "`wc -c < 'newbs/action.c.new'`"
then
	echo shar: error transmitting "'newbs/action.c.new'" '(should have been 14386 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bsint.c'" '(5406 characters)'
if test -f 'newbs/bsint.c'
then
	echo shar: will not over-write existing file "'newbs/bsint.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsint.c'
/* bsint.c -- main part of interpretor.
 */

#include "bsdefs.h"

int (*_null[])() = { 0,0 };

struct line llist[NUMLINES] = {
    0, _null, "",
    MAXLN, _null, ""
};

struct line *lastline = &llist[1];
struct line *Thisline = &llist[0];
int Thisp = 0;

struct dictnode vlist[VLSIZ];



/* gtok() -- read a token using input().  Tokens are delimited by whitespace.
 *	When '\n' is found, "\n" is returned.
 *	For EOF or control characters (not '\n' or '\t') 0 is returned.
 */
char *gtok()
{
    static char token[20];
    register char *s,c;

    s = &token[0];
loop: c=input();
    if(c==' ' || c=='\t') goto loop;
    else if(c == '\n') return("\n");
    else if(c==EOF || iscntrl(c)) return(0);
    else {
	*s++ = c;
	for(c=input(); c>' ' && c<='~'; c=input())
	    *s++ = c;
	unput(c);
	*s++ = '\0';
	return(token);
    }
}

/* insline(num) -- insert num into llist with insertion sort style.
 *	Replaces old lines if already in list.
 */
struct line *insline(num)
int num;
{
    struct line *p,*p2,*p3;
    struct dictnode *vp;
    struct dictnode *gvadr();
    char s[12];

    if(lastline == LASTLINE) return(0);
    for(p=lastline; p->num > num; p--)
	/* null */ ;
    if(p->num == num) {
	if(p->code != 0) { free(p->code); p->code = 0; }
	if(p->text != 0) { free(p->text); p->text = 0; }
    }
    else { /* p->num < num */
	++p;
	p2=lastline;
	p3= ++lastline;
	while(p2 >= p) {
		p3->num = p2->num;
		p3->code = p2->code;
		p3->text = p2->text;
		p2--;
		p3--;
	}
	p->num = num;
	p->text = p->code = 0;
    }
    sprintf(s,"LN%d",num);
    vp = gvadr(s,T_LBL);
    vp->val.lval.codelist = p;
    vp->val.lval.place = 0;
    return(p);
}



/* gladr() -- get address of llist entry, given the line number.
 */
struct line *gladr(lnum)
unsigned lnum;
{
    register struct line *q;
    register int num;

    num = lnum;
    for(q= &llist[0]; q->num!=num && q->num!=MAXLN ; q++)
		;
    if(q->num == MAXLN) return(0);
    /* else */
    if(q->code==0 && q->text==0) return(0); /* fake line */
    /* else */
    return(q); /* found place */
}

/* gllentry() -- Given an address for a code list, return llist entry which
 *	has matching code list address.
 */
struct line *gllentry(l)
int **l;
{
    register int llp;

    for(llp=0; llist[llp].num != MAXLN; llp++)
	if(llist[llp].code == l)
		return(&llist[llp]);

    return(0);	/* such an entry not found */
}

/* glist() -- read rest of line as a code list, return the corresponding
 *	code list.
 */
int **glist()
{
    register char *s;
    int (*codestring[100])();
    int lp,(**l)();
    register int i;

    lp=0;
    for(s=gtok(); s!=0 && strcmp(s,"\n")!=0; s=gtok()) {
	for(i=0; wlist[i].name!=0; i++)
	    if(strcmp(wlist[i].name,s)==0)
		break;
	if(wlist[i].name == 0) {
	    fprintf(stderr,"unknown name %s\n",s);
	    exit(1);
	}
	if(wlist[i].funct == 0) {
	    fprintf(stderr,"glist: no function for %s at %o\n",s,&wlist[i]);
	    exit(1);
	}
	codestring[lp++] = wlist[i].funct;
	lp = (*wlist[i].funct)(codestring,lp);
    }
    codestring[lp++] = 0;
    l = myalloc(lp*2+1);
    blcpy(l,codestring,lp*2);
    return(l);
}

/* rprg -- read in a bunch of lines, put them in program buffer.
 */
rprg()
{
    char *s;
    int ln;
    struct line *pl;

    for(s=gtok(); s!=0; s=gtok()) {
	if(strcmp(s,"line") == 0) {
	    s=gtok();
	    ln=atoi(s);
	    pl=insline(ln);
	    if(pl == 0) {
		fprintf(stderr,"out of room for program\n");
		exit(1);
	    }
	    s=myalloc(strlen(ibuf)+1);
	    strcpy(s,ibuf);
	    pl->text = s;
	    pl->code = glist();
	}
	else { 
	    fprintf(stderr,"syntax error, no line number: %s\n",ibuf);
	    exit(1);
	}
    }
}


interp(l,start)
int (*l[])(),start;
{
    int lp;
    for(lp=start+1; l[lp-1]!=0; lp++)
	lp = (*l[lp-1])(l,lp);
    return(lp);
}

/* runit() -- run the program in llist.  arg- address of place to start at.
 *
 * to do a goto type action, set Thisline to llist entry PREVIOUS to 
 * desired place.  Set Thisp to desired index.  To cause it to happen,
 * place a 0 in the code list where interp() will see it at the right
 * time.
 *
 * All this will cause runit() to run correctly, and automatically take
 * care of updating the line number pointers (Thisline and Thisp).
 */
runit()
{
    int ourthisp;

    ourthisp = Thisp;
    Thisp = 0;
    while(Thisline < lastline) {
	interp((Thisline->code),ourthisp);
	++Thisline;
	ourthisp = Thisp;
	Thisp = 0;
    }
}

int dbg = 0;	/* debugging flag. */
main(argc,argv)
int argc;
char **argv;
{
    int i,j;
    int (**l)();

    if(argc >= 2) {
	if((bsin=fopen(argv[1],"r")) == NULL) {
		fprintf(stderr,"main: could not open input file %s\n",argv[1]);
		exit(1);
	}
    }
    if(argc > 2)
	dbg = 1;	/* "int file <anything>" sets debugging */

    /* Read the program (on file bsin) and compile it to the executable code. */
    rdlin(bsin);
    status = M_COMPILE;
    rprg();
    if(bsin != stdin) 
	fclose(bsin);
    bsin = stdin;	/* make sure it is stdin for execution */
    iptr = 0;
    ibuf[iptr] = 0;	/* make the input buffer empty. */

    /* Scan through the compiled code, make sure things point to where
     * they are supposed be pointing to, etc.
     */
    status = M_FIXUP;
    Thisline = &llist[0];
    while(Thisline < lastline) {
	interp((Thisline->code),0);
	++Thisline;
    }

    status = M_EXECUTE;
    dlp = 0;	/* set it back to beginning of list */
    Thisline = &llist[0];
    Thisp = 0;
    runit();
}
SHAR_EOF
if test 5406 -ne "`wc -c < 'newbs/bsint.c'`"
then
	echo shar: error transmitting "'newbs/bsint.c'" '(should have been 5406 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/errors.c'" '(1583 characters)'
if test -f 'newbs/errors.c'
then
	echo shar: will not over-write existing file "'newbs/errors.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/errors.c'
/* errors.c -- error message routines for int.
 */

#include "bsdefs.h"


/* ULerror() -- unknown line (cannot find wanted line)
 */
ULerror(l,p) int(*l[])(),p;
{
    fprintf(stderr,"Unknown line %d\n",*(l[p]));
    exit(1);
}

/* STerror() -- wrong value for status variable
 */
XSTerror(f) char *f;
{
    fprintf(stderr,"%s: illegal status %o\n",f,status);
    exit(1);
}
/* FNerror() -- For Next error
 */
XFNerror(l,p)
int (*l[])(),p;
{
    struct dictnode *nv;
    struct line *ll;

    ll = gllentry(l);
    nv = l[p-2];
    fprintf(stderr,"Next %s, For (something else), at line %u\n",
	nv->name,ll->num);
    exit(1);
}

ODerror(l,p)
int (*l[])(),p;
{
    struct line *ll;
    char *s;
    ll = gllentry(l);
    s = ((struct dictnode *)l[p])->name;
    fprintf(stderr,"Out of Data in line %u at var %s\b",ll->num,s);
    exit(1);
}

BDerror(l,p)
int (*l[])(),p;
{
    struct line *ll;
    char *s;
    ll = gllentry(l);
    s = ((struct dictnode *)l[p])->name;
    fprintf(stderr,"Bad Data type in line %u at var %s\n",ll->num,s);
    exit(1);
}

VTerror(l,p)
int (*l[])(),p;
{
    struct dictnode *vp;
    vp = (struct dictnode *)l[p];
    fprintf(stderr,"Invalid data type %d for var %s\n",vp->type_of_value,vp->name);
    exit(1);
}

LVerror(l,p) int(*l[])(),p;
{
    struct line *ll;
    ll = gllentry(l);
    fprintf(stderr,"Tried to leave while not in a loop, at line %u\n",ll->num);
    exit(1);
}

CNerror(l,p) int(*l[])(),p;
{
    struct line *ll;
    ll = gllentry(l);
    fprintf(stderr,"Tried to continue while not in a loop, at line %u\n",ll->num);
    exit(1);
}
SHAR_EOF
if test 1583 -ne "`wc -c < 'newbs/errors.c'`"
then
	echo shar: error transmitting "'newbs/errors.c'" '(should have been 1583 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/mkrbop.c'" '(734 characters)'
if test -f 'newbs/mkrbop.c'
then
	echo shar: will not over-write existing file "'newbs/mkrbop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mkrbop.c'
/* mkrbop.c -- make operator functions for bs.  (real-boolean functions.)
*
*	USAGE: op name oper
*
* where:	name: name of function generated.
*		oper: operator for operation.
*/
#include <stdio.h>

main(argc,argv)
char **argv;
int argc;
{
char *name,*oper;

if(argc != 3) {
	fprintf(stderr,"arg count\n");
	exit(1);
}
name = argv[1]; oper = argv[2];

printf("_%s(l,p)\n",name);
printf("int (*l[])(),p;\n");
printf("{\n");
printf("    union value rg1,rg2,result;\n");
printf("\n");
printf("    if((status&XMODE) == M_EXECUTE) {\n");
printf("	rg2 = pop();\n");
printf("	rg1 = pop();\n");
printf("	result.ival = rg1.rval %s rg2.rval;\n",oper);
printf("	push(result);\n");
printf("    }\n");
printf("    return(p);\n");
printf("}\n");
}
SHAR_EOF
if test 734 -ne "`wc -c < 'newbs/mkrbop.c'`"
then
	echo shar: error transmitting "'newbs/mkrbop.c'" '(should have been 734 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/operat.c.new'" '(9302 characters)'
if test -f 'newbs/operat.c.new'
then
	echo shar: will not over-write existing file "'newbs/operat.c.new'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/operat.c.new'
/* operat.c -- operations, as opposed to actions.  FOR is an action,
 *	'+' is an operation.
 *
 * More operators can be found in the machine generated file "operat2.c".
 */

#include "bsdefs.h"


/*	BINARY OPERATORS	*/

/* Common description for the binary ops.
 *  also applies to all ops in operat2.c
 *
 * M_COMPILE:
 *	x op x   --to--   x,_op,x
 * M_EXECUTE:
 *	stack: ar2,ar1,x   --to--   (ar1 op ar2),x
 */


_comma(l,p) int (*l[])(),p;
{
    union value s1,s2,s3;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	case M_READ: dtype = T_CHR;
	case M_EXECUTE:
	    s1 = pop();
	    s2 = pop();
	    s3.sval = myalloc(strlen(s1.sval)+strlen(s2.sval)+3);
	    strcpy(s3.sval,s2.sval);
	    strcat(s3.sval,"\t");
	    strcat(s3.sval,s1.sval);
	    if(s1.sval != 0) free(s1.sval);
	    if(s2.sval != 0) free(s2.sval);
	    push(s3);
	    return(p);
	default: STerror("comma");
    }
}
_scolon(l,p) int(*l[])(),p;
{
    union value s1,s2,s3;
    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
#endif
	case M_FIXUP: return(p);
	case M_READ: dtype = T_CHR;
	case M_EXECUTE:
	    s1 = pop();
	    s2 = pop();
	    s3.sval = myalloc(strlen(s1.sval)+strlen(s2.sval)+2);
	    strcpy(s3.sval,s2.sval);
	    strcat(s3.sval,s1.sval);
	    push(s3);
	    if(s1.sval != 0) free(s1.sval);
	    if(s2.sval != 0) free(s2.sval);
	    return(p);
	default:
	    STerror("scolon");
    }
}
/* last of binary operators */

/* M_COMPILE:
 *	x not x    --to--    x,_not,x
 * M_EXECUTE:
 *	stack: bool,x    --to--     !(bool),x
 */
_not(l,p) int (*l[])(),p;
{
    union value val;

    if((status&XMODE) == M_EXECUTE) {
	val = pop();
	val.ival = ! val.ival;
	push(val);
    }
    return(p);
}

/* M_COMPILE:
 *	x itoa x   --to--   x,_itoa,x
 * M_EXECUTE:
 *	stack: int,x   --to--   string,x
 */
_itoa(l,p)
int (*l[])(),p;
{
    union value val;
    char s2[30];

    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_READ:
	    dtype = T_CHR;
	case M_EXECUTE:
	    val=pop();
	    sprintf(s2,"%D",val.ival);	/* optimize later */
if(dbg) printf("_icon():M_EXECUTE:ival:%D to sval:%s\n",val.ival,s2);
	    val.sval=myalloc(strlen(s2)+1);
	    strcpy(val.sval,s2);
	    push(val);
	    return(p);
	default:
	    STerror("itoa");
    }
}
_rtoa(l,p)
int (*l[])(),p;
{
    union value val;
    char s2[30];

    switch(status&XMODE) {
	case M_FIXUP:
	case M_COMPILE: return(p);
	case M_READ: dtype = T_CHR;
	case M_EXECUTE:
	    val = pop();
	    sprintf(s2,"%g",val.rval);
if(dbg) printf("_rtoa():M_EXECUTE:rval:%g to sval:%s\n",val.rval,s2);
	    val.sval = myalloc(strlen(s2)+1);
	    strcpy(val.sval,s2);
	    push(val);
	    return(p);
	default: STerror("rtoa");
    }
}
_itor(l,p)
int (*l[])(),p;
{
    union value v1,v2;

    switch(status&XMODE) {
	case M_READ: dtype = T_DBL;
	case M_EXECUTE:
	    v1 = pop();
	    v2.rval = (double)v1.ival;
	    push(v2);
	case M_FIXUP:
	case M_COMPILE: return(p);
	default: STerror("itor");
    }
}
_rtoi(l,p)
int (*l[])(),p;
{
    union value v1,v2;

    switch(status&XMODE) {
	case M_READ: dtype = T_INT;
	case M_EXECUTE:
	    v1 = pop();
	    v2.ival = (int)v1.rval;
	    push(v2);
	case M_FIXUP:
	case M_COMPILE: return(p);
	default: STerror("rtoi");
    }
}

/* M_COMPILE:
 *	x scon "quoted string" x   --to--   x,_scon,*string,x
 * M_EXECUTE:
 *	stack: x   --to--   string,x
 *	other: pushes a COPY of the string, not the original.
 */
_scon(l,p)
int (*l[])(),p;
{
    char *s,c;
    union value val;
    int i;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = scon_in();
	    return(p);
#endif
	case M_READ:
	    dtype = T_CHR;
	case M_EXECUTE:
	    s = l[p++];
	    val.sval = myalloc(strlen(s)+1);
	    strcpy(val.sval,s);
	    push(val);
if(dbg) printf("_scon():M_EXECUTE:sval:%s\n",val.sval);
	    return(p);
	case M_FIXUP: p++; return(p);
	default: STerror("scon");
    }
}

/* M_COMPILE:
 *	x icon int x   --to--   x,_icon,int,x
 * M_EXECUTE:
 *	stack: x   --to--   int,x
 */
_icon(l,p)
int (*l[])(),p;
{
    union value val;
    union loni v;
    int i;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    v.l_in_loni = atol(int_in());
	    for(i=0; i<(sizeof(long)/sizeof(int)); i++)
		l[p++] = v.i_in_loni[i];
	    return(p);
#endif
	case M_READ: dtype = T_INT;
	case M_EXECUTE:
	    for(i=0; i<(sizeof(long)/sizeof(int)); i++)
		v.i_in_loni[i] = l[p++];
	    val.ival = v.l_in_loni;
	    push(val);
if(dbg) printf("_icon():M_EXECUTE:ival:%D\n",val.ival);
	    return(p);
	case M_FIXUP:
	    p += (sizeof(long)/sizeof(int));
	    return(p);
	default: STerror("icon");
    }
}
_rcon(l,p)
int (*l[])(),p;
{
    union doni v;
    int i;
    union value val;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    v.d_in_doni = atof(real_in());
	    for(i=0; i<(sizeof(double)/sizeof(int)); i++)
		l[p++] = v.i_in_doni[i];
	    return(p);
#endif
	case M_FIXUP:
	    p += (sizeof(double)/sizeof(int));
	    return(p);
	case M_READ: dtype = T_DBL;
	case M_EXECUTE:
	    for(i=0; i<(sizeof(double)/sizeof(int)); i++)
		v.i_in_doni[i] = l[p++];
	    val.rval = v.d_in_doni;
	    push(val);
	    return(p);
	default: STerror("rcon");
    }
}

/* M_COMPILE:
 *	x val type x   --to--   x,_val,type,x
 * M_EXECUTE:
 *	stack:	place,x   --to--   value,x
 *	other: for strings, pushes a copy of the string.
 */
_val(l,p) int(*l[])(),p;
{
    union value place,val;
    int ty;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = atoi(int_in());
	    return(p);
#endif
	case M_READ:
	    dtype = l[p];
	case M_EXECUTE:
	    ty = l[p];
	    place = pop();
if(dbg) printf("_val():M_EXECUTE:var:%s",place.vpval->name);
	    place.plval = getplace(place.vpval);
	    if(ty==T_CHR && place.plval->sval!=0) {
		val.sval = myalloc(strlen(place.plval->sval)+1);
		strcpy(val.sval,place.plval->sval);
		push(val);
	    }
	    else push(*place.plval);
if(dbg) printf(":ival:%D:rval:%g:sval:%s\n",ty==T_INT?place.plval->ival:(long)0,
	ty==T_DBL?place.plval->rval:(double)0,ty==T_CHR?place.plval->sval:0);
	case M_FIXUP: p++; return(p);
	default: STerror("val");
    }
}

/* M_COMPILE:
 *	x store typ x   --to--    x,_store,type,x
 * M_EXECUTE:
 *	stack: value,location,x   --to--   value,x
 *		(stores value at location).
 */
_store(l,p) int(*l[])(),p;
{
    union value place,val;
    int ty;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    l[p++] = atoi(int_in());
	    return(p);
#endif
	case M_READ:
	    dtype = l[p];
	case M_EXECUTE:
	    val = pop();
	    place = pop();
	    ty = l[p];
if(dbg) printf("_store():M_EXECUTE:var:%s:ival:%D:rval:%g:sval:%s\n",
	place.vpval->name,ty==T_INT?val.ival:(long)0,ty==T_DBL?val.rval:(double)0,ty==T_CHR?val.sval:0);
	    place.plval = getplace(place.vpval);
	    if(ty==T_CHR && place.plval->sval!=0) free(place.plval->sval);
	    (*place.plval) = val;
	    push(val);
	case M_FIXUP:
	    p++;
	    return(p);
	default: STerror("store");
    }
}

/* M_COMPILE:
 *	x var typ name x   --to--    x,_var,&vlist entry,x
 * M_EXECUTE:
 *	stack: x   --to--   &vlist entry,x
 * M_INPUT:
 *	(&vlist entry)->val is set to input value.
 * M_READ:
 *	Moves the data list pointers to the next data item.  If no next
 *	data item, calls ODerror.
 *	Does a "gosub" to the data item, to get its value on the stack.
 *	Does T_INT to T_CHR conversion if necessary.
 *	Pops value into vp->val.
 */
_var(l,p) int(*l[])(),p; /* same proc for any variable type */
{
    char *s;
    struct dictnode *vp;
    struct line *thislist;
    union value place,val;
    int ty,qual;

    switch(status&XMODE) {
#ifdef INT
	case M_COMPILE:
	    ty = atoi(int_in());
	    s = gtok();
	    l[p++] = gvadr(s,ty);
	    return(p);
#endif
	case M_EXECUTE:
	    val.vpval = l[p++];
if(dbg) printf("_var():M_EXECUTE:var:(%d)%s\n",val.vpval->type_of_value,
	val.vpval->name);
	    push(val);
	    return(p);
	case M_INPUT:
	    vp = l[p++];
	    place.plval = getplace(vp);
	    ty = (vp->type_of_value) & T_TMASK;
	    if(ty == T_INT)
		place.plval->ival = atol(int_in());
	    else if(ty == T_DBL)
		place.plval->rval = atof(real_in());
	    else 
		place.plval->sval = scon_in();
if(dbg) printf("_var():M_INPUT:var:(%d)%s:ival:%D:rval:%g:sval:%s\n",
vp->type_of_value,vp->name,ty==T_INT?place.plval->ival:(long)0,
ty==T_DBL?place.plval->rval:(double)0,ty==T_CHR?place.plval->sval:0);
	    return(p);
	case M_READ:
nxdl:	    if(dlist[dlp] == 0) ODerror(l,p);	/* ran off end of dlist */
	    thislist = dlist[dlp];
	    if((thislist->code)[dlindx] == 0) {
		dlp++;
		dlindx = 2;	/* skips <_data,0> */
		goto nxdl;
	    }

	    status = M_EXECUTE;
	    dlindx = interp(thislist->code,dlindx);
	    status = M_READ;

	    val = pop();
	    vp = l[p];
	    place.plval = getplace(vp);
	    qual = vp->type_of_value&T_TMASK;
	    if(qual == T_INT)
		place.plval->ival = val.ival;
	    else if(qual == T_DBL)
		place.plval->rval = val.rval;
	    else if(qual == T_CHR) {
		if(dtype == T_INT) {
			push(val); _itoa(l,p); val = pop();
		}
		else if(dtype == T_DBL) {
			push(val); _rtoa(l,p); val = pop();
		}
		if(place.plval->sval != 0) free(place.plval->sval);
		place.plval->sval = myalloc(strlen(val.sval)+1);
		strcpy(place.plval->sval,val.sval);
	    }
	    else VTerror(l,p);
	case M_FIXUP:
	    p++;
	    return(p);
	default: STerror("var");
    }
}
SHAR_EOF
if test 9302 -ne "`wc -c < 'newbs/operat.c.new'`"
then
	echo shar: error transmitting "'newbs/operat.c.new'" '(should have been 9302 characters)'
fi
fi # end of overwriting check
#	End of shell archive
exit 0