Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume7 / basic / part02 < prev next >

Wrap

Internet Message Format | 1986-12-03 | 54.6 KB

Subject: v07i074: A BASIC Interpreter, Part02/06 Newsgroups: mod.sources Approved: mirror!rs Submitted by: phil@Cs.Ucl.AC.UK Mod.sources: Volume 7, Issue 74 Archive-name: basic/Part02 # Shar file shar02 (of 6) # # This is a shell archive containing the following files :- # bas2.c # bas3.c # bas4.c # bas5.c # bas6.c # ------------------------------ # This is a shell archive, shar, format file. # To unarchive, feed this text into /bin/sh in the directory # you wish the files to be in. echo x - bas2.c 1>&2 sed 's/^X//' > bas2.c << 'End of bas2.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * This file contains the routines to get a variable from its name X * To dimension arrays and assignment to a variable. X * X * A variable name consists of a letter followed by an optional X * letter or digit followed by the type specifier. X * A type specifier is a '%' for an integer a '$' for a string X * or is absent if the variable is a real ( Default ). X * An integer variable also has the top bit of its second letter X * set this is used to distinguish between real and integer variables. X * A variable name can be optionally followed by a subscript X * turning the variable into a subscripted variable. X * A subscript is specified by a list of indexes in square brackets X * e.g. [1,2,3] , a maximum of three subscripts may be used. X * All arrays must be specified before use. X * X * The variable to be accessed has its name in the array nm[], X * and its type in the variable 'vartype'. X * X * 'vartype' is very important as it is used all over the place X * X * The value in 'vartype' can have the following values:- X * 0: real variable (Default ). X * 1: integer variable. X * 2: string variable. X * X */ X X#ifdef V6 X#define LBRACK '[' X#define RBRACK ']' X#else X#define LBRACK '(' X#define RBRACK ')' X#endif X X/* X * getnm will return with nm[] and vartype set appropriately but without X * any regard for subscript parameters. Called by dimensio() only. X */ X Xgetnm() X{ X#ifdef LNAMES X register char *p,*q; X register struct entry *ep,*np; X register int c; X register int l; X nam[0]=c=getch(); X if(!isletter(c)) X error(VARREQD); X p = &nam[1]; X for(l =c,c = *point;isletter(c) || isnumber(c) ; c = *++point) X if(p < &nam[MAXNAME-1] ){ X l +=c; X *p++ = c; X } X *p = 0; X for(np = 0,ep=hshtab[l%HSHTABSIZ]; ep ; np = ep,ep=ep->link) X if(l == ep->ln_hash) X for(p = ep->_name,q = nam ; *q == *p++ ; ) X if(!*q++) X goto got; X ep = (struct entry *)xpand(&enames,sizeof(struct entry)); X if(!np) X hshtab[l%HSHTABSIZ] = ep; X else X np->link = ep; X for(p = ep->_name , q = nam ; *p++ = *q++ ; ); X ep->ln_hash = l; Xgot: X nm = (char *)ep - estring; X#else X register int c; X nm=c=getch(); X if(!isletter(c)) X error(VARREQD); X c= *point; X if(isletter(c) ||isnumber(c)){ X nm |= c<<8; X do X c= *++point; X while(isletter(c) || isnumber(c)); X } X#endif X vartype=0; X if(c=='$'){ X point++; X vartype=02; X } X else if(c=='%'){ X point++; X vartype++; X nm |=0200<<8; X } X} X X/* X * getname() will return a pointer to a variable with vartype X * set to the correct type. If the variable is subscripted getarray X * is called and the subscripts are evaluated and depending upon X * the type of variable the index into that array is returned. X * Any simple variable that is not already declared is defined X * and has a value of 0 or null (for strings) assigned to it. X * In all instances a valid pointer is returned. X */ Xmemp getname() X{ X memp getstring(); X#ifdef LNAMES X register char *p,*q; X register struct entry *ep; X register int c; X register struct vardata *pt; X struct entry *np; X register int l; X nam[0]=c=getch(); X if(!isletter(c)) X error(VARREQD); X p = &nam[1]; X for(l =c,c = *point;isletter(c) || isnumber(c) ; c = *++point) X if(p < &nam[MAXNAME-1] ){ X l +=c; X *p++ = c; X } X *p = 0; X for(np = 0,ep=hshtab[l%HSHTABSIZ]; ep ; np = ep,ep=ep->link) X if(l == ep->ln_hash) X for(p = ep->_name,q = nam ; *q == *p++ ; ) X if(!*q++) X goto got; X ep = (struct entry *)xpand(&enames,sizeof(struct entry)); X if(!np) X hshtab[l%HSHTABSIZ] = ep; X else X np->link = ep; X for(p = ep->_name ,q = nam ; *p++ = *q++ ; ); X ep->ln_hash = l; Xgot: X nm = (char *)ep - estring; X#else X register int c; X register struct vardata *pt; X X nm=c=getch(); X if(!isletter(c)) X error(VARREQD); X c= *point; X if(isletter(c) ||isnumber(c)){ X nm |=c<<8; X do{ c= *++point; }while(isletter(c) || isnumber(c)); X } X#endif X vartype=0; X if(c=='$'){ X vartype=02; X if(*++point==LBRACK) X getarray(); X return(getstring()); X } X else if(c=='%'){ X point++; X vartype++; X nm |= 0200<<8; X } X if(*point==LBRACK) X return( (memp) getarray()); X#ifdef LNAMES X /* X * now do hashing of the variables X */ X if( (c = varshash[l % HSHTABSIZ]) >= 0){ X pt = (vardp)earray; X for(pt += c; pt < (vardp) vend;pt++) X if(pt->nam ==nm ) X return( (memp) &pt->dt); X /* X * not found **** X */ X } X /* X * really look for it - will force varshash to be the lowest X * value. The hassle of chaining. X */ X if(chained) X for(pt = (vardp)earray; pt < (vardp) vend;pt++) X if(pt->nam ==nm ){ X varshash[l % HSHTABSIZ] = pt - (vardp)earray; X return((memp) &pt->dt); X } X /* X * not found **** X */ X pt= (vardp) xpand(&vend,sizeof(struct vardata)); X if(c < 0) X varshash[l % HSHTABSIZ] = pt - (vardp)earray; X#else X for(pt = (vardp)earray; pt < (vardp) vend;pt++) X if(pt->nam ==nm ) X return( (memp) &pt->dt); X pt= (vardp) xpand(&vend,sizeof(struct vardata)); X#endif X pt->nam=nm; X return( (memp) &pt->dt); X} X X/* X * getstring() returns a pointer to a string structure if the string X * is not declared then it is defined. X */ X Xmemp Xgetstring() X{ X register struct stdata *p; X vartype=02; X for(p= (stdatap)estdt ; p < (stdatap)estring ; p++) X if(p->snam == nm ) X return( (memp) p); X if( estdt - sizeof(struct stdata) < eostring){ X garbage(); X if(estdt - sizeof(struct stdata) <eostring) X error(OUTOFSTRINGSPACE); X } X p = (stdatap)estdt; X --p; estdt = (memp)p; X p->snam = nm; X p->stpt=0; X return( (memp) p); X} X X/* X * getarray() evaluates the subscripts of an array and the tries X * to access it. getarray() returns different things dependent X * on the type of variable. For an integer or real then the pointer to X * the element of the array is returned. X * For a string array element then the nm[] array is filled out X * with a unique number and then getstring() is called to access it. X * The variable hash (in the strarr structure ) is used as the X * offset to the next array if the array is real or integer, but X * is the base for the unique number to access the string structure. X * X * This is a piece of 'hairy' codeing. X */ X Xgetarray() X{ X register struct strarr *p; X register int l; X short *m; X int c; X int i=1; X register int j=0; X char vty; X#ifdef LNAMES X memp savee; X#endif X X point++; X vty=vartype; X if(vty==02){ X for(p= (strarrp) edefns ; p < (strarrp) estarr ; p++) X if(p->snm ==nm ) X goto got; X } X else { X for( p = (strarrp) estarr ; p < (strarrp)earray ; X p = (strarrp)((memp)p + p->hash) ) X if(p->snm ==nm ) X goto got; X } X error(19); Xgot: m = p->dim; X i=1; X do{ X#ifdef LNAMES X savee = edefns; X#endif X l=evalint()-baseval; X#ifdef LNAMES X p = (strarrp)((memp)p + (edefns - savee)); X#endif X if(l >= *m || l <0) X error(17); X j= l + j * *m; X if((c=getch())!=',') X break; X m++,i++; X } while(i <= p->dimens); X if(i!=p->dimens || c!=RBRACK) X error(16); X vartype=vty; X if(vty==02){ X j += p->hash; X j |= 0100000; X nm = j; X } X else { X j <<= (vty ? 1 : 3 ); X p++; X return( (int) ((char *)p+j) ); X } X} X X/* X * dimensio() executes the dim command. It sets up the strarr structure X * as needed. If the array is a string array then only the structure X * is filled in. This means that elements of a string array do not have X * storage allocated until assigned to. If the array is real or integer X * then the array is allocated space as well as the strarr array. X * This is why the hash element is needed so as to be able to access X * the next array. X */ X X Xdimensio() X{ X int dims[3]; X int nmm; X long j; X int c; X char vty; X register int i; X register int *r; X register struct strarr *p; Xfor(;;){ X r=dims; X i=0; X j=1; X getnm(); X nmm = nm; X vty=vartype; /* save copy of type of array */ X if(*point++!=LBRACK) X error(SYNTAX); X do{ X *r=evalint() + 1 - baseval; X#ifndef pdp11 X if( (j *= *r) <= 0 || j > 32767) X#else X if( (j=dimmul( (int)j , *r)) <= 0) X#endif X error(17); X if((c=getch())!=',') X break; X r++;i++; X }while(i<3); X if(i ==3 || c!=RBRACK) X error(16); X i++; X if(vty== 02){ X for(p= (strarrp) edefns ;p < (strarrp) estarr;p++) X if(p->snm == nmm ) X error(20); X if(j+shash > 32767) X error(17); X p = (strarrp) xpand(&estarr,sizeof(struct strarr)); X p->hash= shash; X shash+=j; X } X else { X for(p = (strarrp)estarr ; p < (strarrp)earray ; X p = (strarrp)((memp)p + p->hash) ) X if(p->snm == nmm ) X error(20); X j<<= (vty ? 1 : 3); X j += sizeof(struct strarr); X#ifdef ALIGN4 X j = (j + 3) & ~03; X#endif X if(nospace(j)) X error(17); X p = (strarrp) xpand(&earray,(int)j); X p->hash = j; /* offset to next array */ X } X p->snm = nmm; /* fill in common stuff */ X p->dimens=i; X p->dim[0]=dims[0]; X p->dim[1]=dims[1]; X p->dim[2]=dims[2]; X if(getch()!=',') /* any more arrays */ X break; X } X point--; X normret; X} X X/* X * Assign() is called if there is no keyword at the start of a X * statement ( Default assignment statement ) and by let. X * it just calls the relevent evaluation routine and leaves all the X * hard work to stringassign() and putin() to actualy assign the variables. X */ X Xassign() X{ X register memp p; X register char vty; X register int c; X int i; X value t1; X extern int (*mbin[])(); X#ifdef LNAMES X memp savee; X#endif X X p= getname(); X vty=vartype; X if(vty==02){ X if(getch()!='=') X error(4); X stringeval(gblock); X stringassign( (stdatap)p ); X return; X } X#ifdef LNAMES X savee = edefns; X#endif X if((c = getch()) != '='){ X i = 6; X switch(c){ X default: X error(4); X case '*': X case '/': X i += 2; X break; X case '+': X case '-': X break; X } X if(*point++ != '=') X error(4); X#ifndef V6C X t1 = *((value *)p); X#else X movein(p,&t1); X#endif X eval(); X if(vty != vartype){ X if(vty) X cvt(&t1); X else X cvt(&res); X vartype = 0; X } X (*mbin[i+vartype])(&t1,&res,c); X } X else X eval(); X#ifdef LNAMES X /* X * cope with adding new names - pushes space up X */ X p += edefns - savee; X#endif X putin(p,vty); X} End of bas2.c chmod u=rw-,g=r,o=r bas2.c echo x - bas3.c 1>&2 sed 's/^X//' > bas3.c << 'End of bas3.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * This file contains the numeric evaluation routines and some X * of the numeric functions. X */ X X/* X * evalint() is called by a routine that requires an integer value X * e.g. string functions. It will always return an integer. If X * the result will not overflow an integer -1 is returned. X * N.B. most ( all ) routines assume that a negative return is an X * error. X */ X X Xevalint() X{ X eval(); X if(vartype) X return(res.i); X if(conv(&res)) X return(-1); X return(res.i); X} X X/* X * This structure is only ever used by eval() and so is not declared X * in 'bas.h' with the others. X */ X X Xstruct m { X value r1; X int lastop; X char value; X char vty; X }; X X/* X * eval() will evaluate any numeric expression and return the result X * in the UNION 'res'. X * A valid expression can be any numeric expression or a string X * comparison expression e.g. "as" <> "gh" . String expressions can X * themselves be used in relational tests and also be used with the X * logical operators. e.g. "a" <> "b" and "1" <> a$ is a valid X * expression. X */ X Xeval() X{ X extern (*mbin[])(); X register int i; X register int c; X register struct m *j; X value *pp; X char firsttime=1; X char minus=0,noting=0; X struct m restab[6]; X X checksp(); X j=restab; X j->value=0; X Xfor(;;){ X c=getch(); X if(c=='-' && firsttime){ X if(minus) X error(SYNTAX); X minus++; X continue; X } X else if(c==NOTT){ X if(noting) X error(SYNTAX); X noting++; X firsttime++; X continue; X } X else if(c&0200){ X if(c<MINFUNC || c>MAXFUNC) /* we have a function */ X goto err1; /* possibly a string function */ X if(c>= RND ) /* functions that don't */ X (*functs[c-RND])(); /* require arguments */ X else { X if(*point++ !='(') X error(SYNTAX); /* functions that do */ X (*functb[c-MINFUNC])(); X if(getch()!=')') X error(SYNTAX); X } X } X else if(isletter(c)){ X char *sp = --point; X X pp= (value *)getname(); /* we have a variable */ X if(vartype== 02){ /* a string !!!!!! */ X if(firsttime){ /* no need for checktype() since */ X point = sp; /* we know it's a string */ X stringcompare(); X goto ex; X } X else error(2); /* variable required */ X } X#ifdef V6C X getv(pp); X#else X res = *pp; X#endif X } X else if(isnumber(c) || c=='.'){ X point--; X if(!getop()) /* we have a number */ X error(36); /* bad number */ X } X else if(c=='('){ /* bracketed expression */ X eval(); /* recursive call of eval() */ X if(getch()!=')') X error(SYNTAX); X } X else { Xerr1: /* get here if the function we tried to access was not */ X /* a legal maths func. or a string variable */ X /* stringcompare() will give a syntax error if not a valid */ X /* string. therefore this works ok */ X point--; X if(!firsttime) X error(SYNTAX); X stringcompare(); X } Xex: X if(minus){ /* do the unary minus */ X minus=0; X negate(); X } X if(noting){ /* do the not */ X noting=0; X notit(); X } X i=0; X switch(c=getch()){ /* get the precedence of the */ X case '^': i++; /* operator */ X case '*': X case '/': X case MODD: i++; X case '+': X case '-': i++; X case EQL: /* comparison operators */ X case LTEQ: X case NEQE: X case LTTH: X case GTEQ: X case GRTH: i++; /* logical operators */ X case ANDD: X case ORR: X case XORR: i++; X } X if(i>2) X firsttime = 0; Xame: if(j->value< (char)i){ /* current operator has higher */ X (++j)->lastop=c; /* precedence */ X#ifndef V6C X j->r1 = res; X#else X push(&j->r1); /* block moving */ X#endif X j->value=i; X j->vty=vartype; X continue; X } X if(! j->value ){ /* end of expression */ X point--; X return; X } X if(j->vty!=vartype){ /* make both parameters */ X if(vartype) /* the same type */ X cvt(&res); X else X cvt(&j->r1); /* if changed then they must be */ X vartype=0; /* changed to reals */ X } X (*mbin[(j->value<<1)+vartype])(&j->r1,&res,j->lastop); X j--; /* execute it then pop the stack and */ X goto ame; /* deal with the next operator */ X } X} X X/* X * The rest of the routines in this file evaluate functions and are X * relatively straight forward. X */ X Xtim() X{ X time(&overfl); X X#ifndef SOFTFP X res.f = overfl; X vartype = 0; X#else X over(0,&res); /* convert from long to real */ X#endif X} X Xrnd() X{ X static double recip32 = 32767.0; X value temp; X register int rn; X X rn = rand() & 077777; X if(*point!='('){ X res.i=rn; X vartype=01; X return; X } X point++; X eval(); X if(getch()!=')') X error(SYNTAX); X#ifdef PORTABLE X if(vartype ? res.i : res.f){ X#else X if(res.i){ X#endif X if(!vartype && conv(&res)) X error(FUNCT); X res.i= rn % res.i + 1; X vartype=01; X return; X } X#ifndef SOFTFP X res.f = (double)rn / recip32; X#else X temp.i=rn; X cvt(&temp); X#ifndef V6C X res = *( (value *)( &recip32 ) ); X#else X movein(&recip32,&res); X#endif X fdiv(&temp,&res); /* horrible */ X#endif X vartype =0; X} X X/* X * This routine is the command 'random' and is placed here for some X * unknown reason it just sets the seed to rnd to the value from X * the time system call ( is a random number ). X */ X Xrandom() X{ X long m; X time(&m); X srand((int)m); X normret; X} X Xerlin() X{ X res.i = elinnumb; X vartype=01; X if(res.i < 0 ){ /* make large linenumbers */ X#ifndef SOFTFP X res.f = (unsigned)elinnumb; X vartype = 0; X#else X overfl=(unsigned)elinnumb; /* into reals as they */ X over(0,&res); /* overflow integers */ X#endif X } X} X Xerval() X{ X res.i =ecode; X vartype=01; X} X Xsgn() X{ X eval(); X#ifdef PORTABLE X if(!vartype){ X if(res.f < 0) X res.i = -1; X else if(res.f > 0) X res.i = 1; X else res.i = 0; X vartype = 1; X return; X } X#endif X if(res.i<0) /* bit twiddling */ X res.i = -1; /* real numbers have the top bit set if */ X else if(res.i>0) /* negative and the top word is non-zero */ X res.i= 1; /* for all non-zero numbers */ X vartype=01; X} X Xabs() X{ X eval(); X#ifdef PORTABLE X if(!vartype){ X if(res.f < 0) X negate(); X return; X } X#endif X if(res.i<0) X negate(); X} X Xlen() X{ X stringeval(gblock); X res.i =gcursiz; X vartype=01; X} X Xascval() X{ X stringeval(gblock); X if(!gcursiz) X error(FUNCT); X res.i = *gblock & 0377; X vartype=01; X} X Xsqrtf() X{ X#ifndef SOFTFP X double sqrt(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifdef PORTABLE X if(res.f < 0) X#else X if(res.i < 0) X#endif X error(37); /* negative square root */ X#ifndef SOFTFP X res.f = sqrt(res.f); X#else X sqrt(&res); X#endif X} X Xlogf() X{ X#ifndef SOFTFP X double log(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifdef PORTABLE X if(res.f <= 0) X#else X if(res.i <= 0) X#endif X error(38); /* bad log value */ X#ifndef SOFTFP X res.f = log(res.f); X#else X log(&res); X#endif X} X Xexpf() X{ X#ifndef SOFTFP X double exp(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifndef SOFTFP X if(res.f > 88.02969) X error(39); X res.f = exp(res.f); X#else X if(!exp(&res)) X error(39); /* overflow in exp */ X#endif X} X Xpii() X{ X#ifndef SOFTFP X res.f = pivalue; X#else X movein(&pivalue,&res); X#endif X vartype=0; X} X X/* X * This routine will deal with the eval() function. It has to do X * a lot of moving of data. to enable it to 'compile' an expression X * so that it can be evaluated. X */ X X Xevalu() X{ X register char *tmp; X char chblck1[256]; X char chblck2[256]; X X checksp(); X if(evallock>5) X error(43); /* mutually recursive eval */ X evallock++; X stringeval(gblock); X gblock[gcursiz]=0; X strcpy(nline,chblck2); /* save nline */ X line[0]='\01'; /* stop a line number being created */ X strcpy(gblock,&line[1]); X compile(0); X strcpy(&nline[1],chblck1); /* restore nline ( eval in immeadiate */ X strcpy(chblck2,nline); /* mode ). */ X tmp=point; X point=chblck1; X eval(); X if(getch()) X error(SYNTAX); X point=tmp; X evallock--; X} X Xffn() X{ X register struct deffn *p; X value ovrs[3]; X value nvrs[3]; X char vttys[3]; X char *spoint; X register int i; X if(!isletter(*point)) X error(SYNTAX); X getnm(); X#ifdef LNAMES X for(p = (deffnp)enames ; p < (deffnp)edefns ; X p = (deffnp)((memp)p + p->offs) ) X#else X for( p = (deffnp)estring ; p < (deffnp)edefns ; X p = (deffnp)((memp)p + p->offs) ) X#endif X if(p->dnm ==nm ) X goto got; X error(UNDEFFN); Xgot: X for(i=0;i<p->narg;i++) /* save values */ X#ifndef V6C X ovrs[i] = *((value *) (p->vargs[i] + earray) ); X#else X movein( (double *)(p->vargs[i] + earray) ,&ovrs[i]); X#endif X if(p->narg){ X if(*point++!='(') X error(SYNTAX); X for(i=0;;){ X eval(); X#ifndef V6C X nvrs[i] = res; X#else X movein(&res,&nvrs[i]); X#endif X vttys[i] = vartype; X if(++i >= p->narg ) X break; X if( getch() != ',' ) X error(SYNTAX); X } X if( getch() != ')' ) X error(SYNTAX); X } /* got arguments in nvrs[] */ X X for(i=0;i<p->narg;i++){ /* put in new values */ X#ifndef V6C X res = nvrs[i]; X#else X movein(&nvrs[i],&res); X#endif X vartype=vttys[i]; X putin((value *)(p->vargs[i] + earray),((p->vtys>>i)&01)); X } X spoint=point; X point=p->exp; X eval(); X for(i=0;i<p->narg;i++) X#ifndef V6C X *( (value *)(p->vargs[i] + earray)) = ovrs[i]; X#else X movein(&ovrs[i], (double *) (p->vargs[i] + earray) ); X#endif X if(getch()) X error(SYNTAX); X point= spoint; X i= p->vtys>>4; X if(vartype != (char)i){ X if(vartype) X cvt(&res); X else if(conv(&res)) X error(INTOVER); X vartype=i; X } X} X X/* int() - return the greatest integer less than x */ X Xintf() X{ X#ifndef SOFTFP X double floor(); X eval(); X if(!vartype) X res.f = floor(res.f); X if(!conv(&res)) X vartype=01; X#else X value temp; X static double ONE = 1.0; X X eval(); X if(vartype) /* conv and integ truncate not round */ X return; X#ifdef PORTABLE X if(res.f>=0){ X#else X if(res.i>=0){ /* positive easy */ X#endif X if(!conv(&res)) X vartype=01; X else integ(&res); X return; X } X#ifndef V6C X temp = res; X#else X movein(&res,&temp); X#endif X integ(&res); X if(cmp(&res,&temp)){ /* not got an integer subtract one */ X#ifndef V6C X res = *((value *)&ONE); X#else X movein(&ONE,&res); X#endif X fsub(&temp,&res); X integ(&res); X } X if(!conv(&res)) X vartype=01; X#endif /* not floating point */ X} X Xpeekf(sp) X{ X register char *p; X#ifndef pdp11 X register long l; X eval(); X if(vartype) X cvt(&res); X l = res.f; X if(res.f > 0x7fff000 || res.f < 0) /* check this */ X error(FUNCT); X p = (char *)l; X#else X eval(); X if(!vartype && conv(&res)) X error(FUNCT); X p= (char *)res.i; /* horrible - fix for a Vax */ X#endif X vartype=01; X if(p>vvend && p < (char *)&sp ) X res.i=0; X else res.i = *p & 0377; X} X Xpoke(sp) /* sp = approx position of stack */ X{ /* can give bus errors */ X#ifndef pdp11 /* why are you poking any way ??? */ X register long l; X#endif X register char *p; X register int i; X eval(); X if(getch()!=',') X error(SYNTAX); X#ifndef pdp11 X if(vartype) X cvt(&res); X l = res.f; X if(res.f > 0x7fff000 || res.f < 0) /* check this */ X error(FUNCT); X p = (char *)l; X#else X if(!vartype && conv(&res)) X error(FUNCT); X p= (char *)res.i; X#endif X i= evalint(); X check(); X if(i<0) X error(FUNCT); X if(p< vvend || p > (char *)&sp) X *p = i; X normret; X} X Xsinf() X{ X#ifndef SOFTFP X double sin(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifndef SOFTFP X res.f = sin(res.f); X#else X sin(&res); X#endif X} X Xcosf() X{ X#ifndef SOFTFP X double cos(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifndef SOFTFP X res.f = cos(res.f); X#else X cos(&res); X#endif X} X Xatanf() X{ X#ifndef SOFTFP X double atan(); X#endif X eval(); X if(vartype) X cvt(&res); X vartype=0; X#ifndef SOFTFP X res.f = atan(res.f); X#else X atan(&res); X#endif X} X X/* X * the "system" function, returns the status of the command it executes X */ X X Xssystem() X{ X register int i; X register int (*q)() , (*p)(); X int (*signal())(); X char *s; X int status; X#ifdef SIGTSTP X int (*t)(); X#endif X X stringeval(gblock); /* get the command */ X gblock[gcursiz] = 0; X X flushall(); X#ifdef SIGTSTP X t = signal(SIGTSTP, SIG_DFL); X#endif X#ifdef VFORK X i = vfork(); X#else X i=fork(); X#endif X if(i==0){ X rset_term(1); X setuid(getuid()); /* stop user getting clever */ X#ifdef V7 X s = getenv("SHELL"); X if(!s || !*s) X s = "/bin/sh"; X#else X s = "/bin/sh"; X#endif X execl(s, "sh (from basic)", "-c", gblock, 0); X exit(-1); /* problem */ X } X if(i != -1){ X p=signal(SIGINT,SIG_IGN); /* ignore some signals */ X q=signal(SIGQUIT, SIG_IGN); X while(i != wait(&status) ); /* wait on the 'child' */ X signal(SIGINT,p); /* resignal to what they */ X signal(SIGQUIT,q); /* were before */ X /* in a mode fit for basic */ X set_term(); /* reset terminal modes */ X rset_term(0); X i = status; X } X#ifdef SIGTSTP X signal(SIGTSTP, t); X#endif X vartype = 1; X res.i = i; X} End of bas3.c chmod u=rw-,g=r,o=r bas3.c echo x - bas4.c 1>&2 sed 's/^X//' > bas4.c << 'End of bas4.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * Stringeval() will evaluate a string expression of any X * form. '+' is used as the concatenation operator X * X * gblock and gcursiz are used as global variables by the X * string routines. Gblock contains the resultant string while X * gcursiz holds the length of the resultant string ( even if not X * put in gblock ). X * For routines that need more than one result e.g. mid$ instr$ X * then one result at least is put on the stack while the other X * ( possibly ) is put in gblock. X */ X X/* X * The parameter to stringeval() is a pointer to where the X * result will be put. X */ X X Xstringeval(gblck) Xchar *gblck; X{ X int cursiz=0; X memp l; X int c; X char charac; X register char *p,*q; X register int i; X int m[2]; X char chblock[256]; X char *ctime(); X checksp(); X q=chblock; Xfor(;;){ X gcursiz=0; X c=getch(); X if(c&0200){ /* a string function */ X if(c==DATE){ /* date does not want a parameter */ X time(m); X p=ctime(m); X gcursiz=24; X } X else { X if(c<MINSTRING || c>MAXSTRING) X error(11); X if(*point++!='(') X error(1); X (*strngcommand[c-MINSTRING])(); X if(getch()!=')') X error(1); X p=gblock; /* string functions return with */ X } /* result in gblock */ X } X else if(c=='"' || c=='`'){ /* a quoted string */ X charac=c; X p=point; X while(*point && *point!= charac){ X gcursiz++; X point++; X } X if(*point) X point++; X } X else if(isletter(c)){ /* a string variable */ X point--; X l=getname(); X if(vartype!=02) X error(SYNTAX); X if(p= ((stdatap)l)->stpt) /* newstring routines */ X gcursiz= *p++ &0377; X } X else X error(SYNTAX); X /* all routines return to here with the string pointed to by p */ X if(cursiz+gcursiz>255) X error(9); X i=gcursiz; X if(getch()!='+') X break; X cursiz += i; X if(i) do X *q++ = *p++; X while(--i); X } X point--; /* the following code is */ X if(!cursiz){ /* horrible but it speeds */ X if(p==gblck) /* execution by reducing the amount */ X return; /* of movement of strings */ X cursiz=gcursiz; X } X else { X cursiz+=gcursiz; X if(i) do X *q++ = *p++; X while(--i); X p=chblock; X } X q=gblck; X gcursiz=cursiz; X if(i=cursiz) X do X *q++ = *p++; X while(--i); X} X X/* X * stringassign() will put the sting in gblock into the string X * pointed to by p. X * It will call the garbage collection routine as neccasary. X */ X Xstringassign(p) Xstruct stdata *p; X{ X register char *q,*r; X register int i; X X p->stpt=0; X if(!gcursiz) X return; X if(estdt-eostring <gcursiz+1){ X garbage(); X if(estdt-eostring <gcursiz+1) X error(3); /* out of string space */ X } X p->stpt=eostring; X q=eostring; X i=gcursiz; X *q++ = i; X r= gblock; X do X *q++ = *r++; X while(--i); X eostring=q; X} X X/* X * This will collect all unused strings and free the space X * It works that is about all tha can be said for it. X */ X Xgarbage() /* new string routine */ X{ X register char *p,*q; X register struct stdata *r; X register int j; X X p=ecore; X q=ecore; X while(p<eostring){ X j= (*p&0377)+1; X for(r = (stdatap)estdt ; r < (stdatap)estring ; r++) X if(r->stpt==p) X if(q==p){ X p+=j; X q=p; X goto more; X } X else { X r->stpt=q; X do{ X *q++ = *p++; X }while(--j); X goto more; X } X p+=j; Xmore: ; X } X eostring=q; X} X X/* X * The following routines implement string functions they are all quite X * straight forward in operation. X */ X Xstrng() X{ X int m; X register char *q,*p; X int cursiz=0; X int siz; X register int i; X char chblock[256]; X X checksp(); X stringeval(chblock); X cursiz=gcursiz; X if(getch()!=',') X error(1); X m=evalint(); X if(m>255 || m <0) X error(10); X if(!cursiz){ X gcursiz=0; X return; X } X siz=m; X if((unsigned)(cursiz * siz) >255) X error(9); X gcursiz= cursiz *siz; X p=gblock; X while(siz--) X for(q=chblock,i=cursiz;i--;) X *p++ = *q++; X} X X/* left$ string function */ X Xleftst() X{ X int l1; X register int i; X register char *p,*q; X int cursiz; X char chblock[256]; X X checksp(); X stringeval(chblock); X cursiz=gcursiz; X if(getch()!=',') X error(SYNTAX); X l1=evalint(); X if(l1<0 || l1 >255) X error(10); X i=l1; X if(l1>cursiz) X i=cursiz; X p=chblock; X q=gblock; X if(gcursiz=i) do X *q++ = *p++; X while(--i); X} X X/* right$ string function */ X Xrightst() X{ X int l1,l2; X register int i; X register char *p,*q; X int cursiz; X char chblock[256]; X X checksp(); X stringeval(chblock); X cursiz=gcursiz; X if(getch()!=',') X error(SYNTAX); X l1=evalint(); X if(l1<0 || l1 >255) X error(10); X l2= cursiz-l1; X i=l1; X if(i>cursiz){ X i=cursiz; X l2=0; X } X p= &chblock[l2]; X q= gblock; X if(gcursiz=i) do X *q++ = *p++; X while(--i); X} X X/* X * midst$ string function:- X * can have two or three parameters , if third X * parameter is missing then a value of cursiz X * is used. X */ X Xmidst() X{ X int l1,l2; X int cursiz; X register int i; X register char *q,*p; X char chblock[256]; X X checksp(); X stringeval(chblock); X cursiz=gcursiz; X if(getch()!=',') X error(1); X l1=evalint()-1; X if(getch()!=','){ X point--; X l2=255; X } X else X l2=evalint(); X if(l1<0 || l2<0 || l1 >255 || l2 >255) X error(10); X l2+=l1; X if(l2>cursiz) X l2=cursiz; X if(l1>cursiz) X l1=cursiz; X i= l2-l1; X p=gblock; X q= &chblock[l1]; X if(gcursiz=i) do X *p++ = *q++; X while(--i); X} X X/* ermsg$ string routine , returns the specified error message */ X Xestrng() X{ X register char *p,*q,*r; X int l; X X l=evalint(); X if(l<1 || l> MAXERR) X error(22); X p=ermesg[l-1]; X q=gblock; X r=p; X while(*q++ = *p++); X gcursiz= p-r-1; X} X X/* chr$ string function , returns character from the ascii value */ X Xchrstr() X{ X register int i; X X i=evalint(); X if(i<0 || i>255) X error(FUNCT); X *gblock= i; X gcursiz=1; X} X X/* str$ string routine , returns a string representation X * of the number given. There is NO leading space on positive X * numbers. X */ X Xnstrng() X{ X register char *p,*q; X X eval(); X gcvt(); X if(*gblock!=' ') X return; X q=gblock; X p= gblock+1; X while(*q++ = *p++); X gcursiz= --q -gblock; X} X X/* val() maths function , returns the value of a string. If X * no numeric value is used then a value of zero is returned. X */ X Xval() X{ X register char *tmp,*p; X register minus=0; X X stringeval(gblock); X gblock[gcursiz]=0; X p=gblock; X while(*p++ == ' '); X if(*--p=='-'){ X p++; X minus++; X } X if(!isnumber(*p) && *p!='.'){ X res.i=0; X vartype=01; X return; X } X tmp=point; X point=p; X if(!getop()){ X point=tmp; X error(36); X } X point=tmp; X if(minus) X negate(); X} X X/* instr() maths function , returns the index of the first string X * in the second. Starting either from the first character or from X * the optional third parameter position. X */ X Xinstr() X{ X int cursiz1; X int cursiz2; X register char *p,*q,*r; X int i=0; X char chbl1ck[256]; X char chbl2ck[256]; X X checksp(); X stringeval(chbl1ck); X cursiz1=gcursiz; X if(getch()!=',') X error(SYNTAX); X stringeval(chbl2ck); X cursiz2=gcursiz; X if(getch()==','){ X i=evalint()-1; X if(i<0 || i>255) X error(10); X } X else X point--; X cursiz2-=cursiz1; X vartype=01; X r= &chbl2ck[cursiz1+i]; X for(;i<=cursiz2;i++,r++){ X p= chbl1ck; X q= &chbl2ck[i]; X while(q < r && *p== *q) X p++,q++; X if( q == r ){ X res.i = i+1; X return; X } X } X res.i = 0; X} X X/* space$ string function returns a string of spaces the number X * of which is the argument to the function X */ X Xspace() X{ X register int i; X register char *q; X X i=evalint(); X if(i<0 || i>255) X error(10); X if(gcursiz=i){ X q= gblock; X do{ X *q++ =' '; X }while(--i); X } X} X X/* get$() read a single character from a file */ X Xgetstf() X{ X register struct filebuf *p; X register i; X X i=evalint(); X if(!i){ X if(noedit) /* illegal function with silly terminals */ X error(11); X if(!trapped){ X set_term(); X *gblock=readc(); X rset_term(0); X } X if(!trapped) X gcursiz=1; X else X gcursiz =0; X } X else { X p=getf(i,_READ); X if(!(i = filein(p,gblock,1)) ) X error(30); X gcursiz=i; X } X} X X X/* mid$() when on the left of an assignment */ X/* can have optional third argument */ X X/* a$ = "this is me" X * mid$(a$,2) = "hello" -> a$ = "thello" X * mid$(a$,2,5) = "hello" -> a$ = "thellos me" X */ X Xlhmidst() X{ X char chbl1ck[256]; X char chbl2ck[256]; X int cursiz,rhside,i1,i2; X memp pt; X register char *p,*q; X register int i; X X if(*point++ !='(') X error(SYNTAX); X pt=getname(); X if(vartype!=02) X error(VARREQD); X if(getch()!=',') X error(SYNTAX); X i1=evalint()-1; X if(getch()!=','){ X i2=255; X point--; X } X else X i2= evalint(); X if(i2<0 || i2>255 || i1<0 || i1>255) X error(10); X if(getch()!=')' ) X error(SYNTAX); X if(getch()!='=') X error(4); X cursiz=0; X if(p= ((stdatap)pt)->stpt){ X cursiz=i= *p++ & 0377; X q=chbl1ck; X do{ X *q++ = *p++; X }while(--i); X } X if(i1>cursiz) X i1=cursiz; X i2+=i1; X if(i2>cursiz) X i2=cursiz; X rhside= cursiz -i2; X if(i=rhside){ X p=chbl2ck; X q= &chbl1ck[i2]; X do{ X *p++ = *q++; X }while(--i); X } X stringeval(gblock); X check(); X if(gcursiz+rhside+i1>255) X error(9); X p= &chbl1ck[i1]; X q= gblock; X if(i=gcursiz) X do{ /* what a lot of data movement */ X *p++ = *q++; X }while(--i); X gcursiz+=i1; X q=chbl2ck; X if(i=rhside) X do{ X *p++ = *q++; X }while(--i); X gcursiz+=rhside; X p=gblock; X q=chbl1ck; X if(i=gcursiz) X do{ X *p++ = *q++; X }while(--i); X stringassign( (stdatap)pt ); /* done it !! */ X normret; X} X X#ifdef _BLOCKED X X/* mkint(a$) X * routine to make the first 2 bytes of string into a integer X * for use with formatted files. X */ X Xmkint() X{ X register short *p = (short *)gblock; X stringeval(gblock); X if(gcursiz < sizeof(short) ) X error(10); X res.i = *p; X vartype = 01; X} X X/* ditto for string to double */ X Xmkdouble() X{ X stringeval(gblock); X if(gcursiz < sizeof(double) ) X error(10); X#ifndef V6C X res = *( (value *)gblock); X#else X movein(gblock,&res); X#endif X vartype = 0; X} X X/* X * mkistr$(x%) X * convert an integer into a string for use with disk files X */ X Xmkistr() X{ X register short *p = (short *)gblock; X eval(); X if(!vartype && conv(&res)) X error(FUNCT); X *p = res.i; X gcursiz = sizeof(short); X} X X/* mkdstr$(x) X * ditto for doubles. X */ X Xmkdstr() X{ X eval(); X if(vartype) X cvt(&res); X#ifndef V6C X *((value *)gblock) = res; X#else X movein(&res,gblock); X#endif X gcursiz = sizeof(double); X} X#else Xmkdstr(){} Xmkistr(){} Xmkint(){} Xmkdouble(){} X#endif End of bas4.c chmod u=rw-,g=r,o=r bas4.c echo x - bas5.c 1>&2 sed 's/^X//' > bas5.c << 'End of bas5.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * This file contains the routines for input and read since they X * do almost the same they can use a lot of common code. X */ X X/* X * input can have a text string, which it outputs as a prompt X * instead of the usual '?'. If input is from a file this X * facility is not permitted ( what use anyway ? ). X * X * added 28-oct-81 X */ X Xinput() X{ X register char *p; X register int i; X memp l; X register filebufp infile=0; X char lblock[512]; X int firsttime=0; X int c; X char vty; X char *getstrdt(),*getdata(); X X c=getch(); X if(c=='"'){ X i=0; X p=line; X while(*point && *point != '"'){ X *p++ = *point++; X i++; X } X if(*point) X point++; X if(getch()!=';') X error(SYNTAX); X *p=0; X firsttime++; X } X else if(c=='#'){ X i=evalint(); X if(getch()!=',') X error(SYNTAX); X infile=getf(i,_READ); X } X else X point--; X l=getname(); X vty=vartype; Xfor(;;){ X if(!infile){ X if(!firsttime){ X *line='?'; X i=1; X } X firsttime=0; X edit(i,i,i); X if(trapped){ X point=savepoint; /* restore point to start of in. */ X return(-1); /* will trap at start of this in. */ X } X strcpy(&line[i],lblock); X } X else if(! filein(infile,lblock,512) ) X error(30); X p= lblock; Xex3: while(*p++ ==' '); /* ignore leading spaces */ X if(!*--p && vty!=02) X continue; X p= ((vty==02)?(getstrdt(p)) :( getdata(p))); X if(p){ X while(*p++ == ' '); X p--; X } X if(!p || (*p!=',' && *p)){ X if(infile) X error(26); X prints("Bad data redo\n"); X continue; X } X if(vartype == 02) X stringassign( (stdatap)l ); X else X putin(l,vty); X if(getch()!=',') X break; X l=getname(); X vty=vartype; X if(*p==','){ X p++; X goto ex3; X } X } X point--; X normret; X} X X/* valid types for string input :- X * open quote followed by any character until another quote or the end of line X * no quote followed by a sequence of characters except a quote X * terminated by a comma (or end of line). X */ X X/* the next two routines return zero on error and a pointer to X * rest of string on success. X */ X X/* read string data routine */ X Xchar * Xgetstrdt(p) Xregister char *p; X{ X register char *q; X register int cursiz=0; X char charac; X X q=gblock; X if(*p=='"' || *p=='`' ){ X charac= *p++; X while(*p!= charac && *p ){ X *q++ = *p++; X if(++cursiz>255) X return(0); X } X if(*p) X p++; X gcursiz=cursiz; X return(p); X } X while( *p && *p!=',' && *p!='"' && *p!='`'){ X *q++ = *p++; X if(++cursiz>255) X return(0); X } X gcursiz=cursiz; X return(p); X} X X/* read number routine */ X Xchar * Xgetdata(p) Xregister char *p; X{ X register char *tmp; X register int minus=0; X if(*p=='-'){ X p++; X minus++; X } X if(!isnumber(*p) && *p!='.') X return(0); X tmp=point; X point=p; X if(!getop()){ X point=tmp; X return(0); X } X p=point; X point=tmp; X if(minus) X negate(); X return(p); X} X X/* input a whole line of text (into a string ) */ X Xlinput() X{ X X register char *p; X register int i; X memp l; X register filebufp infile; X char lblock[512]; X int c; X X c=getch(); X if(c=='#'){ X i=evalint(); X if(getch()!=',') X error(SYNTAX); X infile=getf(i,_READ); X l=getname(); X if(vartype!=02) X error(VARREQD); X check(); X if(!(i= filein(infile,lblock,512)) ) X error(30); X if(i>255) X error(9); X p=strcpy(lblock,gblock); X } X else { X if(c=='"'){ X i=0; X p=line; X while(*point && *point != '"'){ X *p++ = *point++; X i++; X } X if(*point) X point++; X if(getch()!=';') X error(SYNTAX); X *p=0; X } X else { X point--; X *line='?'; X i=1; X } X l=getname(); X if(vartype!=02) X error(VARREQD); X check(); X edit(i,i,i); X if(trapped){ X point=savepoint; /* restore point to start of in. */ X return(-1); /* will trap at start of this in. */ X } X p=strcpy(&line[i],gblock); X } X gcursiz= p-gblock; X stringassign( (stdatap)l ); X normret; X} X X/* read added 3-12-81 */ X X/* X * Read routine this should :- X * get variable then search for data then assign it X * repeating until end of command X * ( The easy bit. ) X */ X X/* X * Getting data :- X * if the data pointer points to anywhere then it points to a line X * to a point where getch would get an end of line or the next data item X * at the end of a line a null string must be implemented as X * a pair of quotes i.e. "" , on inputing data '"'`s are significant X * this is no problem normally . X * If the read routine finds an end of line then there is bad data X * X */ X Xreadd() X{ X register memp l; X register char *p; X register char vty; X if(!datapoint) X getmore(); X for(;;){ X l=getname(); X vty=vartype; X p= datapoint; X while(*p++ == ' '); X datapoint= --p; X if(!*p){ X getmore(); X p=datapoint; X while(*p++ ==' '); X p--; X } X /* get here the next thing should be a data item or an error */ X datapoint=p; X if(!*p) X error(BADDATA); X p= ((vty==02)?(getstrdt(p)) :( getdata(p))); X if(!p) X error(BADDATA); X while(*p++ == ' '); X p--; X if(*p!=',' && *p) X error(BADDATA); X if(vty == 02) X stringassign( (stdatap)l ); X else putin(l,vty); X if(*p) X p++; X datapoint=p; X if(getch()!=',') X break; X } X point--; X normret; X} X X/* X * This is only called when datapoint is at the end of the line X * it is also called if datapoint is zero e.g. when this is the first call X * to read. X */ X Xgetmore() X{ X register lpoint p; X register char *q; X if(!datapoint) X p = (lpoint)fendcore; X else { X p=datastolin; X if(p->linnumb) X p = (lpoint)((memp)p + lenv(p)); X } X for(;p->linnumb; p = (lpoint)((memp)p + lenv(p)) ){ X q=p->lin; X while(*q++ == ' '); X if(*--q == (char)DATA){ X datapoint= ++q; X datastolin=p; X return; X } X } X datastolin=p; X error(OUTOFDATA); X} X X/* the 'data' command it just checks things and sets up pointers X * as neccasary. X */ X Xdodata() X{ X register char *p; X if(runmode){ X p=stocurlin->lin; X while(*p++ ==' '); X if(*--p != (char) DATA) X error(BADDATA); X if(!datapoint){ X datastolin= stocurlin; X datapoint= ++p; X } X } X return(GTO); /* ignore rest of line */ X} X X/* the 'restore' command , will reset the data pointer to X * the first bit of data it finds or to the start of the program X * if it doesn't find any. It will start searching from a line if X * tthat line is given as an optional parameter X */ X Xrestore() X{ X register unsigned i; X register lpoint p; X register char *q; X X i=getlin(); X check(); X p= (lpoint)fendcore; X if(i!= (unsigned)(-1) ){ X for(;p->linnumb; p = (lpoint)( (memp)p + lenv(p)) ) X if(p->linnumb== i) X goto got; X error(6); X } Xgot: datapoint=0; X for(;p->linnumb; p = (lpoint)((memp)p + lenv(p)) ){ X q= p->lin; X while(*q++ ==' '); X if(*--q == (char)DATA){ X datapoint= ++q; X break; X } X } X datastolin= p; X normret; X} End of bas5.c chmod u=rw-,g=r,o=r bas5.c echo x - bas6.c 1>&2 sed 's/^X//' > bas6.c << 'End of bas6.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X#ifdef V7 X#include <sys/ioctl.h> X#endif X X/* X * This file contains all the routines to implement terminal X * like files. X */ X X/* X * setupfiles is called only once, it finds out how many files are X * required and allocates buffers for them. It will also execute X * 'silly' programs that are given as parameters. X */ X Xsetupfiles(argc,argv) Xchar **argv; X{ X register int fp; X register int nfiles=2; X register struct filebuf *p; X char *q; X extern memp sbrk(); X X#ifdef NOEDIT X noedit=1; X#endif X while(argc > 1 ){ X q = *++argv; X if(*q++ !='-') X break; X if(isnumber(*q)){ X nfiles= atoi(q); X if(nfiles<0 || nfiles > MAXFILES) X nfiles=2; X } X else if(*q=='x') X noedit=1; X else if(*q=='e') X noedit=0; X argc--; X } X filestart= sbrk(0); X fendcore= filestart+(sizeof(struct filebuf) * nfiles); X brk(fendcore+sizeof(xlinnumb) ); /* allocate enough core */ X for(p = (filebufp)filestart ; p < (filebufp)fendcore ; p++){ X p->filedes=0; X p->userfiledes=0; X p->use=0; X p->nleft=0; X } X /* code added to execute silly programs */ X if(argc <= 1) X return; X if((fp=open(*argv,0))!=-1) X runfile(fp); X prints("file not found\n"); X _exit(1); X} X X/* X * This routine executes silly programs. It has to load up X * the program and then simulate the environment as is usually seen X * in main. It works.... X */ X Xrunfile(fp) X{ X int firsttime; X register lpoint p; X X setupterm(); /* set up terminal - now done after files */ X ecore= fendcore+sizeof(xlinnumb); X ( (lpoint) fendcore )->linnumb=0; X firsttime=1; /* flag to say that we are just loading */ X setexit(); /* the file at the moment */ X if(ertrap) /* setexit is the return for error */ X goto execut; /* and execute */ X if(!firsttime) /* an error or cntrl-c */ X quit(); X firsttime=0; X readfi(fp); X clear(DEFAULTSTRING); X p= (lpoint)fendcore; X stocurlin=p; X if(!(curline=p->linnumb)) /* is this needed - yes */ X quit(); X point= p->lin; X elsecount=0; X runmode=1; /* go and run it */ Xexecut: X execute(); X} X X/* commands implemented are :- X open / creat X close X input X print X*/ X X/* syntax of commands :- X open "filename" for input as <filedesc> X open "filename" [for output] as <filedesc> X close <filedesc> ,[<filedesc>] X input #<filedesc> , v1 , v2 , v3 .... X print #<filedesc> , v1 , v2 , v3 .... X */ X X/* format of file buffers added 17-12-81 X struct { X int filedes; / * Unix file descriptor X int userfiledes; / * name by which it is used X int posn; / * position of cursor in file X int dev; / * dev and inode are used to X int inode; / * stop r/w to same file X int use; / * r/w etc. + other info X int nleft; / * number of characters in buffer X char buf[BLOCKSIZ]; / * the actual buffer X } file_buffer ; X X The file_buffers are stored between the end of initialised data X and fendcore. uses sbrk() at start up. X X At start up there are two buffer spaces allocated. X*/ X X/* X * The 'open' command it allocates file descriptors and buffer X * space then sets about opening the file and checking weather the X * the file is opened already and then checks to see if that file X * was opened for reading or writing. It stops files being read and X * written at the same time X */ X Xfopen() X{ X char chblock[256]; X register struct filebuf *p; X register struct filebuf *q; X register int c; X int i; X int append=0; X int bl = 0; X int mode= _READ; X struct stat inod; X X stringeval(chblock); X chblock[gcursiz]=0; X c=getch(); X if(c== FOR){ X c=getch(); X if(c== OUTPUT) X mode = _WRITE; X else if(c== APPEND){ X append++; X mode = _WRITE; X } X else if(c== TERMINAL) X mode = _TERMINAL; X else if(c != INPUT) X error(SYNTAX); X c=getch(); X } X if(c!= AS) X error(SYNTAX); X i=evalint(); X#ifdef _BLOCKED X if(getch() == ','){ X bl = evalint(); X if(bl <= 0 || bl > 255) X error(10); X } X else X point--; X#endif X check(); X X/* here we have mode set. i is the file descriptor 1-9 X now check to see if already allocated then allocate the descriptor X and open file etc. */ X X if(i<1 || i>MAXFILES) X error(29); X for(q=0,p = (filebufp)filestart ; p < (filebufp)fendcore ; p++){ X if(i== p->userfiledes) X error(29); X else if(!p->userfiledes && !q) X q=p; X } X if(!(p=q)) /* out of file descriptors */ X error(31); X X/* code to check to see if file is open twice */ X X if(stat(chblock,&inod)!= -1){ X if( (inod.st_mode & S_IFMT) == S_IFDIR) X if(mode== _READ ) /* cannot deal with directories */ X error(15); X else X error(14); X for(q = (filebufp)filestart ; q < (filebufp)fendcore ; q++) X if(q->userfiledes && q->inodnumber== inod.st_ino && X q->device== inod.st_dev){ X if(mode== _READ ){ X if( q->use & mode ) X break; X error(15); X } X else X error(14); X } X } X else if(mode == _TERMINAL) /* terminals */ X error(15); X if(mode == _READ){ X if( (p->filedes=open(chblock,0))== -1) X error(15); X } X else if(mode == _TERMINAL){ X#ifdef _BLOCKED /* can't block terminals */ X if(bl) X error(15); X#endif X if((p->filedes = open(chblock,2)) == -1) X error(15); X mode |= _READ | _WRITE; X } X else { X if(append){ X p->filedes=open(chblock,1); X#ifndef V6C X lseek(p->filedes, 0L, 2); X#else X seek(p->filedes,0,2); X#endif X } X if(!append || p->filedes== -1) X if((p->filedes=creat(chblock,0644))== -1) X error(14); X } X p->posn = 0; X fstat(p->filedes,&inod); X#ifdef V7 X ioctl(p->filedes,FIOCLEX,0); /* close on exec */ X#endif X p->device= inod.st_dev; /* fill in all relevent details */ X p->inodnumber= inod.st_ino; X p->userfiledes= i; X#ifdef _BLOCKED X if(bl){ X p->blocksiz = bl; X mode |= _BLOCKED; X } X#endif X p->nleft=0; X p->use=mode; X normret; X} X X/* the 'close' command it runs through the list of file descriptors X * and flushes all buffers and closes the file and clears all X * relevent entry in the structure X */ X Xfclosef() X{ X register struct filebuf *p; X for(;;){ X p=getf(evalint(),(_READ | _WRITE) ); X if(p->use & _WRITE ) X f_flush(p); X close(p->filedes); X p->filedes=0; X p->userfiledes=0; X p->nleft=0; X p->use=0; X if(getch()!=',') X break; X } X point--; X normret; X} X X/* the 'seek' command thought to be neccasary X */ X Xfseek() X{ X register struct filebuf *p; X register int j; X register long l; X X if(getch() != '#') X error(SYNTAX); X p = getf(evalint(),(_READ | _WRITE)); /* get file */ X if(getch() != ',') X error(SYNTAX); X eval(); X if(getch() != ',') X error(SYNTAX); X if(!vartype && conv(&res)) X error(FUNCT); X#ifdef _BLOCKED X if(p->use & _BLOCKED) X#ifndef pdp11 X l = res.i * p->blocksiz; X#else X { register k = 0; /* fast multiply for non */ X for(l = 0 ; k < 8 ; k++) /* vax systems. this */ X if(p->blocksiz & (1<<k) ) /* won't bring in the */ X l += (long)res.i << k; /* library */ X } X#endif X else /* watch this. note the indents */ X#endif /* it is right */ X l = res.i; X j = evalint(); X check(); X if(j < 0 || j > 5) /* out of range */ X error(FUNCT); X if(p->use & _WRITE) /* flush out all buffered output */ X f_flush(p); X if(j >=3){ X j -= 3; X l <<= 10; /* blocks are 1024 */ X } X#ifndef V6C X lseek(p->filedes, l ,j); X#else X if(l > 512) X seek(p->filedes, (int)(l >> 9) , j + 3); X seek(p->filedes,(int)l & 0777 ,j); X#endif X p->posn = 0; X p->nleft = 0; X p->use &= ~_EOF; X normret; X} X X X/* the 'eof' maths function eof is true if writting to the file X * or if the _EOF flag is set. X */ X Xeofl() X{ X register struct filebuf *p; X X p=getf(evalint(),(_READ | _WRITE) ); X vartype=01; X if( p->use & ( _EOF | _WRITE) ){ X res.i = -1; X return; X } X if(!p->nleft){ X p->posn = 0; X if( (p->nleft= read(p->filedes,p->buf,BLOCKSIZ)) <= 0){ X p->nleft=0; X p->use |= _EOF; X res.i = -1; X return; X } X } X res.i =0; X} X X/* the 'posn' maths function returns the current 'virtual' cursor X * in the file. If the file descriptor is zero then the screen X * cursor is accessed. X */ X Xfposn() X{ X register struct filebuf *p; X register i; X X i=evalint(); X vartype=01; X if(!i){ X res.i =cursor; X return; X } X p=getf(i,(_READ | _WRITE) ); X if(p->use & _WRITE) X res.i = p->posn; X else X res.i = 0; X} X X/* getf() returns a pointer to a file buffer structure. with the X * relevent file descriptor and with the relevent access permissions X */ X Xstruct filebuf * Xgetf(i,j) Xregister i; /* file descriptor */ Xregister j; /* access permission */ X{ X register struct filebuf *p; X X if(i == 0) X error(29); X j &= ( _READ | _WRITE ) ; X for(p= (filebufp)filestart ; p < (filebufp)fendcore ; p++) X if(p->userfiledes==i && ( p->use & j) ) X return(p); X error(29); /* unknown file descriptor */ X} X X/* flushes the file pointed to by p */ X Xf_flush(p) Xregister struct filebuf *p; X{ X if(p->nleft ){ X write(p->filedes,p->buf,p->nleft); X p->nleft=0; X } X} X X/* will flush all files , for use in 'shell' and in quit */ X Xflushall() X{ X register struct filebuf *p; X for(p = (filebufp)filestart ; p < (filebufp)fendcore ; p++) X if(p->nleft && ( p->use & _WRITE ) ){ X write(p->filedes,p->buf,p->nleft); X p->nleft=0; X } X} X X/* closes all files and clears the relevent bits of info X * used in clear and new. X */ X Xcloseall() X{ X register struct filebuf *p; X flushall(); X for(p= (filebufp)filestart ; p < (filebufp)fendcore ; p++) X if(p->userfiledes){ X close(p->filedes); X p->filedes=0; X p->userfiledes=0; X p->nleft=0; X p->use=0; X } X} X X/* write to a file , same as write in parameters (see print ) X */ X Xputfile(p,q,i) Xregister struct filebuf *p; Xregister char *q; Xint i; X{ X register char *r; X if(!i) X return; X r= &p->buf[p->nleft]; X do{ X if(p->nleft >= BLOCKSIZ ){ X f_flush(p); X r= p->buf; X } X *r++ = *q++; X p->nleft++; X }while(--i); X if(p->use & _TERMINAL) X f_flush(p); X} X X/* gets a line into q (MAX 512 or j) from file p terminating with '\n' X * or _EOF returns number of characters read. X */ X Xfilein(p,q,j) Xregister struct filebuf *p; Xregister char *q; X{ X register char *r; X register int i=0; X X if(p->use & _TERMINAL) /* kludge for terminal files */ X p->use &= ~_EOF; X else if(p->use & _EOF) X return(0); /* end of file */ X#ifdef _BLOCKED X if(p->use & _BLOCKED) X j = p->blocksiz; X#endif X r= &p->buf[p->posn]; X for(;;){ X if(!p->nleft){ X r=p->buf; X if( (p->nleft= read(p->filedes,p->buf,BLOCKSIZ)) <=0){ X p->nleft=0; /* a read error */ X p->use |= _EOF; /* or end of file */ X break; X } X } X *q= *r++; X p->nleft--; X if(++i == j){ X q++; X break; X } X#ifdef _BLOCKED X if(*q++ == '\n' && !(p->use & _BLOCKED) ){ X#else X if(*q++ =='\n'){ X#endif X q--; X break; X } X if(i>=512){ /* problems */ X p->posn= r - p->buf; X error(32); X } X } /* end of for loop */ X *q=0; X if(p->use & _TERMINAL){ X p->nleft = 0; X p->posn = 0; X } X else X p->posn = r - p->buf; X#ifdef _BLOCKED X if( (p->use & _BLOCKED) && j != i){ X p->use |= _EOF; X p->nleft = 0; X return(0); X } X#endif X return(i); X} End of bas6.c chmod u=rw-,g=r,o=r bas6.c