sources-request@genrad.UUCP (07/30/85)
Mod.sources: Volume 2, Issue 22 Submitted by: ukma!david (David Herron) About a month ago I posted a response saying that I had a BASIC interpretor I'd written (that it wasn't a working interpretor) and that I'd post it if anybody wanted to debug it. Well, something in the offer must have sounded tempting since I got about 30 replies all saying yes. So here it is. Let me give a little bit of the history first. About 3 years ago I was taking a course entitled something like "Minicomputer Management". Which, it was basically a smoke screen behind which to introduce students to the wonderful world on Unix. (On 2 PDP-11/23's (not 23+) running Version 7 (now 2.9BSD)). Two weeks before the end of class we were assigned to write a BASIC interpretor. Nobody else finished it but me, but it took me a year and a half to get a working version. (I spent a lot of that time playing with different ideas for parsing). I had it working. But it was in two parts. A parser which turned the BASIC programs into a stack based intermediate language, and the interpretor for the intermediate language. There was no immediate type in program and run it capability. You had to run ed, write the file, save it, convert it, THEN run it. I really wanted to have the two parts in one piece, so I started improving it. Unfortunately, about half way through improving the program I got hired for my current job. (One of those student slave labor deals). And I never finished it. I don't know the status of the code I am sending. It may be code from the first iteration, or it may be from the current (now a year old) iteration. There are three directories under here, as follows: bs2 This has sources which will make the two part translator/interpretor I described above. But I don't know if the files will compile into a runnable program or not. bstest Some basic programs and the output produced by the translator. It should help you in understanding what the intermediate code should look like. newbs This is where I was working on the new interpretor. I was trying to make bsgram.y produce EITHER the ascii intermediate file, or an incore version that could be run immediately. I may also have been trying to clean up the grammar some. The intermediate language is intended to be much like FORTH. It is not a full FORTH of course, butis much simplified. I picked this route partly as a path of least resistance, and partly to try out an idea. (I had a good description of how to build a FORTH, if you are interested look for the article in 1981 or 1982 of the IEEE Computer magazine). Around that time I had an inspiration on a better way to implement languages. I had recieved a strong lesson in the amount of work that was needed to implement a language on a new piece of hardware. My idea is similar to the P-code method of implementing Pascal. Design a machine-independant intermediate language which is simple yet provides facilities needed by a language interpretor. You would save a lot of time in porting languages to new hardware this way, especially if the intermediate language was easy to interpret. I already knew that RPN was easy to interpret having worked with one previously. And I could show myself that it was easy to convert an expression tree to an RPN expression. So this looked good. The idealistic form of this interpretor is simply an array of pointers to procedures which are called in order. In actuality arguments to the routines are interspersed with the pointers. The comments in the code try to make this clear. This is (currently) the only documentation, and in some cases the code and the comments may not agree. Remember that this is a work in progress that was never completed. (But now that I'm thinking about it again, I see so many better ways of doing things, I may just give it another go.) A quick word about efficiency and I'll get off this subject. My standard quickie benchmark is the nearest equivalent to: 10 FOR I = 1 TO 10000 20 NEXT I I ran this on both a TRS-80 Color Computer (it was handy) with floating point arithmetic, and my interpretor running on a LSI-11/23 with integer arithmetic. They both took about 15 seconds to run this. As a first attempt I am pleased to have showed so well against seasoned professionals. On the other hand, considering the differences in data types, and CPU speeds, should have given a two to three times difference. (In the favor of the LSI-11). There is one GLARING thing I should do when (if) I do this over. I should not have the interpretor doing procedure calls for each instruction, but should have the main loop be a large switch statement. This was an early design decision that I now regret. I went with using the procedure calls because it seemed that I would end up with a less monolithic system.
sources-request@genrad.UUCP (07/30/85)
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 0sources-request@genrad.UUCP (07/31/85)
Mod.sources: Volume 2, Issue 24
Submitted by: ukma!david (David Herron)
#! /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/bsdefs.c
# newbs/bsdefs.h
# newbs/bsgram.y
# newbs/bslash.c
# newbs/bslib.c
# newbs/getplace.c
# newbs/gvadr.c
# newbs/makefile
# newbs/makefile.old
# newbs/mkop.c
# newbs/mkop.sh
# newbs/mksop.c
# newbs/num_ins.c
# newbs/op2.c
# newbs/operat.c
# newbs/scon_in.c
# This archive created: Tue Jul 30 13:02:34 1985
export PATH; PATH=/bin:$PATH
if test ! -d 'newbs'
then
echo shar: creating directory "'newbs'"
mkdir 'newbs'
fi
echo shar: extracting "'newbs/bsdefs.c'" '(1128 characters)'
if test -f 'newbs/bsdefs.c'
then
echo shar: will not over-write existing file "'newbs/bsdefs.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsdefs.c'
/* bsdefs.c -- Actual definitions of all the variables.
*
* bsdefs.h only has the "extern's" of the things declared in here.
*/
#include "bsdefs.h"
/* Initial stuff for line number table.
*
* The line number table is a singly-linked list. The head is "firstline",
* and the tail is "lastline". The proper way to check for the end of the
* list is to compare it to LASTLINE. Lastline points to itself in case
* I forget and code something differently (it also neatly ties up the end
* of the list).
*/
#define LASTLINE (struct line *)(&lastline)
struct line lastline = { &lastline,0077777,"",_nulline };
struct line firstline = { &lastline,0,"",_nulline };
struct line *curline = LASTLINE;
/* Initial stuff for data statements.
*
* "dlist[]" holds pointers to lines that have data on them. It is initialized
* in M_FIXUP. "dlp" used to allocate entries from dlist[], it points to the
* first free entry. "dlindx" points within the current data line to the next
* data item.
* "dtype" indicates the data type for the last data item.
*/
struct line *dlist[DLSIZ];
int dlp = 0,dlindx = 0, dtype = 0;
SHAR_EOF
if test 1128 -ne "`wc -c < 'newbs/bsdefs.c'`"
then
echo shar: error transmitting "'newbs/bsdefs.c'" '(should have been 1128 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bsdefs.h'" '(4648 characters)'
if test -f 'newbs/bsdefs.h'
then
echo shar: will not over-write existing file "'newbs/bsdefs.h'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsdefs.h'
/* bsdefs.h -- definition file for bs.
*/
#include <stdio.h>
#include <ctype.h>
/* 'Machine' status */
extern int status;
#define M_COMPILE (1<<0)
#define M_EXECUTE (1<<1)
#define M_INPUT (1<<2)
#define M_FIXUP (1<<3)
#define M_READ (1<<4)
#define XMODE (M_COMPILE|M_EXECUTE|M_INPUT|M_FIXUP|M_READ)
/* line table. */
#define LASTLINE (struct line *)(&lastline)
struct line {
struct line *nextline; /* next entry in list. */
int lnum; /* its' number */
int (*list)(); /* its' definition */
char *text; /* the original definition */
};
extern struct line firstline,lastline,*curline;
/* Variable types */
#define Q_NRM 0 /* nice, ordinary variable */
#define Q_ARY 1 /* array */
#define Q_BF 2 /* builtin-function */
#define Q_UFL 3 /* long user function */
#define Q_UFS 4 /* short user function */
/* in type part, a zero value is an undefined type. */
#define T_INT (1<<6)
#define T_CHR (2<<6)
#define T_DBL (3<<6)
#define T_LBL (4<<6)
#define T_QMASK 037 /* lower 5 bits for type qualifier */
#define T_TMASK (T_INT|T_CHR|T_DBL|T_LBL)
/* variable table */
#define VLSIZ 150
struct label {
char *name; /* what do we call it by. */
int (*where)(); /* and where does it live */
};
/* For arrays, storage of them is defined as follows:
*
* 1st item: number of dimensions in array <NDIMS>.
* next <NDIMS> items: size of each dimension.
* rest of items: the actual values.
*
* Until we can support varrying sized arrays this is the setup:
*
* 1,10,x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10
*
* for a total size of 13 items.
*/
union value {
long ival; /* T_INT */
double rval; /* T_DBL */
char *sval; /* T_CHR */
struct label lval; /* T_LBL */
struct line *locval; /* for pushing line# list entries */
union value *arval; /* any+Q_ARY */
struct dictnode *vpval; /* for use when pushing variable pointers */
union value *plval; /* for use when pushing pointers to a value */
};
struct dictnode { /* format of vlist entry */
struct dictnode *father,*daughter; /* doubly-linked list. */
char *name; /* name of entry. */
int type_of_value; /* its type. */
union value val; /* and its value */
};
extern struct dictnode *dicthead,*dictail,*curvp;
/* '_' Function table */
extern
_print(), _goto(), _if(), _else(),
_for(), _next(), _read(), _data(),
_dsep(), _spop(), _pop(), _stop(),
_end(), _dlabel(), _rlabel(), _contin(),
_leave(), _enter(), _exitlp(), _iadd(),
_isub(), _imult(), _idiv(), _imod(),
_comma(), _radd(), _rsub(), _rmult(),
_rdiv(), _scolon(), _gosub(), _return(),
_not(), _ieq(), _req(), _seq(),
_ineq(), _rneq(), _sneq(), _ileq(),
_rleq(), _sleq(), _ilt(), _rlt(),
_slt(), _igeq(), _rgeq(), _sgeq(),
_igt(), _rgt(), _sgt(), _or(),
_and(), _itoa(), _rtoa(), _itor(),
_rtoi(), _pushstate(), _popstate(), _scon(),
_rcon(), _icon(), _val(), _store(),
_var();
/*
* Data table.
* Array of pointers into llist.
* Each is a line which has data.
*/
#define DLSIZ 100
extern struct line *dlist[]; /* actual table, number of elems. is DLSIZ */
extern int dlp; /* index into dlist for current line of data */
extern int dlindx; /* index into current line for current data item. */
extern int dtype; /* in M_READ, operators set this to the type of
* their operation. When the expression is done
* executing, this variable will indicate its type.
*/
/* error routines */
extern int ULerror();
extern int STerror();
extern int FNerror();
extern int ODerror();
extern int BDerror();
extern int VTerror();
/*
* unions for storing data types in the code list
*
* Used to convert from a double (for instance) into "int" sized chunks
* for the purpose of manipulating instances of them in code lists.
*/
union doni {
double d_in_doni;
int i_in_doni[sizeof(double)/sizeof(int)];
};
union loni {
long l_in_loni;
int i_in_loni[sizeof(long)/sizeof(int)];
};
union voni {
union value v_in_voni;
int i_in_voni[sizeof(union value)/sizeof(int)];
};
/* miscellaneous definitions. */
#define STKSIZ 500
extern union value stack[];
extern int stackp;
extern int push();
extern union value pop();
#define CSTKSIZ 5
#define BFSIZ 200 /* input buffer */
extern char pbbuf[]; /* unput() buffer */
extern char ibuf[];
extern int iptr,pbptr;
extern char input();
extern rdlin(),unput();
extern blcpy();
extern char bslash();
extern char *scon_in();
extern int num_in();
extern char *myalloc();
extern union value *getplace();
extern struct line *gllentry();
extern FILE *bsin;
extern int dbg; /* debugging flag. */
extern long atol();
extern double atof();
SHAR_EOF
if test 4648 -ne "`wc -c < 'newbs/bsdefs.h'`"
then
echo shar: error transmitting "'newbs/bsdefs.h'" '(should have been 4648 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bsgram.y'" '(8891 characters)'
if test -f 'newbs/bsgram.y'
then
echo shar: will not over-write existing file "'newbs/bsgram.y'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bsgram.y'
/* bsgram.y -- grammer specification for bs.
*/
%{
#include "bsdefs.h"
char *p; /* the generic pointer */
int i; /* the generic counter */
int (*l[300])(); /* array to generate the code list into. */
int lp; /* pointer to current spot in l[] */
struct stk {
int stack[40];
int stkp;
};
struct stk ifstk,whstk,forstk,repstk,lpstk;
int gomax=0, ifmax=0, whmax=0, formax=0, repmax=0, lpmax=0;
extern char *yytext;
extern char *bsyysval;
extern int yyleng;
%}
%term EQUAL NEQ LE LT GE WHILE
%term GT OR AND NOT RET REPEAT
%term IF THEN ELSE GOTO GOSUB UNTIL
%term STOP END INTEGER REAL SCONST ELIHW
%term LET SWORD PRINT INPUT DATA CFOR
%term FOR TO STEP READ WRITE NEXT
%term DEFINE LFUN SFUN FDEF SYMBOL DIM
%term VALUE IWORD RWORD ROFC LOOP EXITIF
%term ITOR RTOI ITOA RTOA LEAVE CONTINUE
%term POOL
%left ',' ';'
%right '='
%nonassoc OR AND
%nonassoc LE LT GE GT EQUAL NEQ
%left '+' '-'
%left '*' '/' '%'
%left UNARY
%left '('
%start lines
%%
lines : /* empty */
| lines line
;
line : lnum stat '\n'
{ printf("\n"); }
| '\n'
;
lnum : INTEGER
{ bundle(2,_line,atoi($1); }
;
stat : LET let_xpr
| let_xpr
| PRINT pe
{ bundle(1,_print); }
| GOTO INTEGER
{
sprintf(s,"LN%s",$2);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
}
| GOSUB INTEGER
{
sprintf(s,"LN%s",$2);
bundle(4,_rlabel,gvadr(s,T_LBL),_gosub,0);
}
| LEAVE
{ bundle(2,_leave,0); }
| CONTINUE
{ bundle(2,_contin,0); }
| RET
{ bundle(1,_return); }
| IF bexpr
{
lpush(&ifstk,ifmax);
sprintf(s,"IF%d",ifmax);
bundle(4,_rlabel,gvadr(s,T_LBL),_if,0);
ifmax += 2;
}
THEN stat
{
i = ltop(&ifstk);
sprintf(s,"IF%d",i+1);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
}
if_else
| INPUT
{ bundle(2,_pushstate,M_INPUT); }
var_lst
{ bundle(1,_popstate); }
| STOP
{ bundle(1,_stop); }
| END
{ bundle(1,_end); }
| FOR nvar '=' rexpr TO rexpr for_step
{
lpush(&forstk,formax);
sprintf(s,"FOR%d",formax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"FOR%d",formax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"FOR%d",formax+1);
bundle(5,_icon,(long)0,_rlabel,gvadr(s,T_LBL));
sprintf(s,"FOR%d",formax);
bundle(4,_dlabel,gvadr(s,T_LBL),_for,0);
formax += 3;
}
| NEXT
{
i = ltop(&forstk);
sprintf(s,"FOR%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
nvar
{
i = lpop(&forstk);
sprintf(s,"FOR%d",i);
bundle(5,_next,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"FOR%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| READ
{ bundle(2,_pushstate,M_READ); }
var_lst
{ bundle(1,_popstate); }
| DATA
{ bundle(2,_data,0); }
data_lst
| LOOP
{
lpush(&lpstk,lpmax);
sprintf(s,"LP%d",lpmax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"LP%d",lpmax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"LP%d",lpmax);
bundle(2,_dlabel,gvadr(s,T_LBL));
lpmax += 3;
}
| EXITIF bexpr
{
i = ltop(&lpstk);
sprintf(s,"LP%d",i+1);
bundle(5,_not,_rlabel,gvadr(s,T_LBL),_if,0);
}
| POOL
{
i = lpop(&lpstk);
sprintf(s,"LP%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"LP%d",i);
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"LP%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| WHILE
{
lpush(&whstk,whmax);
sprintf(s,"WH%d",whmax+2);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"WH%d",whmax+1);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"WH%d",whmax);
bundle(2,_rlabel,gvadr(s,T_LBL));
whmax += 3;
}
bexpr
{
i = ltop(&whstk);
sprintf(s,"WH%d",i+1);
bundle(4,_rlabel,gvadr(s,T+LBL),_if,0);
}
| ELIHW
{
i = lpop(&whstk);
sprintf(s,"WH%d",i+2);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"WH%d",i)
bundle(4,_rlabel,gvadr(s,T_LBL),_goto,0);
sprintf(s,"WH%d",i+1);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
| REPEAT
{
lpush(&repstk,repmax);
sprintf(s,"REP%d",repmax+1);
bundle(2,_rlabel,gvadr(s,T_LBL));
sprintf(s,"REP%d",repmax+2);
bundle(3,_rlabel,gvadr(s,T_LBL),_enter);
sprintf(s,"REP%d",repmax);
bundle(2,_dlabel,gvadr(s,T_LBL));
repmax += 3;
}
| UNTIL
{
i = ltop(&repstk);
sprintf(s,"REP%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
bexpr
{
i = lpop(&repstk);
sprintf(s,"REP%d",i);
bundle(5,_not,_rlabel,gvadr(s,T_LBL),_if,0);
sprintf(s,"REP%d",i+2);
bundle(3,_dlabel,gvadr(s,T_LBL),_exitlp);
}
;
nvar : ivar
| rvar
;
let_xpr : ivar '=' rexpr
{ bundle(4,_rtoi,_store,T_DBL,_pop); }
| rvar '=' rexpr
{ bundle(3,_store,T_DBL,_pop); }
| svar '=' sexpr
{ bundle(3,_store,T_CHR,spop); }
;
data_lst : rexpr
{ bundle(2,_dsep,0); }
| sexpr
{ bundle(1,_dsep); }
| data_lst ',' rexpr
{ bundle(1,_dsep); }
| data_lst ',' sexpr
{ bundle(1,_dsep); }
;
ind_lst : rexpr
| ind_lst ',' rexpr
;
for_step : /* empty */
{ bundle(3,_icon,(long)0); }
| STEP rexpr
;
if_else : /* empty */
{
i = lpop(&ifstk);
sprintf(s,"IF%d",i);
bundle(2,_dlabel,gvadr(s,T_LBL));
sprintf(s,"IF%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
| ELSE
{
i = ltop(&ifstk);
sprintf(s,"IF%d",i);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
stat
{
i = lpop(&ifstk);
sprintf(s,"IF%d",i+1);
bundle(2,_dlabel,gvadr(s,T_LBL));
}
;
pe : sexpr ','
{ bundle(3,_scon,"",_comma); }
| sexpr ';'
| sexpr
{ bundle(3,_scon,"\\n",_scolon); }
| /* empty */
{ bundle(2,_scon,"\\n"); }
;
var_lst : ivar
| rvar
| svar
| var_lst ',' var_lst
;
sexpr : SCONST
{ p=myalloc(yyleng); strcpy(p,$1); bundle(2,_scon,p); }
| svar
{ bundle(2,_val,T_CHR); }
| rexpr
{ bundle(1,_rtoa); }
| svar '=' sexpr
{ bundle(2,_store,T_CHR); }
| sexpr ';' sexpr
{ bundle(1,_scolon); }
| sexpr '+' sexpr
{ bundle(1,_scolon); }
| sexpr ',' sexpr
{ bundle(1,_comma); }
| '(' sexpr ')'
;
sbe : sexpr EQUAL sexpr
{ bundle(1,_seq); }
| sexpr NEQ sexpr
{ bundle(1,_sneq); }
| sexpr LE sexpr
{ bundle(1,_sleq); }
| sexpr LT sexpr
{ bundle(1,_slt); }
| sexpr GE sexpr
{ bundle(1,_sgeq); }
| sexpr GT sexpr
{ bundle(1,_sgt); }
;
ivar : IWORD
{ bundle(2,_var,gvadr($1,T_INT)); }
| IWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_INT+Q_ARY)); }
;
rvar : RWORD
{ bundle(2,_var,gvadr($1,T_DBL)); }
| RWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_DBL+Q_ARY)); }
;
svar : SWORD
{ bundle(2,_var,gvadr($1,T_CHR)); }
| SWORD '('
{ bundle(2,_pushstate,M_EXECUTE); }
ind_lst ')'
{ bundle(3,_popstate,_var,gvadr($1,T_CHR+Q_ARY)); }
;
rexpr : rvar
{ bundle(2,_val,T_DBL); }
| REAL
{ bundle(5,_rcon,(double)atof($1)); }
| INTEGER
{ bundle(5,_rcon,(double)atof($1)); }
| ivar
{ bundle(3,_val,T_INT,_itor); }
| rvar '=' rexpr
{ bundle(2,_store,T_DBL); }
| '(' rexpr ')'
| rexpr '+' rexpr
{ bundle(1,_radd); }
| rexpr '-' rexpr
{ bundle(1,_rsub); }
| rexpr '*' rexpr
{ bundle(1,_rmult); }
| rexpr '/' rexpr
{ bundle(1,_rdiv); }
| '+' rexpr %prec UNARY
| '-' rexpr %prec UNARY
{ bundle(6,_rcon,(double)(-1),_rmult); }
;
rbe : rexpr EQUAL rexpr
{ bundle(1,_req); }
| rexpr NEQ rexpr
{ bundle(1,_rneq); }
| rexpr LE rexpr
{ bundle(1,_rleq); }
| rexpr LT rexpr
{ bundle(1,_rlt); }
| rexpr GE rexpr
{ bundle(1,_rgeq); }
| rexpr GT rexpr
{ bundle(1,_rgt); }
;
bexpr : sbe
| rbe
| NOT bexpr %prec UNARY
{ bundle(1,_not); }
| bexpr OR bexpr
{ bundle(1,_or); }
| bexpr AND bexpr
{ bundle(1,_and); }
| '(' bexpr ')'
;
%%
main()
{
rdlin(bsin);
return(yyparse());
}
yyerror(s)
char *s;
{
fprintf(stderr,"%s\n",s);
}
lpush(stack,val) struct stk *stack; int val;
{
stack->stack[stack->stkp++] = val;
}
int ltop(stack) struct stk *stack;
{
return(stack->stack[stack->stkp-1]);
}
int lpop(stack) struct stk *stack;
{
return(stack->stack[--stack->stkp]);
}
/* bundle() -- append argument list to l[]. Idea tooken from bc.y.
*
* Usage: bundle(cnt,arg,arg,...,arg)
*
* The "arg"'s can be anything. "cnt" is a count of the number of integers
* it would take to hold all the args.
*
* e.g. bundle(4,(double)a); is the correct count for a.
*
* ******* NOTE *******
*
* This routine is machine dependant. It depends on the way arguments are
* passed on the stack on the PDP-11 machines. It may not work elsewhere.
*/
bundle(a)
int a;
{
register int *p;
register int sz;
p = &a;
sz = *p++;
while(sz-- > 0)
l[lp++] = *p++;
}
SHAR_EOF
if test 8891 -ne "`wc -c < 'newbs/bsgram.y'`"
then
echo shar: error transmitting "'newbs/bsgram.y'" '(should have been 8891 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bslash.c'" '(567 characters)'
if test -f 'newbs/bslash.c'
then
echo shar: will not over-write existing file "'newbs/bslash.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bslash.c'
/* bslash() -- have seen '\', use input() to say what is actually wanted.
*/
char bslash()
{
char text[8];
register char *s,c;
int v;
c=input();
if(c == 'n') c='\n';
else if(c == 't') c='\t';
else if(c == 'b') c='\b';
else if(c == 'r') c='\r';
else if(c == 'f') c='\f';
else if(c>='0' && c<='7') { /* octal digit string */
s = &text[0];
*s++ = c;
c=input();
while(c>='0' && c<='7') {
*s++ = c;
c=input();
}
*s++ = '\0';
sscanf(text,"%o",&v);
c = (char) v;
}
else if(c=='\n') rdlin(bsin);
return(c);
}
SHAR_EOF
if test 567 -ne "`wc -c < 'newbs/bslash.c'`"
then
echo shar: error transmitting "'newbs/bslash.c'" '(should have been 567 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/bslib.c'" '(1553 characters)'
if test -f 'newbs/bslib.c'
then
echo shar: will not over-write existing file "'newbs/bslib.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/bslib.c'
/* bslib.c -- subroutine library, routines useful anywhere.
*/
#include "bsdefs.h"
XFILE *bsin = stdin;
/* blcpy -- copies a block of memory (l bytes) from s to d.
*/
blcpy(d,s,l)
char *d,*s;
int l;
{
for(; l >= 0; (l--)) *(d++) = *(s++);
}
/* Input routines. These routines buffer input a line at a time into
* ibuf. Unputted input goes to pbbuf, and gets read before things in
* ibuf, if anything in pbbuf.
*/
char pbbuf[CSTKSIZ],ibuf[BFSIZ];
int iptr = -1;
int pbptr = -1;
char input()
{
if(pbptr > -1)
return(pbbuf[pbptr--]);
else {
if(ibuf[iptr] == '\0') rdlin(bsin);
if(ibuf[iptr]!='\0' && !feof(bsin))
return(ibuf[iptr++]);
else
return(0);
}
}
rdlin(f) FILE *f;
{
char c;
iptr = 0;
for(c=fgetc(f); c!='\n' && c!=EOF; c=fgetc(f)) ibuf[iptr++] = c;
ibuf[iptr++] = c;
ibuf[iptr++] = '\0';
iptr = 0;
}
unput(c) char c;
{ pbbuf[++pbptr] = c; }
/* myalloc() -- allocate, checking for out of memory.
*/
char *myalloc(nb)
int nb;
{
char *rval;
rval = malloc(nb);
/*
printf("myalloc:tos:%o,rv:%o,nb:%d,e:%o\n",&rval,rval,nb,sbrk(0));
*/
if(rval == 0) {
fprintf(stderr,"myalloc: out of memory\n");
exit(1);
}
return(rval);
}
/* Stack routines. Very simple. */
union value stack[STKSIZ];
int stackp = -1;
push(i) union value i;
{
stack[++stackp] = i;
}
union value pop()
{
return(stack[stackp--]);
}
/* Mark stack. Also very simple. */
int mstack[5];
int mstkp = -1;
mpush()
{ mstack[++mstkp] = stackp; }
mpop()
{ stackp = mstack[mstkp--]; }
SHAR_EOF
if test 1553 -ne "`wc -c < 'newbs/bslib.c'`"
then
echo shar: error transmitting "'newbs/bslib.c'" '(should have been 1553 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/getplace.c'" '(488 characters)'
if test -f 'newbs/getplace.c'
then
echo shar: will not over-write existing file "'newbs/getplace.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/getplace.c'
/* getplace() -- get a pointer to place of value for vlist entry on top of stack
* For arrays, getplace() expects the indexes to be on the stack as well.
* The parser should properly arrange for this to happen.
*/
union value *getplace(dp)
struct dictnode *dp;
{
int qual;
union value ind,*place;
qual = dp->type_of_value&T_QMASK;
if(qual == Q_ARY) {
ind = pop();
mpop();
place = & dp->val.arval[ind.ival+2];
}
else
place = & dp->val;
return(place);
}
SHAR_EOF
if test 488 -ne "`wc -c < 'newbs/getplace.c'`"
then
echo shar: error transmitting "'newbs/getplace.c'" '(should have been 488 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/gvadr.c'" '(911 characters)'
if test -f 'newbs/gvadr.c'
then
echo shar: will not over-write existing file "'newbs/gvadr.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/gvadr.c'
/* gvadr() -- Get variable address from vlist, with type checking.
* This routine allows numerous copies of same name as long as
* all copies have different types. Probably doesnt matter since
* the parser does the type checking.
*/
struct dictnode *gvadr(s,ty)
char *s;
int ty;
{
register int i;
register int qual; /* type qualifier */
/* Inefficient */
for(i=0; vlist[i].name!=0 && i<VLSIZ; i++)
if(vlist[i].type_of_value==ty && strcmp(s,vlist[i].name)==0)
/* match found */
break;
if(i >= VLSIZ) {
fprintf(stderr,"gvadr: out of room in variable list for %s\n",s);
exit(1);
}
/* not on list, enter it */
if(vlist[i].name == 0) {
vlist[i].name = myalloc(strlen(s)+1);
strcpy(vlist[i].name,s);
vlist[i].val.rval = 0;
vlist[i].type_of_value = ty;
if(ty&T_QMASK == Q_ARY)
vlist[i].val.arval = myalloc(13*sizeof(union value));
}
return(&vlist[i]);
}
SHAR_EOF
if test 911 -ne "`wc -c < 'newbs/gvadr.c'`"
then
echo shar: error transmitting "'newbs/gvadr.c'" '(should have been 911 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/makefile'" '(193 characters)'
if test -f 'newbs/makefile'
then
echo shar: will not over-write existing file "'newbs/makefile'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/makefile'
operat2.o: mkop.sh op rop sop
mkop.sh >operat2.c
cc -c operat2.c
rm operat2.c
: done operat2.o
op: mkop.c
cc mkop.c -o op
rop: mkrbop.c
cc mkrbop.c -o rop
sop: mksop.c
cc mksop.c -o sop
SHAR_EOF
if test 193 -ne "`wc -c < 'newbs/makefile'`"
then
echo shar: error transmitting "'newbs/makefile'" '(should have been 193 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/makefile.old'" '(661 characters)'
if test -f 'newbs/makefile.old'
then
echo shar: will not over-write existing file "'newbs/makefile.old'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/makefile.old'
OFILES = lex.o bsint.o action.o operat.o bslib.o errors.o
PRSO= bsgram.o lex.o bslib.o
INTO= bsint.o action.o operat2.o operat.o bslib.o errors.o
prs: ${PRSO}
cc -s ${PRSO} -o prs
bsgram.o: bsgram.c bsdefs.h
cc -c bsgram.c
bsgram.c: bsgram.y
yacc -d bsgram.y
mv y.tab.c bsgram.c
mv y.tab.h bstokens.h
int: ${INTO}
cc ${INTO} -o int
${OFILES}: bsdefs.h
operat2.o: mkop.sh op rop sop
mkop.sh >operat2.c
cc -c operat2.c
rm operat2.c
: done operat2.o
op: mkop.c
cc mkop.c -o op
rop: mkrbop.c
cc mkrbop.c -o rop
sop: mksop.c
cc mksop.c -o sop
pr:
pr bsgram.y lex.c bsdefs.h bslib.c bsint.c action.c operat.c mkop.c mkrbop.c mksop.c errors.c | lpr
SHAR_EOF
if test 661 -ne "`wc -c < 'newbs/makefile.old'`"
then
echo shar: error transmitting "'newbs/makefile.old'" '(should have been 661 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/mkop.c'" '(1030 characters)'
if test -f 'newbs/mkop.c'
then
echo shar: will not over-write existing file "'newbs/mkop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mkop.c'
/* mkop.c -- make operator function for bs.
*
* USAGE: op name type oper tag
*
* where: name: name of function generated.
* type: data type of operation.
* oper: operator for operation.
* tag: structure tag name.
*
* This will only work with T_INT and T_DBL operators, T_CHR operations
* do not boil down to a simple operation.
*/
#include <stdio.h>
main(argc,argv)
char **argv;
int argc;
{
char *name,*type,*oper,*tag;
if(argc != 5) {
fprintf(stderr,"arg count\n");
exit(1);
}
name = argv[1]; type = argv[2]; oper = argv[3]; tag = argv[4];
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_READ){ dtype=T_%s; goto EXEC;}\n",type);
printf(" if((status&XMODE) == M_EXECUTE) {\n");
printf("EXEC:\n");
printf(" rg2 = pop();\n");
printf(" rg1 = pop();\n");
printf(" result.%s = rg1.%s %s rg2.%s;\n",tag,tag,oper,tag);
printf(" push(result);\n");
printf(" }\n");
printf(" return(p);\n");
printf("}\n");
}
SHAR_EOF
if test 1030 -ne "`wc -c < 'newbs/mkop.c'`"
then
echo shar: error transmitting "'newbs/mkop.c'" '(should have been 1030 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/mkop.sh'" '(482 characters)'
if test -f 'newbs/mkop.sh'
then
echo shar: will not over-write existing file "'newbs/mkop.sh'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mkop.sh'
echo "/* operat2.c -- more operators for bs. the ones that are all alike."
echo " */"
echo ""
echo "#include \"bsdefs.h\""
echo ""
op "radd" "DBL" "+" "rval"
op "rsub" "DBL" "-" "rval"
op "rmult" "DBL" "*" "rval"
op "rdiv" "DBL" "/" "rval"
rop "req" "=="
sop "seq" "=="
rop "rneq" "!="
sop "sneq" "!="
rop "rleq" "<="
sop "sleq" "<="
rop "rlt" "<"
sop "slt" "<"
rop "rgeq" ">="
sop "sgeq" ">="
rop "rgt" ">"
sop "sgt" ">"
op "or" "INT" "||" "ival"
op "and" "INT" "&&" "ival"
SHAR_EOF
if test 482 -ne "`wc -c < 'newbs/mkop.sh'`"
then
echo shar: error transmitting "'newbs/mkop.sh'" '(should have been 482 characters)'
fi
chmod +x 'newbs/mkop.sh'
fi # end of overwriting check
echo shar: extracting "'newbs/mksop.c'" '(725 characters)'
if test -f 'newbs/mksop.c'
then
echo shar: will not over-write existing file "'newbs/mksop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/mksop.c'
/* mksop.c -- make string comparator functions for bs.
*
* 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.sval = strcmp(rg1.sval,rg2.sval) %s 0;\n",oper);
printf(" push(result);\n");
printf(" }\n");
printf(" return(p);\n");
printf("}\n");
}
SHAR_EOF
if test 725 -ne "`wc -c < 'newbs/mksop.c'`"
then
echo shar: error transmitting "'newbs/mksop.c'" '(should have been 725 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/num_ins.c'" '(3393 characters)'
if test -f 'newbs/num_ins.c'
then
echo shar: will not over-write existing file "'newbs/num_ins.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/num_ins.c'
/* int_in() -- tokenizer routine for inputting a number.
* int_in() returns a pointer to a static data area. This area gets
* overwritten with each call to int_in so use the data before calling
* int_in() again.
*/
char * int_in()
{
register char c,*s;
static char text[20];
s = &text[0];
/* beginning state, skip junk until either '-' or ['0'-'9'] comes along */
l1: c=input();
if(c>='0' && c<='9') goto l3;
else if(c == '-') goto l2;
else {
if(c=='\n' || c=='\0') rdlin(bsin);
goto l1;
}
/* skipped junk, seen '-', gather it and make sure next char is a digit */
l2: *s++ = c;
c=input();
if(c==' ' || c=='\t') goto l2; /* allow white between sign and digit */
else if(c>='0' && c<='9') goto l3;
else { /* seen something not allowed. */
s = &text[0];
printf("\n\007??");
goto l1; /* restart machine */
}
/* skipped junk, seen a digit, gather until a non-digit appears */
l3: *s++ = c;
c=input();
if(c>='0' && c<='9') goto l3;
else {
/* have reached successful conclusion to machine. */
unput(c);
*s++ = '\0';
return(text);
}
}
/* real_in() -- read in a floating point number using input().
*
* real_in() returns a pointer to a static data area. This data area
* gets overwritten with each call to real_in(), so use it quickly.
*/
char *real_in()
{
register char *s,c;
static char bf[30];
s = &bf[0];
/* starting state. loops back until something interesting seen */
state1: c=input();
if(c == '-') goto state3;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else {
if(c == '\0') return(0);
/* else */
if(c == '\n') rdlin(bsin);
goto state1;
}
/* seen ([sign] dig). loop back for digs, looking for (.|e|E) */
state2: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state2;
else if(c=='e' || c=='E') goto state6;
else if(c == '.') goto state4;
else goto state9; /* done */
/* seen (sign). looking for (dig). ignore whitespace. */
state3: *s++ = c;
state3_a: c=input();
if(c==' ' || c=='\t') goto state3_a;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else goto state10; /* error, had a sign so we have to have digs. */
/* seen ([sign] digs '.'). looking for digs. done on anything else */
state4: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state5;
else goto state9; /* done */
/* seen ([sign] digs '.' dig). looking for (dig|e|E). done on anything else */
state5: *s++ = c;
c=input();
if(c=='e' || c=='E') goto state6;
else if(c>='0' && c<='9') goto state5;
else goto state9;
/* seen ([sign] digs '.' digs (e|E)). looking for sign or digs, else error. */
state6: *s++ = c;
c=input();
if(c=='+' || c=='-') goto state7;
else if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen ([sign] digs '.' digs (e|E) sign). looking for digs, else error. */
state7: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen ([sign] digs '.' digs (e|E) [sign] dig). looking for digs. */
state8: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state9; /* done */
/* seen a complete number. machine successfully completed. whew! */
state9: unput(c); /* might want that later */
*s++ = '\0';
return(bf);
/* Uh oh. An error. Print an error and restart. */
state10: printf("\n\007??");
s = &bf[0];
goto state1;
}
SHAR_EOF
if test 3393 -ne "`wc -c < 'newbs/num_ins.c'`"
then
echo shar: error transmitting "'newbs/num_ins.c'" '(should have been 3393 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/op2.c'" '(4171 characters)'
if test -f 'newbs/op2.c'
then
echo shar: will not over-write existing file "'newbs/op2.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/op2.c'
/* operat2.c -- more operators for bs. the ones that are all alike.
*/
#include "bsdefs.h"
_radd(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval + rg2.rval;
push(result);
}
return(p);
}
_rsub(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval - rg2.rval;
push(result);
}
return(p);
}
_rmult(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval * rg2.rval;
push(result);
}
return(p);
}
_rdiv(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_DBL; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.rval = rg1.rval / rg2.rval;
push(result);
}
return(p);
}
_req(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval == rg2.rval;
push(result);
}
return(p);
}
_seq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) == 0;
push(result);
}
return(p);
}
_rneq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval != rg2.rval;
push(result);
}
return(p);
}
_sneq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) != 0;
push(result);
}
return(p);
}
_rleq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval <= rg2.rval;
push(result);
}
return(p);
}
_sleq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) <= 0;
push(result);
}
return(p);
}
_rlt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval < rg2.rval;
push(result);
}
return(p);
}
_slt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) < 0;
push(result);
}
return(p);
}
_rgeq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval >= rg2.rval;
push(result);
}
return(p);
}
_sgeq(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) >= 0;
push(result);
}
return(p);
}
_rgt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.ival = rg1.rval > rg2.rval;
push(result);
}
return(p);
}
_sgt(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE) == M_EXECUTE) {
rg2 = pop();
rg1 = pop();
result.sval = strcmp(rg1.sval,rg2.sval) > 0;
push(result);
}
return(p);
}
_or(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_INT; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.ival = rg1.ival || rg2.ival;
push(result);
}
return(p);
}
_and(l,p)
int (*l[])(),p;
{
union value rg1,rg2,result;
if((status&XMODE)==M_READ){ dtype=T_INT; goto EXEC;}
if((status&XMODE) == M_EXECUTE) {
EXEC:
rg2 = pop();
rg1 = pop();
result.ival = rg1.ival && rg2.ival;
push(result);
}
return(p);
}
SHAR_EOF
if test 4171 -ne "`wc -c < 'newbs/op2.c'`"
then
echo shar: error transmitting "'newbs/op2.c'" '(should have been 4171 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/operat.c'" '(8663 characters)'
if test -f 'newbs/operat.c'
then
echo shar: will not over-write existing file "'newbs/operat.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/operat.c'
/* 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;
if((status&XMODE) == M_FIXUP) return(p);
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
_scolon(l,p) int(*l[])(),p;
{
union value s1,s2,s3;
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
/* last of binary operators */
/* ---And now for something completely different: a Unary Operator.
*
* 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];
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
_rtoa(l,p)
int (*l[])(),p;
{
union value val;
char s2[30];
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
_itor(l,p)
int (*l[])(),p;
{
union value v1,v2;
if((status&XMODE) == M_READ) { dtype = T_DBL; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
v1 = pop();
v2.rval = (double)v1.ival;
push(v2);
}
return(p);
}
_rtoi(l,p)
int (*l[])(),p;
{
union value v1,v2;
if((status&XMODE) == M_READ) { dtype = T_INT; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
v1 = pop();
v2.ival = (int)v1.rval;
push(v2);
}
return(p);
}
/* 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;
if((status&XMODE) == M_FIXUP) ++p;
if((status&XMODE) == M_READ) { dtype = T_CHR; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
/* 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;
if((status&XMODE) == M_FIXUP) return(p+(sizeof(long)/sizeof(int)));
if((status&XMODE) == M_READ) { dtype = T_INT; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
_rcon(l,p)
int (*l[])(),p;
{
union doni v;
int i;
union value val;
if((status&XMODE) == M_FIXUP) return(p+(sizeof(double)/sizeof(int)));
if((status&XMODE) == M_READ) { dtype = T_DBL; goto EXEC; }
if((status&XMODE) = M_EXECUTE) {
EXEC:
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);
}
/* 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;
if((status&XMODE) == M_READ) { dtype = l[p]; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
return(p+1);
}
/* 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;
if((status&XMODE) == M_READ) { dtype = l[p]; goto EXEC; }
if((status&XMODE) == M_EXECUTE) {
EXEC:
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);
}
return(p+1);
}
/* 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;
if((status&XMODE) == 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);
}
if((status&XMODE) == 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 /* ty == T_CHR */
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);
}
if((status&XMODE) == 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) {
if(dtype == T_DBL) {
push(val); _rtoi(l,p); val = pop();
}
place.plval->ival = val.ival;
}
else if(qual == T_DBL) {
if(dtype == T_INT) {
push(val); _itor(l,p); val = pop();
}
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);
return(p+1);
}
return(p+1);
}
SHAR_EOF
if test 8663 -ne "`wc -c < 'newbs/operat.c'`"
then
echo shar: error transmitting "'newbs/operat.c'" '(should have been 8663 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'newbs/scon_in.c'" '(1454 characters)'
if test -f 'newbs/scon_in.c'
then
echo shar: will not over-write existing file "'newbs/scon_in.c'"
else
sed 's/^X//' << \SHAR_EOF > 'newbs/scon_in.c'
/* scon_in() -- read in a string constant using input.
* Format of an scon is either a quoted string, or a sequence
* of characters ended with a seperator (' ', '\t' or '\n' or ',').
*
* In either mode, you can get funny characters into the string by
* "quoting" them with a '\'.
*
* scon_in() uses myalloc() to create space to store the string in.
*/
char *scon_in()
{
register char c,*s;
static char text [80];
s = &text[0];
/* beginning state, skip seperators until something interesting comes along */
l1: c=input();
if(c == '"') goto l2;
else if(c=='\n' || c=='\0') {
rdlin(bsin);
goto l1;
}
else if(c==' ' || c=='\t' || c==',') goto l1;
else goto l3;
/* have skipped unwanted material, seen a '"', read in a quoted string */
l2: c=input();
if(c == '\n') {
fprintf(stderr,"scon_in: unterminated string\n");
exit(1);
}
else if(c == '\\') { *s++ = bslash(bsin); goto l2; }
else if(c == '"')
if((c=input()) == '"') {
*s++ = '"';
goto l2;
}
else goto done;
else { *s++ = c; goto l2; }
/* skipped unwanted, seen something interesting, not '"', gather until sep */
l3: *s++ = c;
c=input();
if(c == '\\') { c = bslash(bsin); goto l3; }
else if(c==' ' || c=='\t' || c==',' || c=='\n') goto done;
else goto l3;
/* final state (if machine finished ok.) */
done: unput(c);
*s++ = '\0';
s=myalloc(strlen(text)+1);
strcpy(s,text);
return(s);
}
SHAR_EOF
if test 1454 -ne "`wc -c < 'newbs/scon_in.c'`"
then
echo shar: error transmitting "'newbs/scon_in.c'" '(should have been 1454 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0sources-request@genrad.UUCP (07/31/85)
Mod.sources: Volume 2, Issue 25
Submitted by: ukma!david (David Herron)
#! /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:
# bs2/action.c
# bs2/bsdefs.h
# bs2/bsgram.y
# bs2/bsgram.y.orig
# bs2/bsint.c
# bs2/bslib.c
# bs2/errors.c
# bs2/operat.c
# This archive created: Tue Jul 30 13:03:04 1985
export PATH; PATH=/bin:$PATH
if test ! -d 'bs2'
then
echo shar: creating directory "'bs2'"
mkdir 'bs2'
fi
echo shar: extracting "'bs2/action.c'" '(14073 characters)'
if test -f 'bs2/action.c'
then
echo shar: will not over-write existing file "'bs2/action.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/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;
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) {
case M_COMPILE: l[p] = 0;
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) {
case M_COMPILE:
s=gtok();
vp=gvadr(s,T_LBL);
l[p++] = vp;
return(p);
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) {
case M_COMPILE:
s=gtok();
vp=gvadr(s,T_LBL);
l[p++] = vp;
return(p);
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) {
case M_COMPILE:
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) {
case M_COMPILE:
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) {
case M_COMPILE:
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) {
case M_COMPILE:
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) {
case M_COMPILE:
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) {
case M_COMPILE:
l[p++] = 0;
return(p);
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) {
case M_COMPILE:
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) {
case M_COMPILE:
l[p++] = atoi(int_in());
return(p);
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) {
case M_COMPILE:
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);
case M_COMPILE: return(p);
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 14073 -ne "`wc -c < 'bs2/action.c'`"
then
echo shar: error transmitting "'bs2/action.c'" '(should have been 14073 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/bsdefs.h'" '(4472 characters)'
if test -f 'bs2/bsdefs.h'
then
echo shar: will not over-write existing file "'bs2/bsdefs.h'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/bsdefs.h'
/* bsdefs.h -- definition file for bs.
*/
#include <stdio.h>
#include <ctype.h>
/* 'Machine' status */
extern int status;
#define M_COMPILE (1<<0)
#define M_EXECUTE (1<<1)
#define M_INPUT (1<<2)
#define M_FIXUP (1<<3)
#define M_READ (1<<4)
#define XMODE (M_COMPILE|M_EXECUTE|M_INPUT|M_FIXUP|M_READ)
/* line table. */
#define MAXLN ((unsigned)65535)
#define NUMLINES 1000
#define LASTLINE (&llist[NUMLINES-1])
extern int (*_null[])();
struct line {
unsigned num;
int (**code)();
char *text;
};
extern struct line llist[];
extern struct line *lastline;
extern struct line *Thisline;
extern int Thisp;
/* Variable types */
#define Q_NRM 0 /* nice, ordinary variable */
#define Q_ARY 1 /* array */
#define Q_BF 2 /* builtin-function */
#define Q_UFL 3 /* long user function */
#define Q_UFS 4 /* short user function */
/* in type part, a zero value is an undefined type. */
#define T_INT (1<<6)
#define T_CHR (2<<6)
#define T_DBL (3<<6)
#define T_LBL (4<<6)
#define T_QMASK 037 /* lower 5 bits for type qualifier */
#define T_TMASK (T_INT|T_CHR|T_DBL|T_LBL)
/* variable table */
#define VLSIZ 150
struct label {
char *name;
int (**codelist)(); /* what line it is on */
int place; /* where on the line it is. */
};
/* For arrays, storage of them is defined as follows:
*
* 1st item: number of dimensions in array <NDIMS>.
* next <NDIMS> items: size of each dimension.
* rest of items: the actual values.
*
* Until we can support varrying sized arrays this is the setup:
*
* 1,10,x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10
*
* for a total size of 13 items.
*/
union value {
long ival; /* T_INT */
double rval; /* T_DBL */
char *sval; /* T_CHR */
struct label lval; /* T_LBL */
union value *arval; /* any+Q_ARY */
struct dictnode *vpval; /* for use when pushing variable pointers */
union value *plval; /* for use when pushing pointers to a value */
};
struct dictnode { /* format of vlist entry */
char *name;
int type_of_value;
union value val;
};
extern struct dictnode vlist[];
/* '_' Function table */
extern
_print(), _goto(), _if(), _else(), _for(),
_next(), _read(), _data(), _dsep(), _spop(),
_pop(), _stop(), _end(), _dlabel(), _rlabel(),
_contin(), _leave(), _enter(), _exitlp(),
_iadd(), _isub(), _imult(), _idiv(), _imod(), _comma(),
_radd(), _rsub(), _rmult(), _rdiv(),
_scolon(), _gosub(), _return(), _not(),
_ieq(), _req(), _seq(),
_ineq(), _rneq(), _sneq(),
_ileq(), _rleq(), _sleq(),
_ilt(), _rlt(), _slt(),
_igeq(), _rgeq(), _sgeq(),
_igt(), _rgt(), _sgt(), _or(), _and(),
_itoa(), _rtoa(), _itor(), _rtoi(),
_pushstate(), _popstate(),
_scon(), _rcon(), _icon(), _val(), _store(), _var();
/* interpretor operator table */
struct wlnode {
char *name;
int (*funct)();
};
extern struct wlnode wlist[];
/* Data table. Array of pointers into llist. Each is a line wich has data. */
#define DLSIZ 100
extern struct line *dlist[]; /* actual table, number of elems. is DLSIZ */
extern int dlp; /* index into dlist for current line of data */
extern int dlindx; /* index into current line for current data item. */
extern int dtype; /* in M_READ, operators set this to the type of
* their operation. When the expression is done
* executing, this variable will indicate its type.
*/
/* error routines */
extern int ULerror();
extern int STerror();
extern int FNerror();
extern int ODerror();
extern int BDerror();
extern int VTerror();
/* unions for storing data types in the code list */
union doni {
double d_in_doni;
int i_in_doni[sizeof(double)/sizeof(int)];
};
union loni {
long l_in_loni;
int i_in_loni[sizeof(long)/sizeof(int)];
};
union voni {
union value v_in_voni;
int i_in_voni[sizeof(union value)/sizeof(int)];
};
/* miscellaneous definitions. */
#define STKSIZ 500
extern union value stack[];
extern int stackp;
extern int push();
extern union value pop();
#define CSTKSIZ 5
#define BFSIZ 200 /* input buffer */
extern char pbbuf[]; /* unput() buffer */
extern char ibuf[];
extern int iptr,pbptr;
extern char input();
extern rdlin(),unput();
extern blcpy();
extern char bslash();
extern char *scon_in();
extern int num_in();
extern char *myalloc();
extern union value *getplace();
extern struct line *gllentry();
extern FILE *bsin;
extern int dbg; /* debugging flag. */
extern long atol();
extern double atof();
SHAR_EOF
if test 4472 -ne "`wc -c < 'bs2/bsdefs.h'`"
then
echo shar: error transmitting "'bs2/bsdefs.h'" '(should have been 4472 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/bsgram.y'" '(6761 characters)'
if test -f 'bs2/bsgram.y'
then
echo shar: will not over-write existing file "'bs2/bsgram.y'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/bsgram.y'
/* bsgram.y -- grammer specification for bs.
*/
%{
#include "bsdefs.h"
char *p; /* the generic pointer */
int i; /* the generic counter */
struct stk {
int stack[40];
int stkp;
};
struct stk ifstk,whstk,forstk,repstk,lpstk;
int gomax=0; int ifmax=0; int whmax=0; int formax=0; int repmax=0; int lpmax=0;
extern char *yytext;
extern char *bsyysval;
extern int yyleng;
%}
%term EQUAL NEQ LE LT GE WHILE
%term GT OR AND NOT RET REPEAT
%term IF THEN ELSE GOTO GOSUB UNTIL
%term STOP END INTEGER REAL SCONST ELIHW
%term LET SWORD PRINT INPUT DATA CFOR
%term FOR TO STEP READ WRITE NEXT
%term DEFINE LFUN SFUN FDEF SYMBOL DIM
%term VALUE IWORD RWORD ROFC LOOP EXITIF
%term ITOR RTOI ITOA RTOA LEAVE CONTINUE
%term POOL
%left ',' ';'
%right '='
%nonassoc OR AND
%nonassoc LE LT GE GT EQUAL NEQ
%left '+' '-'
%left '*' '/' '%'
%left UNARY
%left '('
%start lines
%%
lines : /* empty */
| lines line
;
line : lnum stat '\n'
{ printf("\n"); }
| '\n'
;
lnum : INTEGER
{ printf(" line %s ",$1); }
;
stat : LET let_xpr
| let_xpr
| PRINT pe
{ printf(" print "); }
| GOTO INTEGER
{ printf(" rlabel LN%s goto ",$2); }
| GOSUB INTEGER
{ printf(" rlabel LN%s gosub ",$2); }
| LEAVE
{ printf(" leave "); }
| CONTINUE
{ printf(" contin "); }
| RET
{ printf(" return "); }
| IF bexpr
{
lpush(&ifstk,ifmax);
printf(" rlabel IF%d if ",ifmax);
ifmax += 2;
}
THEN stat
{
i = ltop(&ifstk);
printf(" rlabel IF%d goto ",i+1);
}
if_else
| INPUT
{ printf(" pushstate %d ",M_INPUT); }
var_lst
{ printf(" popstate "); }
| STOP
{ printf(" stop "); }
| END
{ printf(" end "); }
| FOR ivar '=' rexpr TO rexpr for_step
{
lpush(&forstk,formax);
printf(" rlabel FOR%d rlabel FOR%d enter",
formax+2,formax+1);
printf(" icon 0 rlabel FOR%d dlabel FOR%d for ",
formax+1,formax);
formax += 3;
}
| NEXT
{
i = ltop(&forstk);
printf(" dlabel FOR%d ",i+2);
}
ivar
{
i = lpop(&forstk);
printf(" next rlabel FOR%d goto dlabel FOR%d ",
i,i+1);
printf("exitlp ");
}
| READ { printf(" pushstate %d ",M_READ); } var_lst
{ printf(" popstate "); }
| DATA { printf(" data "); } data_lst
| LOOP
{
lpush(&lpstk,lpmax);
printf(" rlabel LP%d rlabel LP%d enter",
lpmax+2,lpmax+1);
printf(" dlabel LP%d ",lpmax);
lpmax += 3;
}
| EXITIF bexpr
{
i = ltop(&lpstk);
printf(" not rlabel LP%d if ",i+1);
}
| POOL
{
i = lpop(&lpstk);
printf(" dlabel LP%d rlabel LP%d goto",i+2,i);
printf(" dlabel LP%d exitlp ",i+1);
}
| WHILE
{
lpush(&whstk,whmax);
printf(" rlabel WH%d rlabel WH%d enter",
whmax+2,whmax+1);
printf(" dlabel WH%d ",whmax);
whmax += 3;
}
bexpr
{
i = ltop(&whstk);
printf(" rlabel WH%d if ",i+1);
}
| ELIHW
{
i = lpop(&whstk);
printf(" dlabel WH%d",i+2);
printf(" rlabel WH%d goto dlabel WH%d exitlp ",i,i+1);
}
| REPEAT
{
lpush(&repstk,repmax);
printf(" rlabel REP%d rlabel REP%d enter",
repmax+1,repmax+2);
printf(" dlabel REP%d ",repmax);
repmax += 3;
}
| UNTIL
{
i = ltop(&repstk);
printf(" dlabel REP%d ",i+1);
}
bexpr
{
i = lpop(&repstk);
printf(" not rlabel REP%d if",i);
printf(" dlabel REP%d exitlp ",i+2);
}
;
let_xpr : ivar '=' rexpr
{ printf(" rtoi store %d pop ",T_INT); }
| rvar '=' rexpr
{ printf(" store %d pop ",T_DBL); }
| svar '=' sexpr
{ printf(" store %d spop ",T_CHR); }
;
data_lst : rexpr
{ printf(" dsep "); }
| sexpr
{ printf(" dsep "); }
| data_lst ',' rexpr
{ printf(" dsep "); }
| data_lst ',' sexpr
{ printf(" dsep "); }
;
ind_lst : rexpr
| ind_lst ',' rexpr
;
for_step : /* empty */
{ printf(" icon 0 "); }
| STEP rexpr
;
if_else : /* empty */
{
i = lpop(&ifstk);
printf(" dlabel IF%d dlabel IF%d ",i,i+1);
}
| ELSE { i=ltop(&ifstk); printf(" dlabel IF%d ",i); } stat
{ i=lpop(&ifstk); printf(" dlabel IF%d ",i+1); }
;
pe : sexpr ','
{ printf(" scon \"\" , "); }
| sexpr ';'
| sexpr
{ printf(" scon \"\\n\" ; "); }
| /* empty */
{ printf(" scon \"\\n\" "); }
;
var_lst : ivar
| rvar
| svar
| var_lst ',' var_lst
;
sexpr : SCONST
{ printf(" scon \"%s\" ",$1); }
| svar
{ printf(" val %d ",T_CHR); }
| rexpr
{ printf(" rtoa "); }
| svar '=' sexpr
{ printf(" store %d ",T_CHR); }
| sexpr ';' sexpr
{ printf(" ; "); }
| sexpr '+' sexpr
{ printf(" ; "); }
| sexpr ',' sexpr
{ printf(" , "); }
| '(' sexpr ')'
;
sbe : sexpr EQUAL sexpr
{ printf(" s== "); }
| sexpr NEQ sexpr
{ printf(" s<> "); }
| sexpr LE sexpr
{ printf(" s<= "); }
| sexpr LT sexpr
{ printf(" s< "); }
| sexpr GE sexpr
{ printf(" s>= "); }
| sexpr GT sexpr
{ printf(" s> "); }
;
ivar : IWORD
{ printf(" var %d %s ",T_INT,$1); }
| IWORD '(' {printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_INT+Q_ARY,$1); }
;
rvar : RWORD
{ printf(" var %d %s ",T_DBL,$1); }
| RWORD '(' { printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_DBL+Q_ARY,$1); }
;
svar : SWORD
{ printf(" var %d %s ",T_CHR,$1); }
| SWORD '(' { printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_CHR+Q_ARY,$1); }
;
rexpr : rvar
{ printf(" val %d ",T_DBL); }
| REAL
{ printf(" rcon %s ",$1); }
| INTEGER
{ printf(" rcon %s ",$1); }
| ivar
{ printf(" val %ditor ",T_INT); }
| rvar '=' rexpr
{ printf(" store %d ",T_DBL); }
| '(' rexpr ')'
| rexpr '+' rexpr
{ printf(" r+ "); }
| rexpr '-' rexpr
{ printf(" r- "); }
| rexpr '*' rexpr
{ printf(" r* "); }
| rexpr '/' rexpr
{ printf(" r/ "); }
| '+' rexpr %prec UNARY
| '-' rexpr %prec UNARY
{ printf(" rcon -1 r* "); }
;
rbe : rexpr EQUAL rexpr
{ printf(" r== "); }
| rexpr NEQ rexpr
{ printf(" r<> "); }
| rexpr LE rexpr
{ printf(" r<= "); }
| rexpr LT rexpr
{ printf(" r< "); }
| rexpr GE rexpr
{ printf(" r>= "); }
| rexpr GT rexpr
{ printf(" r> "); }
;
bexpr : sbe
| rbe
| NOT bexpr %prec UNARY
{ printf(" not "); }
| bexpr OR bexpr
{ printf(" or "); }
| bexpr AND bexpr
{ printf(" and "); }
| '(' bexpr ')'
;
%%
main()
{
rdlin(bsin);
return(yyparse());
}
yyerror(s)
char *s;
{
fprintf(stderr,"%s\n",s);
}
lpush(stack,val) struct stk *stack; int val;
{ stack->stack[stack->stkp++] = val; }
int ltop(stack) struct stk *stack;
{ return(stack->stack[stack->stkp-1]); }
int lpop(stack) struct stk *stack;
{ return(stack->stack[--stack->stkp]); }
SHAR_EOF
if test 6761 -ne "`wc -c < 'bs2/bsgram.y'`"
then
echo shar: error transmitting "'bs2/bsgram.y'" '(should have been 6761 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/bsgram.y.orig'" '(7701 characters)'
if test -f 'bs2/bsgram.y.orig'
then
echo shar: will not over-write existing file "'bs2/bsgram.y.orig'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/bsgram.y.orig'
/* bsgram.y -- grammer specification for bs.
*/
%{
#include "bsdefs.h"
char *p; /* the generic pointer */
int i; /* the generic counter */
struct stk {
int stack[40];
int stkp;
};
struct stk ifstk,whstk,forstk,repstk,lpstk;
int gomax=0; int ifmax=0; int whmax=0; int formax=0; int repmax=0; int lpmax=0;
extern char *yytext;
extern char *bsyysval;
extern int yyleng;
%}
%term EQUAL NEQ LE LT GE WHILE
%term GT OR AND NOT RET REPEAT
%term IF THEN ELSE GOTO GOSUB UNTIL
%term STOP END INTEGER REAL SCONST ELIHW
%term LET SWORD PRINT INPUT DATA CFOR
%term FOR TO STEP READ WRITE NEXT
%term DEFINE LFUN SFUN FDEF SYMBOL DIM
%term VALUE IWORD RWORD ROFC LOOP EXITIF
%term ITOR RTOI ITOA RTOA LEAVE CONTINUE
%term POOL
%left ',' ';'
%right '='
%nonassoc OR AND
%nonassoc LE LT GE GT EQUAL NEQ
%left '+' '-'
%left '*' '/' '%'
%left UNARY
%left '('
%start lines
%%
lines : /* empty */
| lines line
;
line : lnum stat '\n'
{ printf("\n"); }
| '\n'
;
lnum : INTEGER
{ printf(" line %s ",$1); }
;
stat : LET let_xpr
| let_xpr
| PRINT pe
{ printf(" print "); }
| GOTO INTEGER
{ printf(" rlabel LN%s goto ",$2); }
| GOSUB INTEGER
{ printf(" rlabel LN%s gosub ",$2); }
| LEAVE
{ printf(" leave "); }
| CONTINUE
{ printf(" contin "); }
| RET
{ printf(" return "); }
| IF bexpr
{
lpush(&ifstk,ifmax);
printf(" rlabel IF%d if ",ifmax);
ifmax += 2;
}
THEN stat
{
i = ltop(&ifstk);
printf(" rlabel IF%d goto ",i+1);
}
if_else
| INPUT { printf(" pushstate %d ",M_INPUT); } var_lst
{ printf(" popstate "); }
| STOP
{ printf(" stop "); }
| END
{ printf(" end "); }
| FOR ivar '=' iexpr TO iexpr for_step
{
lpush(&forstk,formax);
printf(" rlabel FOR%d rlabel FOR%d enter",
formax+2,formax+1);
printf(" icon 0 rlabel FOR%d dlabel FOR%d for ",
formax+1,formax);
formax += 3;
}
| NEXT
{
i = ltop(&forstk);
printf(" dlabel FOR%d ",i+2);
}
ivar
{
i = lpop(&forstk);
printf(" next rlabel FOR%d goto dlabel FOR%d ",
i,i+1);
printf("exitlp ");
}
| READ { printf(" pushstate %d ",M_READ); } var_lst
{ printf(" popstate "); }
| DATA { printf(" data "); } data_lst
| LOOP
{
lpush(&lpstk,lpmax);
printf(" rlabel LP%d rlabel LP%d enter",
lpmax+2,lpmax+1);
printf(" dlabel LP%d ",lpmax);
lpmax += 3;
}
| EXITIF bexpr
{
i = ltop(&lpstk);
printf(" not rlabel LP%d if ",i+1);
}
| POOL
{
i = lpop(&lpstk);
printf(" dlabel LP%d rlabel LP%d goto",i+2,i);
printf(" dlabel LP%d exitlp ",i+1);
}
| WHILE
{
lpush(&whstk,whmax);
printf(" rlabel WH%d rlabel WH%d enter",
whmax+2,whmax+1);
printf(" dlabel WH%d ",whmax);
whmax += 3;
}
bexpr
{
i = ltop(&whstk);
printf(" rlabel WH%d if ",i+1);
}
| ELIHW
{
i = lpop(&whstk);
printf(" dlabel WH%d",i+2);
printf(" rlabel WH%d goto dlabel WH%d exitlp ",i,i+1);
}
| REPEAT
{
lpush(&repstk,repmax);
printf(" rlabel REP%d rlabel REP%d enter",
repmax+1,repmax+2);
printf(" dlabel REP%d ",repmax);
repmax += 3;
}
| UNTIL
{
i = ltop(&repstk);
printf(" dlabel REP%d ",i+1);
}
bexpr
{
i = lpop(&repstk);
printf(" not rlabel REP%d if",i);
printf(" dlabel REP%d exitlp ",i+2);
}
;
let_xpr : ivar '=' iexpr
{ printf(" store %d pop ",T_INT); }
| rvar '=' rexpr
{ printf(" store %d pop ",T_DBL); }
| svar '=' sexpr
{ printf(" store %d spop ",T_CHR); }
;
data_lst : iexpr
{ printf(" dsep "); }
| rexpr
{ printf(" dsep "); }
| sexpr
{ printf(" dsep "); }
| data_lst ',' iexpr
{ printf(" dsep "); }
| data_lst ',' rexpr
{ printf(" dsep "); }
| data_lst ',' sexpr
{ printf(" dsep "); }
;
ind_lst : iexpr
| ind_lst ',' iexpr
;
for_step : /* empty */
{ printf(" icon 0 "); }
| STEP iexpr
;
if_else : /* empty */
{
i = lpop(&ifstk);
printf(" dlabel IF%d dlabel IF%d ",i,i+1);
}
| ELSE { i=ltop(&ifstk); printf(" dlabel IF%d ",i); } stat
{ i=lpop(&ifstk); printf(" dlabel IF%d ",i+1); }
;
pe : sexpr ','
{ printf(" scon \"\" , "); }
| sexpr ';'
| sexpr
{ printf(" scon \"\\n\" ; "); }
| /* empty */
{ printf(" scon \"\\n\" "); }
;
var_lst : ivar
| rvar
| svar
| var_lst ',' var_lst
;
sexpr : SCONST
{ printf(" scon \"%s\" ",$1); }
| svar
{ printf(" val %d ",T_CHR); }
| iexpr
{ printf(" itoa "); }
| rexpr
{ printf(" rtoa "); }
| svar '=' sexpr
{ printf(" store %d ",T_CHR); }
| sexpr ';' sexpr
{ printf(" ; "); }
| sexpr '+' sexpr
{ printf(" ; "); }
| sexpr ',' sexpr
{ printf(" , "); }
| '(' sexpr ')'
;
sbe : sexpr EQUAL sexpr
{ printf(" s== "); }
| sexpr NEQ sexpr
{ printf(" s<> "); }
| sexpr LE sexpr
{ printf(" s<= "); }
| sexpr LT sexpr
{ printf(" s< "); }
| sexpr GE sexpr
{ printf(" s>= "); }
| sexpr GT sexpr
{ printf(" s> "); }
;
ivar : IWORD
{ printf(" var %d %s ",T_INT,$1); }
| IWORD '(' {printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_INT+Q_ARY,$1); }
;
rvar : RWORD
{ printf(" var %d %s ",T_DBL,$1); }
| RWORD '(' { printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_DBL+Q_ARY,$1); }
;
svar : SWORD
{ printf(" var %d %s ",T_CHR,$1); }
| SWORD '(' { printf(" pushstate %d ",M_EXECUTE); } ind_lst ')'
{ printf(" popstate var %d %s ",T_CHR+Q_ARY,$1); }
;
iexpr : ivar
{ printf(" val %d ",T_INT); }
| INTEGER
{ printf(" icon %s ",$1); }
| REAL
{ printf(" rcon %s rtoi ",$1); }
| ivar '=' iexpr
{ printf(" store %d ",T_INT); }
| RTOI '(' rexpr ')'
{ printf(" rtoi "); }
| '(' iexpr ')'
| iexpr '+' iexpr
{ printf(" i+ "); }
| iexpr '-' iexpr
{ printf(" i- "); }
| iexpr '*' iexpr
{ printf(" i* "); }
| iexpr '/' iexpr
{ printf(" i/ "); }
| iexpr '%' iexpr
{ printf(" i%% "); }
| '+' iexpr %prec UNARY
| '-' iexpr %prec UNARY
{ printf(" icon -1 i* "); }
;
ibe : iexpr EQUAL iexpr
{ printf(" i== "); }
| iexpr NEQ iexpr
{ printf(" i<> "); }
| iexpr LE iexpr
{ printf(" i<= "); }
| iexpr LT iexpr
{ printf(" i< "); }
| iexpr GE iexpr
{ printf(" i>= "); }
| iexpr GT iexpr
{ printf(" i> "); }
;
rexpr : rvar
{ printf(" val %d ",T_DBL); }
| REAL
{ printf(" rcon %s ",$1); }
| INTEGER
{ printf(" rcon %s ",$1); }
| rvar '=' rexpr
{ printf(" store %d ",T_DBL); }
| ITOR '(' iexpr ')'
{ printf(" itor "); }
| '(' rexpr ')'
| rexpr '+' rexpr
{ printf(" r+ "); }
| rexpr '-' rexpr
{ printf(" r- "); }
| rexpr '*' rexpr
{ printf(" r* "); }
| rexpr '/' rexpr
{ printf(" r/ "); }
| '+' rexpr %prec UNARY
| '-' rexpr %prec UNARY
{ printf(" rcon -1 r* "); }
;
rbe : rexpr EQUAL rexpr
{ printf(" r== "); }
| rexpr NEQ rexpr
{ printf(" r<> "); }
| rexpr LE rexpr
{ printf(" r<= "); }
| rexpr LT rexpr
{ printf(" r< "); }
| rexpr GE rexpr
{ printf(" r>= "); }
| rexpr GT rexpr
{ printf(" r> "); }
;
bexpr : sbe
| ibe
| rbe
| NOT bexpr %prec UNARY
{ printf(" not "); }
| bexpr OR bexpr
{ printf(" or "); }
| bexpr AND bexpr
{ printf(" and "); }
| '(' bexpr ')'
;
%%
main()
{
rdlin(bsin);
return(yyparse());
}
yyerror(s)
char *s;
{
fprintf(stderr,"%s\n",s);
}
lpush(stack,val) struct stk *stack; int val;
{ stack->stack[stack->stkp++] = val; }
int ltop(stack) struct stk *stack;
{ return(stack->stack[stack->stkp-1]); }
int lpop(stack) struct stk *stack;
{ return(stack->stack[--stack->stkp]); }
SHAR_EOF
if test 7701 -ne "`wc -c < 'bs2/bsgram.y.orig'`"
then
echo shar: error transmitting "'bs2/bsgram.y.orig'" '(should have been 7701 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/bsint.c'" '(12093 characters)'
if test -f 'bs2/bsint.c'
then
echo shar: will not over-write existing file "'bs2/bsint.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/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];
/* bslash() -- have seen '\', use input() to say what is actually wanted.
*/
char bslash()
{
char text[8];
register char *s,c;
int v;
c=input();
if(c == 'n') c='\n';
else if(c == 't') c='\t';
else if(c == 'b') c='\b';
else if(c == 'r') c='\r';
else if(c == 'f') c='\f';
else if(c>='0' && c<='7') { /* octal digit string */
s = &text[0];
*s++ = c;
c=input();
while(c>='0' && c<='7') {
*s++ = c;
c=input();
}
*s++ = '\0';
sscanf(text,"%o",&v);
c = (char) v;
}
else if(c=='\n') rdlin(bsin);
return(c);
}
/* scon_in() -- read in a string constant using input.
* Format of an scon is either a quoted string, or a sequence
* of characters ended with a seperator (' ', '\t' or '\n' or ',').
*
* In either mode, you can get funny characters into the string by
* "quoting" them with a '\'.
*
* scon_in() uses myalloc() to create space to store the string in.
*/
char *scon_in()
{
register char c,*s;
static char text [80];
s = &text[0];
/* beginning state, skip seperators until something interesting comes along */
l1: c=input();
if(c == '"') goto l2;
else if(c=='\n' || c=='\0') {
rdlin(bsin);
goto l1;
}
else if(c==' ' || c=='\t' || c==',') goto l1;
else goto l3;
/* have skipped unwanted material, seen a '"', read in a quoted string */
l2: c=input();
if(c == '\n') {
fprintf(stderr,"scon_in: unterminated string\n");
exit(1);
}
else if(c == '\\') { *s++ = bslash(bsin); goto l2; }
else if(c == '"')
if((c=input()) == '"') {
*s++ = '"';
goto l2;
}
else goto done;
else { *s++ = c; goto l2; }
/* skipped unwanted, seen something interesting, not '"', gather until sep */
l3: *s++ = c;
c=input();
if(c == '\\') { c = bslash(bsin); goto l3; }
else if(c==' ' || c=='\t' || c==',' || c=='\n') goto done;
else goto l3;
/* final state (if machine finished ok.) */
done: unput(c);
*s++ = '\0';
s=myalloc(strlen(text)+1);
strcpy(s,text);
return(s);
}
/* int_in() -- tokenizer routine for inputting a number.
* int_in() returns a pointer to a static data area. This area gets
* overwritten with each call to int_in so use the data before calling
* int_in() again.
*/
char * int_in()
{
register char c,*s;
static char text[20];
s = &text[0];
/* beginning state, skip junk until either '-' or ['0'-'9'] comes along */
l1: c=input();
if(c>='0' && c<='9') goto l3;
else if(c == '-') goto l2;
else {
if(c=='\n' || c=='\0') rdlin(bsin);
goto l1;
}
/* skipped junk, seen '-', gather it and make sure next char is a digit */
l2: *s++ = c;
c=input();
if(c==' ' || c=='\t') goto l2; /* allow white between sign and digit */
else if(c>='0' && c<='9') goto l3;
else { /* seen something not allowed. */
s = &text[0];
printf("\n\007??");
goto l1; /* restart machine */
}
/* skipped junk, seen a digit, gather until a non-digit appears */
l3: *s++ = c;
c=input();
if(c>='0' && c<='9') goto l3;
else {
/* have reached successful conclusion to machine. */
unput(c);
*s++ = '\0';
return(text);
}
}
/* real_in() -- read in a floating point number using input().
*
* real_in() returns a pointer to a static data area. This data area
* gets overwritten with each call to real_in(), so use it quickly.
*/
char *real_in()
{
register char *s,c;
static char bf[30];
s = &bf[0];
/* starting state. loops back until something interesting seen */
state1: c=input();
if(c == '-') goto state3;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else {
if(c=='\n' || c=='\0') rdlin(bsin);
goto state1;
}
/* seen a digit. gather all digits following. */
state2: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else goto state9; /* done */
/* seen a sign character before start of number. loop back for whitespace. */
state3: *s++ = c;
state3_a: c=input();
if(c==' ' || c=='\t') goto state3_a;
else if(c>='0' && c<='9') goto state2;
else if(c == '.') goto state4;
else goto state10; /* error, had a sign so we have to have digs. */
/* seen digit(s) and a decimal point. looking for more digs or ('e'|'E') */
state4: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state5;
else if(c=='e' || c=='E') goto state6;
else goto state9; /* done */
/* seen (digs '.' dig). look for more digs or ('e'|'E'). */
state5: *s++ = c;
c=input();
if(c=='e' || c=='E') goto state6;
else if(c>='0' && c<='9') goto state5;
else goto state9;
/* seen (digs '.' digs (e|E)). looking for sign or digs, else error. */
state6: *s++ = c;
c=input();
if(c=='+' || c=='-') goto state7;
else if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen (digs '.' digs (e|E) sign). looking for digs, else error. */
state7: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state10; /* error */
/* seen (digs '.' digs (e|E) [sign] dig). looking for digs. */
state8: *s++ = c;
c=input();
if(c>='0' && c<='9') goto state8;
else goto state9; /* done */
/* seen a complete number. machine successfully completed. whew! */
state9: unput(c); /* might want that later */
*s++ = '\0';
return(bf);
/* Uh oh. An error. Print an error and restart. */
state10: printf("\n\007??");
goto state1;
}
/* 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);
}
/* gvadr() -- Get variable address from vlist, with type checking.
* This routine allows numerous copies of same name as long as
* all copies have different types. Probably doesnt matter since
* the parser does the type checking.
*/
struct dictnode *gvadr(s,ty)
char *s;
int ty;
{
register int i;
register int qual; /* type qualifier */
for(i=0; vlist[i].name!=0 && i<VLSIZ; i++)
if(vlist[i].type_of_value==ty && strcmp(s,vlist[i].name)==0)
break; /* match found */
if(i >= VLSIZ) {
fprintf(stderr,"gvadr: out of room in variable list for %s\n",s);
exit(1);
}
if(vlist[i].name == 0) { /* not on list, enter it */
vlist[i].name = myalloc(strlen(s)+1);
strcpy(vlist[i].name,s);
vlist[i].val.rval = 0;
vlist[i].type_of_value = ty;
if(ty&T_QMASK == Q_ARY)
vlist[i].val.arval = myalloc(13*sizeof(union value));
}
return(&vlist[i]);
}
/* getplace() -- get a pointer to place of value for vlist entry on top of stack
* For arrays, getplace() expects the indexes to be on the stack as well.
* The parser should properly arrange for this to happen.
*/
union value *getplace(dp)
struct dictnode *dp;
{
int qual;
union value ind,*place;
qual = dp->type_of_value&T_QMASK;
if(qual == Q_ARY) {
ind = pop();
mpop();
place = & dp->val.arval[ind.ival+2];
}
else
place = & dp->val;
return(place);
}
/* 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 12093 -ne "`wc -c < 'bs2/bsint.c'`"
then
echo shar: error transmitting "'bs2/bsint.c'" '(should have been 12093 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/bslib.c'" '(1553 characters)'
if test -f 'bs2/bslib.c'
then
echo shar: will not over-write existing file "'bs2/bslib.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/bslib.c'
/* bslib.c -- subroutine library, routines useful anywhere.
*/
#include "bsdefs.h"
XFILE *bsin = stdin;
/* blcpy -- copies a block of memory (l bytes) from s to d.
*/
blcpy(d,s,l)
char *d,*s;
int l;
{
for(; l >= 0; (l--)) *(d++) = *(s++);
}
/* Input routines. These routines buffer input a line at a time into
* ibuf. Unputted input goes to pbbuf, and gets read before things in
* ibuf, if anything in pbbuf.
*/
char pbbuf[CSTKSIZ],ibuf[BFSIZ];
int iptr = -1;
int pbptr = -1;
char input()
{
if(pbptr > -1)
return(pbbuf[pbptr--]);
else {
if(ibuf[iptr] == '\0') rdlin(bsin);
if(ibuf[iptr]!='\0' && !feof(bsin))
return(ibuf[iptr++]);
else
return(0);
}
}
rdlin(f) FILE *f;
{
char c;
iptr = 0;
for(c=fgetc(f); c!='\n' && c!=EOF; c=fgetc(f)) ibuf[iptr++] = c;
ibuf[iptr++] = c;
ibuf[iptr++] = '\0';
iptr = 0;
}
unput(c) char c;
{ pbbuf[++pbptr] = c; }
/* myalloc() -- allocate, checking for out of memory.
*/
char *myalloc(nb)
int nb;
{
char *rval;
rval = malloc(nb);
/*
printf("myalloc:tos:%o,rv:%o,nb:%d,e:%o\n",&rval,rval,nb,sbrk(0));
*/
if(rval == 0) {
fprintf(stderr,"myalloc: out of memory\n");
exit(1);
}
return(rval);
}
/* Stack routines. Very simple. */
union value stack[STKSIZ];
int stackp = -1;
push(i) union value i;
{
stack[++stackp] = i;
}
union value pop()
{
return(stack[stackp--]);
}
/* Mark stack. Also very simple. */
int mstack[5];
int mstkp = -1;
mpush()
{ mstack[++mstkp] = stackp; }
mpop()
{ stackp = mstack[mstkp--]; }
SHAR_EOF
if test 1553 -ne "`wc -c < 'bs2/bslib.c'`"
then
echo shar: error transmitting "'bs2/bslib.c'" '(should have been 1553 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/errors.c'" '(1583 characters)'
if test -f 'bs2/errors.c'
then
echo shar: will not over-write existing file "'bs2/errors.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/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 < 'bs2/errors.c'`"
then
echo shar: error transmitting "'bs2/errors.c'" '(should have been 1583 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/operat.c'" '(9158 characters)'
if test -f 'bs2/operat.c'
then
echo shar: will not over-write existing file "'bs2/operat.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/operat.c'
/* 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) {
case M_COMPILE:
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) {
case M_COMPILE:
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) {
case M_COMPILE:
l[p++] = scon_in();
return(p);
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) {
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);
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) {
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);
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) {
case M_COMPILE:
l[p++] = atoi(int_in());
return(p);
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) {
case M_COMPILE:
l[p++] = atoi(int_in());
return(p);
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) {
case M_COMPILE:
ty = atoi(int_in());
s = gtok();
l[p++] = gvadr(s,ty);
return(p);
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 9158 -ne "`wc -c < 'bs2/operat.c'`"
then
echo shar: error transmitting "'bs2/operat.c'" '(should have been 9158 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0sources-request@genrad.UUCP (08/01/85)
Mod.sources: Volume 2, Issue 26
Submitted by: ukma!david (David Herron)
#! /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:
# bs2/bstokens.h
# bs2/lex.c
# bs2/makefile
# bs2/mkop.c
# bs2/mkop.sh
# bs2/mkrbop.c
# bs2/mksop.c
# bstest/tary.bs
# bstest/tdata.bs
# bstest/tdata.int
# bstest/tf.int
# bstest/tfor.bs
# bstest/tfor.int
# bstest/tgs.bs
# bstest/tgs.int
# bstest/tif.bs
# bstest/tif.int
# bstest/tloop.bs
# bstest/tloop.int
# bstest/trp.bs
# bstest/trp.int
# bstest/tst6.bs
# bstest/tst6.int
# bstest/twh.bs
# bstest/twh.int
# This archive created: Tue Jul 30 13:03:40 1985
export PATH; PATH=/bin:$PATH
if test ! -d 'bs2'
then
echo shar: creating directory "'bs2'"
mkdir 'bs2'
fi
echo shar: extracting "'bs2/bstokens.h'" '(1017 characters)'
if test -f 'bs2/bstokens.h'
then
echo shar: will not over-write existing file "'bs2/bstokens.h'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/bstokens.h'
# define EQUAL 257
# define NEQ 258
# define LE 259
# define LT 260
# define GE 261
# define WHILE 262
# define GT 263
# define OR 264
# define AND 265
# define NOT 266
# define RET 267
# define REPEAT 268
# define IF 269
# define THEN 270
# define ELSE 271
# define GOTO 272
# define GOSUB 273
# define UNTIL 274
# define STOP 275
# define END 276
# define INTEGER 277
# define REAL 278
# define SCONST 279
# define ELIHW 280
# define LET 281
# define SWORD 282
# define PRINT 283
# define INPUT 284
# define DATA 285
# define CFOR 286
# define FOR 287
# define TO 288
# define STEP 289
# define READ 290
# define WRITE 291
# define NEXT 292
# define DEFINE 293
# define LFUN 294
# define SFUN 295
# define FDEF 296
# define SYMBOL 297
# define DIM 298
# define VALUE 299
# define IWORD 300
# define RWORD 301
# define ROFC 302
# define LOOP 303
# define EXITIF 304
# define ITOR 305
# define RTOI 306
# define ITOA 307
# define RTOA 308
# define LEAVE 309
# define CONTINUE 310
# define POOL 311
# define UNARY 312
SHAR_EOF
if test 1017 -ne "`wc -c < 'bs2/bstokens.h'`"
then
echo shar: error transmitting "'bs2/bstokens.h'" '(should have been 1017 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/lex.c'" '(3933 characters)'
if test -f 'bs2/lex.c'
then
echo shar: will not over-write existing file "'bs2/lex.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/lex.c'
/* lex.c -- tokeniser
*/
#include <stdio.h>
#include <ctype.h>
#include "bstokens.h"
#define gather(c) { yytext[yyleng++] = c; }
#define getdig(c) { for(;isdigit(c);c=input()) gather(c); }
#define ERROR (-1) /* yacc won't know what -1 is, gaurantees a syntax error */
#define YYTXTSIZ 200
char yytext[YYTXTSIZ];
int yyleng;
extern char *yylval; /* to return values to Yacc with */
extern FILE *bsin;
struct word {
int val;
char *name;
} words[] = {
OR,"or", AND,"and", NOT,"not", RET,"return",
IF,"if", THEN,"then", ELSE,"else", WHILE,"while",
GOTO,"goto", GOSUB,"gosub", STOP,"stop", END,"end",
LET,"let", PRINT,"print", INPUT,"input", FOR,"for",
TO,"to", STEP,"step", READ,"read", WRITE,"write",
NEXT,"next", DATA,"data", ELIHW,"elihw", REPEAT,"repeat",
UNTIL,"until", DEFINE,"define", LFUN,"longf", SFUN,"shortf",
FDEF,"file", DIM,"dim", SYMBOL,"symbol", VALUE,"value",
ITOR,"itor", ITOA,"itoa", RTOI,"rtoi", RTOA,"rtoa",
CONTINUE,"continue", LEAVE,"leave",
LOOP,"loop", EXITIF,"exitif", POOL,"pool",
-1,0
};
int yylex()
{
char c;
int i,j,typ;
yylval = &yytext[0];
loop:
c=input();
/* tab, or space */
if(c=='\t' || c==' ')
goto loop;
/* numbers start with a digit or a dot */
else if(isdigit(c) || c=='.')
{
yyleng=0;
typ=INTEGER;
getdig(c);
if(c == '.')
{
typ = REAL;
gather(c);
c = input();
getdig(c);
}
/* at this point, SOME digits must have been read, or else error */
if(yyleng==1 && yytext[0]=='.') goto reterr; /* only "." read */
if(yyleng == 0) goto reterr;
j = yyleng; /* save end of first part */
if(c=='e' || c=='E') /* number raised to something */
{
typ = REAL;
gather(c);
c = input();
if(c=='-' || c=='+') {gather(c); c=input(); }
getdig(c);
/* if no digits read since end of first part,
* then there is an error
*/
for(i=yyleng; i>=j; i--)
if(isdigit(yytext[i]))
break;
if(i <= j) goto reterr;
}
unput(c);
gather('\0');
yylval = malloc(yyleng);
strcpy(yylval,yytext);
return(typ);
reterr:
yyerror("badly formed number\n");
return(ERROR);
}
/* word of some kind */
else if(isalpha(c))
{
yyleng=0;
gather(c);
for(c=input(); isalpha(c) || isdigit(c) || c=='$' || c=='%'; c=input())
gather(c);
unput(c);
gather('\0');
fold(yytext);
for(i=0; words[i].val!=-1; i++)
if(strcmp(yytext,words[i].name)==0)
break;
yylval = malloc(yyleng);
strcpy(yylval,yytext);
if(words[i].val != -1)
return(words[i].val);
else
switch(yytext[yyleng-2]) {
case '$': return(SWORD);
case '%': return(IWORD);
default: return(RWORD);
}
}
/* string constant */
else if(c == '\"')
{
yyleng=0;
for(c=input(); ;c=input())
{
if(c == '\"')
if((c=input()) == '\"')
{
gather('\\');
gather('\"');
}
else break;
else if(c == '\\')
{
gather('\\');
c=input();
gather(c);
if(c == '\n') rdlin(bsin);
}
else if(c == '\n')
{
fprintf(stderr,"unclosed string constant: %s\n",yytext);
rdlin(bsin);
return(ERROR);
}
else gather(c);
}
unput(c);
gather('\0');
yylval = malloc(yyleng);
strcpy(yylval,yytext);
return(SCONST);
}
else if(c == '=')
/* EQUAL == '==' */
if((c=input()) == '=')
return(EQUAL);
/* ASSIGN == '=' */
else
{ unput(c); return('='); }
else if(c == '<')
/* NEQ == '<>' */
if((c=input()) == '>')
return(NEQ);
/* LE == '<=' */
else if(c == '=')
return(LE);
/* LT == '<' */
else
{ unput(c); return(LT); }
else if(c == '>')
/* GE == '>=' */
if((c=input()) == '=')
return(GE);
/* GT == '>' */
else
{ unput(c); return(GT); }
/* anything else */
else return(c);
}
/* fold(s) -- change string to all lower-case letters.
*/
fold(s) char *s;
{
int i;
for(i=0; s[i]!='\0'; i++)
if(isupper(s[i]))
s[i] = s[i] + ('a'-'A');
return(s);
}
SHAR_EOF
if test 3933 -ne "`wc -c < 'bs2/lex.c'`"
then
echo shar: error transmitting "'bs2/lex.c'" '(should have been 3933 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/makefile'" '(651 characters)'
if test -f 'bs2/makefile'
then
echo shar: will not over-write existing file "'bs2/makefile'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/makefile'
OFILES = lex.o bsint.o action.o operat.o bslib.o errors.o
PRSO= bsgram.o lex.o bslib.o
INTO= bsint.o action.o operat2.o operat.o bslib.o errors.o
all: prs int
prs: ${PRSO}
cc -s ${PRSO} -o prs
bsgram.o: bsgram.c bsdefs.h
cc -c bsgram.c
bsgram.c: bsgram.y
yacc -d bsgram.y
mv y.tab.c bsgram.c
mv y.tab.h bstokens.h
int: ${INTO}
cc ${INTO} -o int
${OFILES}: bsdefs.h
operat2.o: mkop.c mkrbop.c mksop.c mkop.sh bsdefs.h
cc mkop.c -o op
cc mkrbop.c -o rop
cc mksop.c -o sop
mkop.sh >operat2.c
cc -c operat2.c
rm operat2.c op sop rop
pr:
pr bsgram.y lex.c bsdefs.h bslib.c bsint.c action.c operat.c mkop.c mkrbop.c mksop.c errors.c | lpr
SHAR_EOF
if test 651 -ne "`wc -c < 'bs2/makefile'`"
then
echo shar: error transmitting "'bs2/makefile'" '(should have been 651 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/mkop.c'" '(1199 characters)'
if test -f 'bs2/mkop.c'
then
echo shar: will not over-write existing file "'bs2/mkop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/mkop.c'
/* mkop.c -- make operator function for bs.
*
* USAGE: op name type oper tag
*
* where: name: name of function generated.
* type: data type of operation.
* oper: operator for operation.
* tag: structure tag name.
*
* This will only work with T_INT and T_DBL operators, T_CHR operations
* do not boil down to a simple operation.
*/
#include <stdio.h>
main(argc,argv)
char **argv;
int argc;
{
char *name,*type,*oper,*tag;
if(argc != 5) {
fprintf(stderr,"arg count\n");
exit(1);
}
name = argv[1]; type = argv[2]; oper = argv[3]; tag = argv[4];
printf("_%s(l,p)\n",name);
printf("int (*l[])(),p;\n");
printf("{\n");
printf(" union value rg1,rg2,result;\n");
printf("\n");
printf(" switch(status&XMODE) {\n");
printf(" case M_READ: dtype = T_%s;\n",type);
printf(" case M_EXECUTE:\n");
printf(" rg2 = pop();\n");
printf(" rg1 = pop();\n");
printf(" result.%s = rg1.%s %s rg2.%s;\n",tag,tag,oper,tag);
printf(" push(result);\n");
printf(" case M_FIXUP:\n");
printf(" case M_COMPILE: return(p);\n");
printf(" default: STerror(\"%s\");\n",name);
printf(" }\n");
printf("}\n");
}
SHAR_EOF
if test 1199 -ne "`wc -c < 'bs2/mkop.c'`"
then
echo shar: error transmitting "'bs2/mkop.c'" '(should have been 1199 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/mkop.sh'" '(791 characters)'
if test -f 'bs2/mkop.sh'
then
echo shar: will not over-write existing file "'bs2/mkop.sh'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/mkop.sh'
echo "/* operat2.c -- more operators for bs. the ones that are all alike."
echo " */"
echo ""
echo "#include \"bsdefs.h\""
echo ""
op "iadd" "INT" "+" "ival"
op "radd" "DBL" "+" "rval"
op "isub" "INT" "-" "ival"
op "rsub" "DBL" "-" "rval"
op "imult" "INT" "*" "ival"
op "rmult" "DBL" "*" "rval"
op "idiv" "INT" "/" "ival"
op "rdiv" "DBL" "/" "rval"
op "imod" "INT" "%" "ival"
op "ieq" "INT" "==" "ival"
rop "req" "=="
sop "seq" "=="
op "ineq" "INT" "!=" "ival"
rop "rneq" "!="
sop "sneq" "!="
op "ileq" "INT" "<=" "ival"
rop "rleq" "<="
sop "sleq" "<="
op "ilt" "INT" "<" "ival"
rop "rlt" "<"
sop "slt" "<"
op "igeq" "INT" ">=" "ival"
rop "rgeq" ">="
sop "sgeq" ">="
op "igt" "INT" ">" "ival"
rop "rgt" ">"
sop "sgt" ">"
op "or" "INT" "||" "ival"
op "and" "INT" "&&" "ival"
SHAR_EOF
if test 791 -ne "`wc -c < 'bs2/mkop.sh'`"
then
echo shar: error transmitting "'bs2/mkop.sh'" '(should have been 791 characters)'
fi
chmod +x 'bs2/mkop.sh'
fi # end of overwriting check
echo shar: extracting "'bs2/mkrbop.c'" '(987 characters)'
if test -f 'bs2/mkrbop.c'
then
echo shar: will not over-write existing file "'bs2/mkrbop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/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(" switch(status&XMODE) {\n");
printf(" case M_READ: dtype = T_INT;\n");
printf(" case 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(" case M_FIXUP:\n");
printf(" case M_COMPILE: return(p);\n");
printf(" default: STerror(\"%s\");\n",name);
printf(" }\n");
printf("}\n");
}
SHAR_EOF
if test 987 -ne "`wc -c < 'bs2/mkrbop.c'`"
then
echo shar: error transmitting "'bs2/mkrbop.c'" '(should have been 987 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bs2/mksop.c'" '(932 characters)'
if test -f 'bs2/mksop.c'
then
echo shar: will not over-write existing file "'bs2/mksop.c'"
else
sed 's/^X//' << \SHAR_EOF > 'bs2/mksop.c'
/* mksop.c -- make string comparator functions for bs.
*
* 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(" switch(status&XMODE) {\n");
printf(" case M_EXECUTE:\n");
printf(" rg2 = pop();\n");
printf(" rg1 = pop();\n");
printf(" result.sval = strcmp(rg1.sval,rg2.sval) %s 0;\n",oper);
printf(" push(result);\n");
printf(" case M_FIXUP:\n");
printf(" case M_COMPILE: return(p);\n");
printf(" default: STerror(\"%s\");\n",name);
printf(" }\n");
printf("}\n");
}
SHAR_EOF
if test 932 -ne "`wc -c < 'bs2/mksop.c'`"
then
echo shar: error transmitting "'bs2/mksop.c'" '(should have been 932 characters)'
fi
fi # end of overwriting check
if test ! -d 'bstest'
then
echo shar: creating directory "'bstest'"
mkdir 'bstest'
fi
echo shar: extracting "'bstest/tary.bs'" '(113 characters)'
if test -f 'bstest/tary.bs'
then
echo shar: will not over-write existing file "'bstest/tary.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tary.bs'
10 a=1.0
20 b(3)=2.0
30 b(2)=1.0
40 b(1)=0.0
45 print rtoa(a),rtoa(b(3)),rtoa(b(2)),rtoa(b(1)),rtoa(b(5))
50 end
SHAR_EOF
if test 113 -ne "`wc -c < 'bstest/tary.bs'`"
then
echo shar: error transmitting "'bstest/tary.bs'" '(should have been 113 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tdata.bs'" '(134 characters)'
if test -f 'bstest/tdata.bs'
then
echo shar: will not over-write existing file "'bstest/tdata.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tdata.bs'
10 data 10,20,15,30,5,35,12,32,0
20 read i%
30 if i%==0 then goto 200
40 print itoa(i%),
50 goto 20
200 print "\nOut of data"
210 end
SHAR_EOF
if test 134 -ne "`wc -c < 'bstest/tdata.bs'`"
then
echo shar: error transmitting "'bstest/tdata.bs'" '(should have been 134 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tdata.int'" '(397 characters)'
if test -f 'bstest/tdata.int'
then
echo shar: will not over-write existing file "'bstest/tdata.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tdata.int'
line 10 data icon 10 dsep icon 20 dsep icon 15 dsep icon 30 dsep icon 5 dsep icon 35 dsep icon 12 dsep icon 32 dsep icon 0 dsep
line 20 pushstate 16 var 64 i% popstate
line 30 var 64 i% val 64 icon 0 i== if goto 200 else
line 40 var 64 i% val 64 itoa scon "" , print
line 50 goto 20
line 200 scon "\nOut of data" scon "\n" ; print
line 210 end
SHAR_EOF
if test 397 -ne "`wc -c < 'bstest/tdata.int'`"
then
echo shar: error transmitting "'bstest/tdata.int'" '(should have been 397 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tf.int'" '(223 characters)'
if test -f 'bstest/tf.int'
then
echo shar: will not over-write existing file "'bstest/tf.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tf.int'
line 5 scon "Start please." scon "\n" ; print
line 6 input var 32 a$ elst
line 10 var 0 i con 1 con 10000 con 0 con 0 for
line 20 var 0 i next
line 30 scon "Done." scon "\n" ; print
line 40 end
SHAR_EOF
if test 223 -ne "`wc -c < 'bstest/tf.int'`"
then
echo shar: error transmitting "'bstest/tf.int'" '(should have been 223 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tfor.bs'" '(130 characters)'
if test -f 'bstest/tfor.bs'
then
echo shar: will not over-write existing file "'bstest/tfor.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tfor.bs'
5 for j% = 1 to 10
7 print itoa(j%);" ";
10 for i% = 1 to 10
20 print itoa(i%);" ";
30 next i%
32 print ""
35 next j%
50 end
SHAR_EOF
if test 130 -ne "`wc -c < 'bstest/tfor.bs'`"
then
echo shar: error transmitting "'bstest/tfor.bs'" '(should have been 130 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tfor.int'" '(565 characters)'
if test -f 'bstest/tfor.int'
then
echo shar: will not over-write existing file "'bstest/tfor.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tfor.int'
line 5 var 64 j% icon 1 icon 10 icon 0 rlabel FOR2 rlabel FOR1 enter icon 0 rlabel FOR1 dlabel FOR0 for
line 7 var 64 j% val 64 itoa scon " " ; scon "" ; print
line 10 var 64 i% icon 1 icon 10 icon 0 rlabel FOR5 rlabel FOR4 enter icon 0 rlabel FOR4 dlabel FOR3 for
line 20 var 64 i% val 64 itoa scon " " ; scon "" ; print
line 30 dlabel FOR5 var 64 i% next rlabel FOR3 goto dlabel FOR4 exitlp
line 32 scon "" scon "\n" ; print
line 35 dlabel FOR2 var 64 j% next rlabel FOR0 goto dlabel FOR1 exitlp
line 50 end
SHAR_EOF
if test 565 -ne "`wc -c < 'bstest/tfor.int'`"
then
echo shar: error transmitting "'bstest/tfor.int'" '(should have been 565 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tgs.bs'" '(143 characters)'
if test -f 'bstest/tgs.bs'
then
echo shar: will not over-write existing file "'bstest/tgs.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tgs.bs'
10 a%=0
20 while ( a%<20 )
29 print itoa(a%),
30 gosub 100
31 print itoa(a%),
40 elihw
50 print "Done."
60 stop
100 a%=a%+1
110 return
120 end
SHAR_EOF
if test 143 -ne "`wc -c < 'bstest/tgs.bs'`"
then
echo shar: error transmitting "'bstest/tgs.bs'" '(should have been 143 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tgs.int'" '(408 characters)'
if test -f 'bstest/tgs.int'
then
echo shar: will not over-write existing file "'bstest/tgs.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tgs.int'
line 10 var 64 a% icon 0 store 64 pop
line 20 loopto var 64 a% val 64 icon 20 i< while
line 29 var 64 a% val 64 itoa scon " " ; print
line 30 gosub 100
line 31 var 64 a% val 64 itoa scon " " ; print
line 40 elihw
line 50 scon "Done." scon "\n" ; print
line 60 stop
line 100 var 64 a% var 64 a% val 64 icon 1 i+ store 64 pop
line 110 return
line 120 end
SHAR_EOF
if test 408 -ne "`wc -c < 'bstest/tgs.int'`"
then
echo shar: error transmitting "'bstest/tgs.int'" '(should have been 408 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tif.bs'" '(180 characters)'
if test -f 'bstest/tif.bs'
then
echo shar: will not over-write existing file "'bstest/tif.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tif.bs'
10 a=3.0
20 input b
30 if a==b then goto 100 else goto 70
40 print "failed"
50 stop
70 print rtoa(a);" != ";rtoa(b)
80 goto 20
100 print rtoa(a);" == ";rtoa(b)
110 goto 20
120 end
SHAR_EOF
if test 180 -ne "`wc -c < 'bstest/tif.bs'`"
then
echo shar: error transmitting "'bstest/tif.bs'" '(should have been 180 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tif.int'" '(538 characters)'
if test -f 'bstest/tif.int'
then
echo shar: will not over-write existing file "'bstest/tif.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tif.int'
line 10 var 192 a rcon 3.0 store 192 pop
line 20 pushstate 4 var 192 b popstate
line 30 var 192 a val 192 var 192 b val 192 r== rlabel IF0 if goto 100 rlabel IF1 go@ dlabel IF0 goto 70 dlabel IF1
line 40 scon "failed" scon "\n" ; print
line 50 stop
line 70 var 192 a val 192 rtoa scon " != " ; var 192 b val 192 rtoa ; scon "\n" ; print
line 80 goto 20
line 100 var 192 a val 192 rtoa scon " == " ; var 192 b val 192 rtoa ; scon "\n" ; print
line 110 goto 20
line 120 end
SHAR_EOF
if test 538 -ne "`wc -c < 'bstest/tif.int'`"
then
echo shar: error transmitting "'bstest/tif.int'" '(should have been 538 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tloop.bs'" '(164 characters)'
if test -f 'bstest/tloop.bs'
then
echo shar: will not over-write existing file "'bstest/tloop.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tloop.bs'
10 loop
20 input a,b
30 exitif a==b
40 a% = rtoi(a)
50 b% = rtoi(b)
60 print "a:";(a);" a%:";(a%);" b:";(b);" b%:";(b%)
70 pool
80 print "Done."
90 end
SHAR_EOF
if test 164 -ne "`wc -c < 'bstest/tloop.bs'`"
then
echo shar: error transmitting "'bstest/tloop.bs'" '(should have been 164 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tloop.int'" '(618 characters)'
if test -f 'bstest/tloop.int'
then
echo shar: will not over-write existing file "'bstest/tloop.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tloop.int'
line 10 rlabel LP2 rlabel LP1 enter dlabel LP0
line 20 pushstate 4 var 192 a var 192 b popstate
line 30 var 192 a val 192 var 192 b val 192 r== not rlabel LP1 if
line 40 var 64 a% var 192 a val 192 rtoi store 64 pop
line 50 var 64 b% var 192 b val 192 rtoi store 64 pop
line 60 scon "a:" var 192 a val 192 rtoa ; scon " a%:" ; var 64 a% val 64 itoa ; scon " b:" ; var 192 b val 192 rtoa ; scon " b%:" ; var 64 b% val 64 itoa ; scon "\n" ; print
line 70 dlabel LP2 rlabel LP0 goto dlabel LP1 exitlp
line 80 scon "Done." scon "\n" ; print
line 90 end
SHAR_EOF
if test 618 -ne "`wc -c < 'bstest/tloop.int'`"
then
echo shar: error transmitting "'bstest/tloop.int'" '(should have been 618 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/trp.bs'" '(74 characters)'
if test -f 'bstest/trp.bs'
then
echo shar: will not over-write existing file "'bstest/trp.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/trp.bs'
10 repeat
20 print "Guess ";
30 input a
40 until ( rtoi(a) == 20 )
50 end
SHAR_EOF
if test 74 -ne "`wc -c < 'bstest/trp.bs'`"
then
echo shar: error transmitting "'bstest/trp.bs'" '(should have been 74 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/trp.int'" '(246 characters)'
if test -f 'bstest/trp.int'
then
echo shar: will not over-write existing file "'bstest/trp.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/trp.int'
line 10 rlabel REP1 rlabel REP2 enter dlabel REP0
line 20 scon "Guess " print
line 30 pushstate 4 var 192 a popstate
line 40 dlabel REP1 var 192 a val 192 rtoi icon 20 i== not rlabel REP0 if dlabel REP2 exitlp
line 50 end
SHAR_EOF
if test 246 -ne "`wc -c < 'bstest/trp.int'`"
then
echo shar: error transmitting "'bstest/trp.int'" '(should have been 246 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tst6.bs'" '(438 characters)'
if test -f 'bstest/tst6.bs'
then
echo shar: will not over-write existing file "'bstest/tst6.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tst6.bs'
5 l%=32000
6 h%=-32000
9 print "trailer==0, input one number at a time."
10 input a%
20 if a%==0 then goto 100
30 if a%<l% then goto 60
40 if a%>h% then goto 80
41 print"made it through l:";itoa(l%);"h:";itoa(h%);"a:";itoa(a%)
50 goto 10
60 l%=a%
61 print"a<l l:";itoa(l%);"h:";itoa(h%);"a:";itoa(a%)
70 goto 10
80 h%=a%
81 print"a>h l:";itoa(l%);"h:";itoa(h%);"a:";itoa(a%)
90 goto 10
100 print "low=";itoa(l%),"high=";itoa(h%)
110 end
SHAR_EOF
if test 438 -ne "`wc -c < 'bstest/tst6.bs'`"
then
echo shar: error transmitting "'bstest/tst6.bs'" '(should have been 438 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/tst6.int'" '(1399 characters)'
if test -f 'bstest/tst6.int'
then
echo shar: will not over-write existing file "'bstest/tst6.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/tst6.int'
line 5 var 64 l% icon 32000 store 64 pop
line 6 var 64 h% icon 32000 icon -1 i* store 64 pop
line 9 scon "trailer==0, input one number at a time." scon "\n" ; print
line 10 pushstate 4 var 64 a% popstate
line 20 var 64 a% val 64 icon 0 i== rlabel IF0 if rlabel LN100 goto rlabel IF1 goto dlabel IF0 dlabel IF1
line 30 var 64 a% val 64 var 64 l% val 64 i< rlabel IF2 if rlabel LN60 goto rlabel IF3 goto dlabel IF2 dlabel IF3
line 40 var 64 a% val 64 var 64 h% val 64 i> rlabel IF4 if rlabel LN80 goto rlabel IF5 goto dlabel IF4 dlabel IF5
line 41 scon "made it through l:" var 64 l% val 64 itoa ; scon "h:" ; var 64 h% val 64 itoa ; scon "a:" ; var 64 a% val 64 itoa ; scon "\n" ; print
line 50 rlabel LN10 goto
line 60 var 64 l% var 64 a% val 64 store 64 pop
line 61 scon "a<l l:" var 64 l% val 64 itoa ; scon "h:" ; var 64 h% val 64 itoa ; scon "a:" ; var 64 a% val 64 itoa ; scon "\n" ; print
line 70 rlabel LN10 goto
line 80 var 64 h% var 64 a% val 64 store 64 pop
line 81 scon "a>h l:" var 64 l% val 64 itoa ; scon "h:" ; var 64 h% val 64 itoa ; scon "a:" ; var 64 a% val 64 itoa ; scon "\n" ; print
line 90 rlabel LN10 goto
line 100 scon "low=" var 64 l% val 64 itoa ; scon "high=" , var 64 h% val 64 itoa ; scon "\n" ; print
line 110 end
SHAR_EOF
if test 1399 -ne "`wc -c < 'bstest/tst6.int'`"
then
echo shar: error transmitting "'bstest/tst6.int'" '(should have been 1399 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/twh.bs'" '(201 characters)'
if test -f 'bstest/twh.bs'
then
echo shar: will not over-write existing file "'bstest/twh.bs'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/twh.bs'
9 print "Guess a number ";
10 input a
20 while ( rtoi(a) <> 20)
25 gosub 100
30 elihw
40 print "You guessed it!"
100 print "Do it again ";
110 input a
111 print "number is ";rtoa(a)
120 return
200 end
SHAR_EOF
if test 201 -ne "`wc -c < 'bstest/twh.bs'`"
then
echo shar: error transmitting "'bstest/twh.bs'" '(should have been 201 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'bstest/twh.int'" '(549 characters)'
if test -f 'bstest/twh.int'
then
echo shar: will not over-write existing file "'bstest/twh.int'"
else
sed 's/^X//' << \SHAR_EOF > 'bstest/twh.int'
line 9 scon "Guess a number " scon "" ; print
line 10 pushstate 4 var 192 a popstate
line 20 rlabel WH2 rlabel WH1 enter dlabel WH0 var 192 a val 192 rtoi icon 20 i<> rlabel WH1 if
line 25 rlabel LN100 gosub
line 30 dlabel WH2 rlabel WH0 goto dlabel WH1 exitlp
line 40 scon "You guessed it!" scon "\n" ; print
line 100 scon "Do it again " scon "" ; print
line 110 pushstate 4 var 192 a popstate
line 111 scon "number is " var 192 a val 192 rtoa ; scon "\n" ; print
line 120 return
line 200 end
SHAR_EOF
if test 549 -ne "`wc -c < 'bstest/twh.int'`"
then
echo shar: error transmitting "'bstest/twh.int'" '(should have been 549 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0