Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site seismo.UUCP Posting-Version: version B 2.10.2 9/3/84; site genrad.UUCP Path: seismo!harvard!talcott!panda!genrad!sources-request From: sources-request@genrad.UUCP Newsgroups: mod.sources Subject: A BASIC interpretor (Part 3 of 4) Message-ID: <991@genrad.UUCP> Date: 31 Jul 85 10:18:37 GMT Sender: john@genrad.UUCP Lines: 2734 Approved: john@genrad.UUCP 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-- ,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: ,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: ,x --to-- ,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: ,x --to-- ,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 expr expr expr con 0 dlabel FORx rlabel FORx+1 for *--to-- * _var,vp,,,,,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->ival0 && place.plval->ival>to.ival) goto loop_done; else /* vizd.ival == T_DBL */ if(step.rval<0 && place.plval->rval0 && 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 x --to-- x,pushstate,,x * M_FIXUP: * skip * any other state: * save old state and stack pointer. * set state to . */ _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 #include /* '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 . * next 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) { 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 " 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 0