v07i074: A BASIC Interpreter, Part02/06
sources-request at mirror.UUCP
sources-request at mirror.UUCP
Fri Dec 5 01:26:53 AEST 1986
Submitted by: phil at 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
More information about the Mod.sources
mailing list