sources-request@mirror.UUCP (12/04/86)
Submitted by: phil@Cs.Ucl.AC.UK Mod.sources: Volume 7, Issue 75 Archive-name: basic/Part03 # Shar file shar03 (of 6) # # This is a shell archive containing the following files :- # bas7.c # bas8.c # bas9.c # gen # ------------------------------ # 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 - bas7.c 1>&2 sed 's/^X//' > bas7.c << 'End of bas7.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X#define COMPILE X#include "cursor.c" X#undef COMPILE X X/* X * this file conatins the user interface e.g. the line editor X */ X X#define PADC 0400 /* the character output for padding */ X /* more than 0377 but can still be passed to putc */ X X/* read a single character */ X Xreadc() X{ X char c=RETURN; X X#ifdef BSD42 X if(!setjmp(ecall)){ X ecalling = 1; X if(!read(0,&c,1)){ X ecalling = 0; X quit(); X } X ecalling = 0; X } X#else X if(!read(0,&c,1)) /* reading from a pipe exit on eof */ X quit(); X#endif X return(c&0177); X} X X/* sets up the terminal structures so that the editor is in rare X * with no paging or line boundries and no echo X * Also sets up the user modes so that they are sensible when X * we exit. ( friendly ). X */ X Xsetupterm() X{ X set_cap(); X setu_term(); X} X X X/* the actual editor pretty straight forward but.. */ X Xedit(fl,fi,fc) X{ X register int cursr; X register char *q; X register char *p; X int c; X int quitf=0; /* say we have finished the edit */ X int special; X int lastc; X int inschar =1; X X set_term(); X for(p= &line[fi]; p<= &line[MAXLIN] ;) X *p++ = ' '; X *p=0; X write(1,line,fi); X cursr=fi; X if(noedit){ X for(p= &line[cursr];p< &line[MAXLIN] ; ){ X c=readc(); X if(c=='\n' || trapped) X break; X else if(c >=' ' ) X *p++ =c; X else if(c == ESCAPE) X break; X } X while(c != '\n' && c != ESCAPE && !trapped) X c=readc(); X } X else X do{ X putch(0); /* flush the buffers */ X lastc = lastch(fl); X c=readc(); X if(c >= ' ' && c < '\177'){ X if( cursr < MAXLIN && ( inschar && lastc < MAXLIN || !inschar) ){ X if(cursr < lastc && inschar){ X p= &line[MAXLIN]; X q= p-1; X while(p> &line[cursr]) X *--p= *--q; X if(*o_INSCHAR) X puts(o_INSCHAR); X else X inchar(cursr,lastc,c); X } X putch(c); X line[cursr++]=c; X continue; X } X } X else switch( (c <' ') ? _in_char[c] : _in_char[32] ){ Xcase i_LEFT: X if(cursr==fl) X break; X cursr--; X puts(o_LEFT); X continue; Xcase i_CLEAR: /* control l - redraw */ X puts(o_RETURN); X cursr=lastc; X for(p= line; p< &line[cursr];) X putch(*p++); X deol(cursr); X continue; Xcase i_DELLINE: /* control b - zap line */ X if(cursr==fl && lastc == fl) X break; X puts(o_RETURN); X p=line; X while(p<&line[fl]) X putch(*p++); X deol(cursr); X p= &line[fl]; X while(p<&line[MAXLIN]) X *p++ = ' '; X cursr=fl; X continue; Xcase i_DELCHAR: X if(cursr >= lastc ) X break; X goto rubit; Xcase i_RUBOUT: X if(cursr==fl) X break; X puts(o_LEFT); X cursr--; X if(!inschar) X continue; X rubit: X if(cursr <= lastc ){ X if(*o_DELCHAR) X puts(o_DELCHAR); X p= &line[cursr]; X q= p+1; X while(q < &line[MAXLIN] ) X *p++ = *q++; X *p= ' '; X } X if(!*o_DELCHAR) X delchar(cursr,lastc); X continue; Xcase i_UP: X if(cursr-ter_width< fl) X break; X if(*o_UP) X puts(o_UP); X else for(special = 0; special < ter_width ; special++) X puts(o_LEFT); X cursr -= ter_width; X continue; Xcase i_DOWN1: X if(cursr+ter_width > MAXLIN ) X break; X puts(o_DOWN2); X cursr+=ter_width; X continue; Xcase i_CNTRLD: X if( (c = readc()) >= ' ' || _in_char[c] != i_CNTRLD) X break; X putch(0); X cursor= (cursor+cursr)%ter_width; X quit(); Xcase i_INSCHAR: X inschar = !inschar; X continue; Xcase i_RIGHT: X if(cursr>= MAXLIN) X break; X putch(line[cursr++]); X continue; Xcase i_LLEFT: X if(cursr <= fl) X break; X do{ X puts(o_LEFT); X }while(((--cursr) &07) && cursr > fl); X continue; Xcase i_RRIGHT: X if(cursr>= MAXLIN) X break; X do{ X putch(line[cursr++]); X }while((cursr&07) && cursr < MAXLIN); X continue; Xcase i_DELSOL: /* delete to start of line */ X if(cursr==fl) X break; X special = cursr; X cursr = fl; X goto delit; /* same code as del word almost */ Xcase i_DELWORD: /* control w - del word */ X if(cursr==fl) X break; X special=cursr; X do{ X cursr--; X }while(cursr>fl &&(line[cursr-1]!=' ' || line[cursr]==' ')); X delit: X q= &line[special]; X p= &line[cursr]; X while(q < &line[MAXLIN] ) X *p++ = *q++; X while(p < &line[MAXLIN]){ X puts(o_LEFT); X *p++ = ' '; X if(*o_DELCHAR && --special <= lastc ) X puts(o_DELCHAR); X } X if(!*o_DELCHAR) X delchar(cursr,lastc); X continue; Xcase i_BACKWORD: /* back word */ X if(cursr==fl) X break; X do{ X puts(o_LEFT); X cursr--; X }while(cursr>fl && (line[cursr-1]!=' ' || line[cursr]==' ' )); X continue; Xcase i_NEXTWORD: /* next word */ X if(cursr >= MAXLIN || cursr > lastc || lastc == fl) X break; X do{ X putch(line[cursr++]); X }while(cursr < MAXLIN && cursr <= lastc && X (line[cursr]==' '|| line[cursr-1]!=' ' ) ); X continue; Xcase i_DEOL: X if(cursr >= lastc ) X break; X for(p= &line[cursr];p < &line[MAXLIN];) X *p++ = ' '; X deol(cursr); X continue; Xcase i_ESCAPE: Xcase i_RETURN: Xcase i_DOWN2: X while(cursr< lastc) X putch(line[cursr++]); X puts(o_RETURN); X puts(o_DOWN2); X quitf++; X continue; Xdefault: X break; X } X puts(o_PING); X }while(!quitf && !trapped); X putch(0); X line[lastch(fl)]=0; X/* special characters are dealt with here- null is never returned */ X for(p=line,q=line,special=0;*p;p++){ X if(special){ X special=0; X if(*p>='a' && *p<='~') X *q++ = *p -('a'-1); X else *q++ = *p; X } X else if(*p=='\\') X special++; X else *q++ = *p; X } X *q=0; X cursor=0; X rset_term(0); X return(c); X} X X/* X * put a string out ( using putch ) X */ X Xputs(s) Xregister char *s; X{ X /* X * now cope with padding X */ X if(*s >='0' && *s <= '9'){ X register i = 0; X do{ X i = i * 10 + *s++ -'0'; X }while(*s >= '0' && *s <= '9'); X if(*s == '.') X s++, i++; X if(*s == '*') /* should only affect 1 line */ X s++; X while(i-- > 0) X putch(PADC); X } X while(*s) X putch(*s++); X} X X/* put out a character uses buffere output of up to 256 characters X * It used to use a static buffer but this is a waste of space so X * it now uses gblock as this is never used during an edit. X * A value of zero for the parameter will flush the buffer. X */ X Xputch(c) X{ X static nleft=0; X X if(!c || nleft>=256){ X if(nleft) X write(1,gblock,nleft); X nleft=0; X } X if(!c) X return; X gblock[nleft++]= c; X} X X/* lastch() returns the last character on the line used in the X * editor to see if any more characters can be placed on the line and X * by the redraw key. X */ X Xlastch(f) X{ X register char *p; X register char *q; X p= &line[f]; X q= &line[MAXLIN]; X while(*q==' ' && q>=p) X q--; X return(q-line+1); X} X X/* delete from current cursor position to end of line. */ X Xdeol(cursr) X{ X register cc,i; X if(*o_DEOL){ X puts(o_DEOL); X return; X } X i = ter_width - (cursr % ter_width); X for(cc = i ; cc ; cc--) X putch(' '); X for(; i ; i--) X puts(o_LEFT); X} X X/* delete nchar characters from cursr */ X Xdelchar(cursr,lc) X{ X register char *p; X register char *q; X p = &line[cursr]; X q = &line[lc]; X while(p < q ) X putch(*p++); X q = &line[cursr]; X while(p > q ){ X if( *o_UP && p - q > ter_width ){ X puts(o_UP); X p -= ter_width; X } X else { X p--; X puts(o_LEFT); X } X } X} X X/* display a new character */ X Xinchar(cursr,lastc,c) X{ X register char *p,*q; X p = &line[cursr+1]; X q = &line[lastc+1]; X putch(c); X while(p < q) X putch(*p++); X q = &line[cursr]; X while(p > q ){ X if( *o_UP && p - q > ter_width ){ X puts(o_UP); X p -= ter_width; X } X else { X p--; X puts(o_LEFT); X } X } X} End of bas7.c chmod u=rw-,g=r,o=r bas7.c echo x - bas8.c 1>&2 sed 's/^X//' > bas8.c << 'End of bas8.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * This file contains all the standard commands that are not placed X * anywhere else for any reason. X */ X X/* X * The 'for' command , this is fairly straight forward , but X * the way that the variable is not allowed to be indexed is X * dependent on the layout of variables in core. X * Most of the fiddly bits of code are so that all the variables X * are of the right type (real / integer ). The code for putting X * a '1' in the step for default cases is not very good and could be X * improved. X * A variable is accessed by its displacement from 'earray' X * it is this index that speeds execution ( no need to search through X * the variables for a name ) and that enables the next routine to be X * so efficient. X */ X Xforr() X{ X register struct forst *p; X register memp l; X register char *r; X char vty; X value start; X value end; X value step; X X l=getname(); X vty=vartype; X if(l<earray) /* string or array element */ X error(2); /* variable required */ X if(getch()!='=') X error(SYNTAX); X r= (char *)(l - earray); /* index */ X eval(); /* get the from part */ X putin(&start,vty); /* convert and move the right type */ X if(getch()!=TO) X error(SYNTAX); X eval(); /* the to part */ X putin(&end,vty); X if(getch()==STEP) X eval(); /* the step part */ X else { X point--; /* default case */ X res.i=1; X vartype = 01; X } X putin(&step,vty); X check(); /* syntax check */ X for(p=(forstp)vvend,p--;p>=(forstp)bstk;p--) /* have we had it */ X if(p->fr && p->fnnm == r) /* in a for loop before */ X goto got; /* if so then reset its limits */ X p= (forstp)vvend; X vvend += sizeof(struct forst); /* no then allocate a */ X mtest(vvend); /* new structure on the stack */ X p->fnnm=r; X p->fr= 01+vty; Xgot: p->elses=elsecount; /* set up all information for the */ X p->stolin=stocurlin; /* next routine */ X p->pt=point; X vartype=vty; X#ifndef V6C X p->final = end; X p->step = step; X res = start; X#else X movein(&end,&p->final); /* move the variables to the correct */ X movein(&step,&p->step); /* positions */ X movein(&start,&res); X#endif X#ifdef LNAMES X l = (int)r + earray; /* force it back */ X#endif X putin(l,vty); X normret; X} X X/* X * the 'next' command , this does not need an argument , if there is X * none then the most deeply nested 'next' is accessed. If there is X * a list of arguments then the variable name is accessed and a search X * is made for it. ( next_without_for error ). Then the step is added X * to the varable and the result is compared to the final. If the loop X * is not ended then the stack is set to the end of this 'for' structure X * and a return is executed. Otherwise the stack is popped and a return X * to the required line is performed. X */ X X Xnext() X{ X register struct forst *p; X register value *l; X register char *r; X register int c; X X c=getch(); X point--; X if(istermin(c)){ /* no argument */ X for( p = (forstp)vvend , p-- ; p >= (forstp)bstk ; p--) X if(p->fr){ X l = (value *)(p->fnnm + (int) earray); X goto got; X } X error(18); /* no next */ X } Xfor(;;){ X l= (value *)getname(); X r= (memp)((memp)l - earray); X for(p= (forstp)vvend , p-- ; p >= (forstp)bstk ; p--) X if(p->fr &&p->fnnm == r) X goto got; X error(18); /* next without for */ Xgot: vartype=p->fr-1; X if(vartype){ X#ifndef pdp11 X#ifdef VAX_ASSEM /* if want to use assembler */ X l->i += p->step.i; X asm(" bvc nov"); /* it is a lot faster.... */ X error(35); X asm("nov:"); X#else X register long m = p->step.i; X if( (m += l->i) > 32767 || m < -32768 ) X error(35); X else l->i = m; X#endif X#else X foreadd(p->step.i,l); X#endif X if(p->step.i < 0){ X if( l->i >= p->final.i) X goto nort; X else goto rt; X } X else if( l->i <= p->final.i) X goto nort; X } X else { X fadd(&p->step, l ); X if(p->step.i <0){ /* bit twiddling */ X#ifndef SOFTFP X if( l->f >= p->final.f) X goto nort; X else goto rt; X } X else if( l->f <= p->final.f) X goto nort; X#else X if(cmp(l,&p->final)>=0 ) X goto nort; X goto rt; X } X else if(cmp(l,&p->final)<= 0) X goto nort; X#endif X } Xrt: vvend=(memp)p; /* don't loop - pop the stack */ X if(getch()==',') X continue; X else point--; X break; Xnort: X if(stocurlin=p->stolin) /* go back to the 'for' */ X curline=stocurlin->linnumb; /* need this for very */ X else runmode=0; /* obscure reasons */ X point = p->pt; X elsecount=p->elses; X vvend = (memp) (p+1); X break; X } X normret; X} X X/* X * The 'gosub' command , This uses the same structure as 'for' for X * the storage of data. A gosub is identified by the flag 'fr' in X * the 'for' structure being zero. This just gets the line on which X * we are on and sets up th structure. Gosubs from immeadiate mode X * are dealt with and this is one of the obscure reasons for the X * the comment and code in 'return' and 'next'. X */ X Xgosub() X{ X register struct forst *p; X register lpoint l; X X l=getline(); X check(); X p = (forstp) vvend; X vvend += sizeof(struct forst); X mtest(vvend); X runmode=1; X p->fr=0; X p->fnnm=0; X p->elses=elsecount; X p->pt=point; X p->stolin=stocurlin; X stocurlin=l; X curline=l->linnumb; X point= l->lin; X elsecount=0; X return(-1); /* return to execute the next instruction */ X} X X/* X * The 'return' command this just searches the stack for the X * first gosub/return it can find, pops the stack to that level X * and returns to the correct point. Deals with returns to X * immeadiate mode, as well. X */ X Xretn() X{ X register struct forst *p; X X check(); X for(p= (forstp)vvend , p-- ; p >= (forstp)bstk ; p--) X if(!p->fr && !p->fnnm) X goto got; X error(21); /* return without gosub */ Xgot: X elsecount=p->elses; X point=p->pt; X if(stocurlin=p->stolin) X curline=stocurlin->linnumb; X else runmode=0; /* return to immeadiate mode */ X vvend= (memp)p; X normret; X} X X/* X * The 'run' command , run will execute a program by putting it in X * runmode and setting the start address to the start of the program X * or to the optional line number. It clears all the variables and X * closes all files. X */ X Xrunn() X{ X register lpoint p; X register unsigned l; X X l=getlin(); X check(); X p = (lpoint)fendcore; X if(l== (unsigned)(-1) ) X goto got; X else for(;p->linnumb; p = (lpoint)((memp) p + lenv(p)) ) X if(l== p->linnumb) X goto got; X error(6); /* undefined line */ Xgot: X clear(DEFAULTSTRING); /* zap the variables */ X closeall(); X if(!p->linnumb) /* no program so return */ X reset(); X curline=p->linnumb; /* set up all the standard pointers */ X stocurlin=p; X point=p->lin; X elsecount=0; X runmode=1; X return(-1); /* return to execute the next instruction */ X} X X/* X * The 'end' command , checks its syntax ( no parameters ) then X * gets out of what we were doing. X */ X Xendd() X{ X check(); X reset(); X} X X/* X * The 'goto' command , simply gets the required line number X * and sets the pointers to it. If in immeadiate mode , go into X * runmode and zap the stack . X */ X Xgotos() X{ X register lpoint p; X p=getline(); X check(); X curline=p->linnumb; X point=p->lin; X stocurlin=p; X elsecount=0; X if(!runmode){ X runmode++; X vvend=bstk; /* zap the stack */ X } X return(-1); X} X X/* X * The 'print' command , The code for this routine is rather weird. X * It works ( well ) for all types of printing ( including files ), X * but it is a bit 'kludgy' and could be done better ( I don't know X * how ). Every expression must be followed by a comma a semicolon X * or the end of a statement. To get it all to work was tricky but it X * now does and that is all that can be said for it. X * The use of filedes assumes that an integer has the same size as X * a structure pointer. If this is not the case. This system will not X * work ( nor will most of the rest of the interpreter ). X */ X Xprint() X{ X int i; X register int c; X extern write(),putfile(); X static char spaces[]=" "; /* 16 spaces */ X register int (*outfunc)(); /* pointer to the output function */ X register int *curcursor; /* pointer to the current cursor */ X /* 'posn' if a file, or 'cursor' */ X int Twidth; /* width of the screen or of the */ X filebufp filedes; /* file. BLOCKSIZ if a file */ X X c=getch(); X if(c=='#'){ X i=evalint(); X if(getch()!=',') X error(SYNTAX); X filedes=getf(i,_WRITE); X outfunc= putfile; /* see bas6.c */ X curcursor= &filedes->posn; X Twidth = BLOCKSIZ; X c=getch(); X } X else { X outfunc= write; X curcursor= &cursor; X filedes = (filebufp)1; X Twidth = ter_width; X } X point--; X Xfor(;;){ X if(istermin(c)) X break; X else if(c==TABB){ /* tabing */ X point++; X if(*point++!='(') X error(SYNTAX); X i=evalint(); X if(getch()!=')') X error(SYNTAX); X while(i > *curcursor+16 && !trapped){ X (*outfunc)(filedes,spaces,16); X *curcursor+=16; X } X if(i> *curcursor && !trapped){ X (*outfunc)(filedes,spaces,i- *curcursor); X *curcursor = i; X } X *curcursor %= Twidth; X c=getch(); X goto outtab; X } X else if(c==',' || c==';'){ X point++; X goto outtab; X } X else if(checktype()) X stringeval(gblock); X else { X eval(); X gcvt(); X } X (*outfunc)(filedes,gblock,gcursiz); X *curcursor = (*curcursor + gcursiz) % Twidth; X c=getch(); Xouttab: if(c==',' ||c==';'){ X if(c==','){ X (*outfunc)(filedes,spaces,16-(*curcursor%16)); X *curcursor=(*curcursor+(16- *curcursor%16)) % Twidth; X } X c=getch(); X point--; X if(istermin(c)) X normret; X } X else if(istermin(c)){ X point--; X break; X } X else error(SYNTAX); X } X X (*outfunc)(filedes,nl,1); X *curcursor=0; X normret; X} X X/* X * The 'if' command , no real problems here but the 'else' part X * could do with a bit more checking of what it's going over. X */ X Xiff() X{ X register int elsees; X register int c; X register char *p; X X eval(); X if(getch()!=THEN) X error(SYNTAX); X#ifdef PORTABLE X if(vartype ? res.i : res.f){ X#else X if(res.i ){ /* naughty bit twiddleing */ X#endif X c=getch(); /* true */ X point--; X elsecount++; /* say `else`s are allowed */ X if(isnumber(c)) /* if it's a number then */ X gotos(); /* execute a goto */ X return(-1); /* return to execute another ins. */ X } X for(elsees = 0, p= point; *p ; p++) /* skip all nested 'if'-'else' */ X if(*p==(char)ELSE){ /* pairs */ X if(--elsees < 0){ X p++; X break; X } X } X else if(*p==(char)IF) X elsees++; X point = p; /* we are after the else or at */ X if(!*p) X normret; X while(*p++ == ' '); /* end of line */ X p--; /* ignore the space after else */ X if(isnumber(*p)) /* if number then do a goto */ X gotos(); X return(-1); X} X X/* X * The 'on' command , this deals with everything , it has to do X * its own searching so that undefined lines are not accessed until X * a 'goto' to that line is actually required. X * Deals with on_gosubs from immeadiate mode. X */ X Xonn() X{ X unsigned lnm[128]; X register unsigned *l; X register lpoint p; X register forstp pt; X int m; X int i; X int c; X int k; X X if(getch()==ERROR){ X if(getch()!=GOTO) X error(SYNTAX); X errtrap(); /* do the trapping of errors */ X normret; X } X else point--; X m=evalint(); X if((k=getch())!= GOTO && k != GOSUB) X error(SYNTAX); X for(l=lnm,i=1;;l++,i++){ /* get the line numbers */ X if( (*l = getlin()) == (unsigned)(-1) ) X error(5); /* line number required */ X if(getch()!=',') X break; X } X point--; X check(); X if(m<1 || m> i) /* index is out of bounds */ X normret; /* so return */ X c= lnm[m-1]; X for(p = (lpoint)fendcore ; p->linnumb ; X p = (lpoint)((memp)p + lenv(p)) ) X if(p->linnumb==c) X goto got; X error(6); /* undefined line */ Xgot: if(k== GOSUB) { X pt=(forstp)vvend; /* fix the gosub stack */ X vvend += sizeof(struct forst); X mtest(vvend); X pt->fnnm=0; X pt->fr=0; X pt->elses=elsecount; X pt->pt=point; X pt->stolin=stocurlin; X } X if(!runmode){ X runmode++; X if(k==GOTO) /* gotos in immeadiate mode */ X vvend=bstk; X } X stocurlin=p; X curline=p->linnumb; X point= p->lin; X elsecount=0; X return(-1); X} X X/* X * The 'cls' command , neads to set the terminal into 'rare' mode X * so that there is no waiting on the page clearing ( form feed ). X */ X Xcls() X{ X extern char o_CLEARSCR[]; X X set_term(); X puts(o_CLEARSCR); X putch(0); /* flush it out */ X rset_term(0); X cursor = 0; X normret; X} X X/* X * The 'base' command , sets the start index for arrays to either X * '0' or '1' , simple. X */ X Xbase() X{ X register int i; X i=evalint(); X check(); X if(i && i!=1) X error(28); /* bad base value */ X baseval=i; X normret; X} X X/* X * The 'rem' and '\'' command , ignore the rest of the line X */ X Xrem() { return(GTO); } X X/* X * The 'let' command , all the work is done in assign , the first X * getch() is to get the pointer in the right place for assign(). X */ X Xlets() X{ X assign(); X normret; X} X X/* X * The 'clear' command , clears all variables , closes all files X * and allocates the required amount of storage for strings, X * maximum is 32K. X */ X Xclearl() X{ X register int i; X X i=evalint(); X check(); X if(i < 0 || i + ecore > MAXMEM) X error(12); /* bad core size */ X clear(i); X closeall(); X normret; X} X X/* X * The 'list' command , can have an optional two arguments and X * a dash is also used. X * Most of this routine is the getting of the arguments. All the X * actual listing is done in listl() , This routine should call write() X * and not clr(), but then the world is not perfect. X */ X Xlist() X{ X register unsigned l1,l2; X register lpoint p; X l1=getlin(); X if(l1== (unsigned)(-1) ){ X l1=0; X l2= -1; X if(getch()=='-'){ X if( (l2 = getlin()) == (unsigned)(-1) ) X error(SYNTAX); X } X else point--; X } X else { X if(getch()!='-'){ X l2= l1; X point--; X } X else X l2 = getlin(); X } X check(); X for(p= (lpoint)fendcore ; p->linnumb < l1 ; X p = (lpoint)((memp)p + lenv(p)) ) X if(!p->linnumb) X reset(); X if(l1== l2 && l1 != p->linnumb ) X reset(); X while(p->linnumb && p->linnumb <=l2 && !trapped){ X l1=listl(p); X line[l1++] = '\n'; X write(1,line,(int)l1); X p = (lpoint)((memp)p + lenv(p)); X } X reset(); X} X X/* X * The routine that does the listing of a line , it searches through X * the table of reserved words if it find a byte with the top bit set, X * It should ( ha ha ) find it. X * This routine could run off the end of line[] since line is followed X * by nline[] this should not cause any problems. X * The result is in line[]. X */ X Xlistl(p) Xlpoint p; X{ X register char *q; X register struct tabl *l; X register char *r; X X r=strcpy(printlin(p->linnumb) ,line); /* do the linenumber */ X for(q= p->lin; *q && r < &line[MAXLIN]; q++){ X if(*q &(char)0200) /* reserved words */ X for(l=table;l->chval;l++){ X if((char)(l->chval) == *q){ X r=strcpy(l->string,r); X break; X } X } X else if(*q<' '){ /* do special characters */ X *r++ ='\\'; X *r++ = *q+ ('a'-1); X } X else { X if(*q == '\\') /* the special character */ X *r++ = *q; X *r++ = *q; /* non special characters */ X } X } X if(r >= &line[MAXLIN]) /* get it back a bit */ X r = &line[MAXLIN-1]; X *r=0; X return(r-line); /* length of line */ X} X X/* X * The 'stop' command , prints the message that it has stopped X * and then exits the 'user' program. X */ X Xstop() X{ X check(); X dostop(0); X} X X/* X * Called if trapped is set (by control-c ) and just calls dostop X * with a different parameter to print a slightly different message X */ X Xdobreak() X{ X dostop(1); X} X X/* X * prints out the 'stopped' or 'breaking' message then exits. X * These two functions were lumped together so that it might be X * possible to add a 'cont'inue command at a latter date ( not X * implemented yet ) - ( it is now ). X */ X Xdostop(i) X{ X if(cursor){ X cursor=0; X prints(nl); X } X prints( (i) ? "breaking" : "stopped" ); X if(runmode){ X prints(" at line "); X prints(printlin(curline)); X if(!intrap){ /* save environment */ X cancont=i+1; X conpoint=point; X constolin=stocurlin; X concurlin=curline; X contelse=elsecount; X conerp=errortrap; X } X } X prints(nl); X reset(); X} X X/* the 'cont' command - it seems to work ?? */ X Xcont() X{ X check(); X if( contpos && !runmode){ X point = conpoint; /* restore environment */ X stocurlin =constolin; X curline = concurlin; X elsecount = contelse; X errortrap = conerp; X vvend= bstk; X bstk = vend; X mtest(vvend); /* yeuch */ X runmode =1; X if(contpos==1){ X contpos=0; X normret; /* stopped */ X } X contpos=0; /* ctrl-c ed */ X return(-1); X } X contpos=0; X error(CANTCONT); X} X X/* X * The 'delete' command , will only delete the required lines if it X * can find the two end lines. stops ' delete 1' etc. as a slip up. X * very slow algorithm. But who cares ?? X */ X Xdelete() X{ X register lpoint p1,p2; X register unsigned i2; X X p1=getline(); X if(getch()!='-') X error(SYNTAX); X p2=getline(); X check(); X if(p1>p2) X reset(); X i2 = p2->linnumb; X do{ X linenumber = p1->linnumb; X insert(0); X }while(p1->linnumb && p1->linnumb <= i2 ); X reset(); X} X X/* X * The 'shell' command , calls the v7 shell as an entry into unix X * without going out of basic. Has to set the terminal in a decent X * mode , else 'ded' doesn't like it. X * Clears out all buffered file output , so that you can see what X * you have done so far, and sets your userid to your real-id X * this stops people becoming unauthorised users if basic is made X * setuid ( for games via runfile of the command file ). X */ X Xshell() X{ X register int i; X register int (*q)() , (*p)(); X int (*signal())(); X char *s; X#ifdef SIGTSTP X int (*t)(); X#endif X X check(); 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)",0); X exit(-1); /* problem */ X } X else if(i== -1) X prints("cannot shell out\n"); X else { /* daddy */ X p=signal(SIGINT,SIG_IGN); /* ignore some signals */ X q=signal(SIGQUIT, SIG_IGN); X while(i != wait(0) && i != -1); /* 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#ifdef SIGTSTP X signal(SIGTSTP, t); X#endif X normret; X} X X/* X * The 'edit' command , can only edit in immeadiate mode , and with the X * specified line ( maybe could be more friendly here , no real need to X * since the editor is the same as on line input. X */ X Xeditl() X{ X register lpoint p; X register int i; X X p= getline(); X check(); X if(runmode || noedit) X error(13); /* illegal edit */ X i=listl(p); X edit(0,i,0); /* do the edit */ X if(trapped) /* ignore it if exited via cntrl-c */ X reset(); X i=compile(0); X if(linenumber) /* ignore it if there is no line number */ X insert(i); X reset(); /* return to 'ready' */ X} X X/* X * The 'auto' command , allows input of lines with automatic line X * numbering. Most of the code is to do with getting the arguments X * otherwise the loop is fairly simple. There are three ways of getting X * out of this routine. cntrl-c will exit the routine immeadiately X * If there is no linenumber then it also exits. If the line typed in is X * terminated by an ESCAPE character the line is inserted and the routine X * is terminated. X */ X Xdauto() X{ X register unsigned start , end , i1; X unsigned int i2; X long l; X int c; X i2=autoincr; X i1=getlin(); X if( i1 != (unsigned)(-1) ){ X if(getch()!= ','){ X point--; X i2=autoincr; X } X else { X i2=getlin(); X if(i2 == (unsigned)(-1) ) X error(SYNTAX); X } X } X else X i1=autostart; X check(); X start=i1; X autoincr=i2; X end=i2; X for(;;){ X i1= strcpy(printlin(start),line) - line; X line[i1++]=' '; X c=edit(0,i1,i1); X if(trapped) X break; X i1=compile(0); X if(!linenumber) X break; X insert(i1); X if( (l= (long)start+end) >=65530){ X autostart=10; X autoincr=10; X error(6); /* undefined line number */ X } X start+=end; X autostart=l; X if(c == ESCAPE ) X break; X } X reset(); X} X X/* X * The 'save' command , saves a basic program on a file. X * It just lists the lines adds a newline then writes them out X */ X Xsave() X{ X register lpoint p; X register int fp; X register int i; X X stringeval(gblock); /* get the name */ X gblock[gcursiz]=0; X check(); X if((fp=creat(gblock,0644))== -1) X error(14); /* cannot creat file */ X for(p= (lpoint)fendcore ; p->linnumb ; X p = (lpoint)((memp) p + lenv(p)) ){ X i=listl(p); X line[i++]='\n'; X write(fp,line,i); /* could be buffered ???? */ X } X close(fp); X normret; X} X X/* X * The 'old' command , loads a program from a file. The old X * program (if any ) is wiped. X * Most of the work is done in readfi, ( see also error ). X */ X Xold() X{ X register int fp; X X stringeval(gblock); X gblock[gcursiz]=0; /* get the file name */ X check(); X if((fp=open(gblock,0))== -1) X error(15); /* can't open file */ X ecore= fendcore+sizeof(xlinnumb); /* zap old program */ X ( (lpoint) fendcore)->linnumb=0; X readfi(fp); /* read the new file */ X reset(); X} X X/* X * The 'merge' command , similar to 'old' but does not zap the old X * program so the two files are 'merged' . X */ X Xmerge() X{ X register int fp; X X stringeval(gblock); X gblock[gcursiz]=0; X check(); X if((fp=open(gblock,0))== -1) X error(15); X readfi(fp); X reset(); X} X X/* X * The routine that actually reads in a file. It sets up readfile X * so that if there is an error ( linenumber overflow ) , then error X * can pick up the pieces , else the number of file descriptors are X * reduced and can ( unlikely ), run out of them so stopping any file X * being saved or restored , ( This is the reason that all files are X * closed so meticulacly ( see 'chain' and its pipes ). X */ X Xreadfi(fp) X{ X register char *p; X int i; X char chblock[BLOCKSIZ]; X int nleft=0; X register int special=0; X register char *q; X X readfile=fp; X inserted=1; /* make certain variables are cleared */ X p=line; /* input into line[] */ X for(;;){ X if(!nleft){ X q=chblock; X if( (nleft=read(fp,q,BLOCKSIZ)) <= 0) X break; X } X *p= *q++; X nleft--; X if(special){ X special=0; X if(*p>='a' && *p<='~'){ X *p -= ('a'-1); X continue; X } X } X if(*p =='\n'){ X *p=0; X i=compile(0); X if(!linenumber) X goto bad; X insert(i); X p=line; X continue; X } X else if(*p<' ') X goto bad; X else if(*p=='\\') X special++; X if(++p > &line[MAXLIN]) X goto bad; X } X if(p!=line) X goto bad; X close(fp); X readfile=0; X return; X Xbad: close(fp); /* come here if there is an error */ X readfile=0; /* that readfi() has detected */ X error(23); /* stops error() having to tidy up */ X} X X/* X * The 'new' command , This deletes any program and clears all X * variables , can take an extra parameter to say how many files are X * needed. If so then clears the number of buffers ( default 2 ). X */ X Xneww() X{ X register int i,c; X register struct filebuf *p; X register memp size; X X c=getch(); X point--; X if(!istermin(c)){ X i=evalint(); X check(); X closeall(); /* flush the buffers */ X if(i<0 || i> MAXFILES) X i=2; X fendcore= filestart + (sizeof(struct filebuf) * i ); X size = fendcore + sizeof(xlinnumb); X size = (char *) ( ((int)size + MEMINC) & ~MEMINC); X brk(size); 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 } X else X check(); X autostart=10; X autoincr=10; X baseval=1; X ecore= fendcore + sizeof(xlinnumb); X ( (lpoint)fendcore )->linnumb=0; X clear(DEFAULTSTRING); X closeall(); X reset(); X} X X/* X * The 'chain' command , This routine chains the program. X * all simple numeric variables are kept. ( max of 4 k ). X * all other variables are cleared. X * runs the loaded file X * files are kept open X * X * error need only check pipe[0] to see if it is to be closed. X */ X Xchain() X{ X register int fp; X register int size; X register char *p; X int ssize,nsize; X#ifdef LNAMES X register struct entry *ep,*np; X register int *xp; X#endif X X stringeval(gblock); X check(); X gblock[gcursiz]=0; X size= vend- earray; X#ifdef LNAMES X nsize = enames - estring; /* can only save offsets */ X if(nsize + size >= 4096) /* cos ecore/estring might */ X#else /* change */ X if(size >= 4096 ) X#endif X error(42); /* out of space for varibles */ X if((fp=open(gblock,0))== -1) X error(15); X ssize= estring- ecore; /* amount of string space */ X pipe(pipes); X write(pipes[1],earray,size); /* check this */ X#ifdef LNAMES X write(pipes[1],estring,nsize); X#endif X close(pipes[1]); X pipes[1]=0; X ecore= fendcore + sizeof(xlinnumb); /* bye bye old file */ X ( (lpoint)fendcore )->linnumb=0; /* commited to new file now */ X readfi(fp); X clear(ssize); X errortrap=0; X inserted=0; /* say we don't actually want to */ X p= xpand(&vend,size); /* clear variables on return */ X read(pipes[0],p,size); X#ifdef LNAMES X p = xpand(&enames,nsize); X read(pipes[0],p,nsize); X /* X * now rehash the symbol table X * cos it gets munged when it moves X */ X for(ep = (struct entry *)estring; ep < (struct entry *)enames; ep++){ X ep->link = 0; X for(p = ep->_name,size = 0; *p ; size += *p++); X ep->ln_hash = size; X if(np = hshtab[size %= HSHTABSIZ]){ X for(;np->link ;np = np->link); X np->link = ep; X } X else X hshtab[size] = ep; X } X /* X * must zap varshash - because of above X */ X for( xp = varshash ; xp < &varshash[HSHTABSIZ] ; *xp++ = -1); X chained = 1; X#endif X close(pipes[0]); /* now have data back from pipe */ X pipes[0]=0; X stocurlin= (lpoint)fendcore; X if(!(curline=stocurlin->linnumb)) X reset(); X point= stocurlin->lin; X elsecount=0; X runmode=1; X return(-1); /* now run the file */ X} X X/* define a function def fna() - can have up to 3 parameters */ X Xdeffunc() X{ X struct deffn fn; /* temporary place for evaluation */ X register struct deffn *p; X register int i=0; X int c; X char *j; X register char *l; X X if(getch() != FN) X error(SYNTAX); X if(!isletter(*point)) X error(SYNTAX); X getnm(); X if(vartype == 02) X error(VARREQD); X fn.dnm = nm; X#ifdef LNAMES X for(p = (deffnp)enames ; p < (deffnp)edefns ; X#else X for(p = (deffnp)estring ; p < (deffnp)edefns ; X#endif X p = (deffnp)( (memp)p + p->offs) ) X if(p->dnm == nm ) X error(REDEFFN); /* redefined functions */ X fn.vtys=vartype<<4; /* save return type of function */ X if(*point=='('){ /* get arguments */ X point++; X for(;i<3;i++){ X l=getname(); X if( l < earray) X error(VARREQD); X fn.vargs[i]= l - earray; X fn.vtys |= vartype <<i; /* save type of arguments */ X if((c=getch())!=',') X break; X } X if(c!= ')') X error(SYNTAX); X i++; X } X if(getch()!='=') X error(SYNTAX); X fn.narg=i; X l = point; X while(*l++ == ' '); X point = --l; X while(!istermin(*l)) /* get rest of expression */ X l++; X if(l==point) X error(SYNTAX); X i= l - point + sizeof(struct deffn); X#ifdef ALIGN4 X i = (i + 03) & ~03; X#else X if(i&01) /* even up space requirement */ X i++; X#endif X p= (deffnp) xpand(&edefns,i ); /* get the space */ X#ifndef V6C X *p = fn; X p->offs = i; X#else X p->dnm = fn.dnm; /* put all values in */ X p->offs=i; X p->narg=fn.narg; X p->vtys= fn.vtys; X p->vargs[0]=fn.vargs[0]; X p->vargs[1]=fn.vargs[1]; X p->vargs[2]=fn.vargs[2]; X#endif X j= p->exp; X while( point<l) /* store away line */ X *j++ = *point++; X *j=0; X normret; X} X X/* the repeat part of the repeat - until loop */ X/* now can have a construct like 'repeat until eof(1)'. */ X/* It might be of use ?? it's a special case */ X X Xrept() X{ X register struct forst *p; X register int c; X register char *tp; X X if(getch() == UNTIL){ X tp = point; /* save point */ X eval(); /* calculate the value */ X check(); /* check syntax */ X#ifdef PORTABLE X while((vartype ? (!res.i) :(res.f == 0)) && !trapped){ X#else X while(!res.i && !trapped){ /* now repeat the loop until <>0 */ X#endif X point = tp; X eval(); X } X normret; X } X point--; X check(); X p= (forstp)vvend; X vvend += sizeof(struct forst); X mtest(vvend); X p->pt = point; X p->stolin = stocurlin; X p->elses = elsecount; X p->fr = 0; /* make it look like a gosub like */ X p->fnnm = (char *)01; /* distinguish from gosub's */ X normret; X} X X/* the until bit of the command */ X Xuntilf() X{ X register struct forst *p; X eval(); X check(); X for(p= (forstp)vvend , p-- ; p >= (forstp)bstk ; p--) X if(!p->fr) X goto got; X error(48); Xgot: X if(p->fnnm != (char *)01 ) X error(51); X#ifdef PORTABLE X if(vartype ? (!res.i) : (res.f == 0)){ X#else X if(!res.i){ /* not true so repeat loop */ X#endif X elsecount = p->elses; X point = p->pt; X if(stocurlin = p->stolin) X curline = stocurlin->linnumb; X else runmode =0; X vvend = (memp)(p+1); /* pop all off stack up until here */ X } X else X vvend = (memp)p; /* pop stack if finished here. */ X normret; X} X X/* while part of while - wend construct. This is like repeat until unless X * loop fails on the first time. (Yeuch - next we need syntax checking on X * input ). X */ X Xwhilef() X{ X register char *spoint = point; X register lpoint lp; X register struct forst *p; X lpoint get_end(); X eval(); X check(); X#ifdef PORTABLE X if(vartype ? res.i : res.f){ X#else X if(res.i){ /* got to go through it once so make it look like a */ X /* repeat - until */ X#endif X p= (forstp)vvend; X vvend += sizeof(struct forst); X mtest(vvend); X p->pt = spoint; X p->stolin = stocurlin; X p->elses = elsecount; X p->fr = 0; /* make it look like a gosub like */ X p->fnnm = (char *)02; /* distinguish from gosub's */ X normret; X } X lp=get_end(); /* otherwise find a wend */ X check(); X if(runmode){ X stocurlin =lp; X curline = lp->linnumb; X } X normret; X} X X/* the end part of a while loop - wend */ X Xwendf() X{ X register struct forst *p; X char *spoint =point; X check(); X for(p= (forstp)vvend , p-- ; p >= (forstp)bstk ; p--) X if(!p->fr) X goto got; X error(49); Xgot: X if( p->fnnm != (char *)02 ) X error(51); X point = p->pt; X eval(); X#ifdef PORTABLE X if(vartype ? (!res.i) : (res.f == 0)){ X#else X if(!res.i){ /* failure of the loop */ X#endif X vvend= (memp)p; X point = spoint; X normret; X } X vvend = (memp)(p+1); /* pop stack after an iteration */ X elsecount = p->elses; X if(stocurlin = p->stolin) X curline = stocurlin->linnumb; X else runmode=0; X normret; X} X X/* get_end - search from current position until found a wend statement - of X * the correct nesting. Keeping track of elses + if's(Yeuch ). X */ X Xlpoint Xget_end() X{ X register lpoint lp; X register char *p; X register int c; X int wcount=0; X int rcount=0; X int flag=0; X X p= point; X lp= stocurlin; X if(getch()!=':'){ X if(!runmode) X error(50); X lp = (lpoint)((memp)lp +lenv(lp)); X if(!lp->linnumb) X error(50); X point = lp->lin; X elsecount=0; X } X for(;;){ X c=getch(); X if(c==WHILE) X wcount++; X else if(c==WEND){ X if(--wcount <0) X break; /* only get out point in loop */ X } X else if(c==REPEAT) X rcount++; X else if(c==UNTIL){ X if(--rcount<0) X error(51); /* bad nesting */ X } X else if(c==IF){ X flag++; X elsecount++; X } X else if(c==ELSE){ X flag++; X if(elsecount) X elsecount--; X } X else if(c==REM || c==DATA || c==QUOTE){ X if(!runmode) X error(50); /* no wend */ X lp = (lpoint)((memp)lp +lenv(lp)); X if(!lp->linnumb) X error(50); /* no wend */ X point =lp->lin; X elsecount=0; X flag=0; X continue; X } X else for(p=point;!istermin(*p);p++) X if(*p=='"' || *p=='`'){ X c= *p++; X while(*p && *p != (char) c) X p++; X if(!*p) X break; X } X if(!*p++){ X if(!runmode) X error(50); X lp = (lpoint)((memp)lp +lenv(lp)); X if(!lp->linnumb) X error(50); X point =lp->lin; X elsecount=0; X flag=0; X } X else X point = p; X } X /* we have found it at this point - end of loop */ X if(rcount || (lp!=stocurlin && flag) ) X error(51); /* bad nesting or wend after an if */ X return(lp); /* not on same line */ X} X X#ifdef RENUMB X X/* X * the renumber routine. It is a three pass algorithm. X * 1) Find all line numbers that are in text. X * Save in table. X * 2) Renumber all lines. X * Fill in table with lines that are found X * 3) Find all line numbers and update to new values. X * X * This routine eats stack space and also some code space X * If you don't want it don't define RENUMB. X * Could run out of stack if on V7 PDP-11's X * ( On vax's it does not matter. Also can increase MAXRLINES.) X * MAXRLINES can be reduced if not got split i-d. If this is X * the case then probarbly do not want this code anyway. X */ X X#define MAXRLINES 500 /* the maximum number of lines that */ X /* can be changed. Change if neccasary */ X Xrenumb() X{ X struct ta { X unsigned linn; X unsigned toli; X } ta[MAXRLINES]; X X struct ta *eta = ta; X register struct ta *tp; X register char *q; X register lpoint p; X X unsigned l1,start,inc; X int size,sl,pl; X char onfl,chg,*r,*s; X long numb; X X start = 10; X inc = 10; X l1 = getlin(); X if(l1 != (unsigned)(-1) ){ /* get start line number */ X start = l1; X if(getch() != ',') X point--; X else { X l1 = getlin(); /* get increment */ X if(l1 == (unsigned)(-1)) X error(5); X inc = l1; X } X } X check(); /* check rest of line */ X numb = start; /* set start counter */ X for(p=(lpoint)fendcore; p->linnumb ;p=(lpoint)((char *)p+lenv(p))){ X numb += inc; X if(numb >= 65530 ) /* check line numbers */ X error(7); /* line number overflow */ X onfl = 0; /* flag to deal with on_goto */ X for(q = p->lin; *q ; q++){ /* now find keywords */ X if( !(*q & (char)0200 )) /* not one */ X continue; /* ignore */ X if(*q == (char) ON){ /* the on keyword */ X onfl++; /* set flag */ X continue; X } /* check items with optional numbers*/ X if(*q == (char)ELSE || *q == (char)THEN || X *q == (char)RESUME || *q == (char)RESTORE X || *q == (char) RUNN ){ X q++; X while(*q++ == ' '); X q--; X if(isnumber(*q)) /* got one ok */ X goto ok1; X } X if(*q != (char) GOTO && *q != (char)GOSUB) X continue; /* can't be anything else */ X q++; X ok1: /* have a label */ X do{ X while(*q++ == ' '); X q--; /* look for number */ X if( !isnumber(*q) ){ X prints("Line number required on line "); X prints(printlin(p->linnumb)); X prints(nl); /* missing */ X goto out1; X } X for(l1 = 0; isnumber(*q) ; q++) /* get it */ X if(l1 >= 6553) X error(7); X else l1 = l1 * 10 + *q - '0'; X for(tp = ta ; tp < eta ; tp++) /* already */ X if(tp->linn == l1) /* got it ? */ X break; X if(tp >= eta ){ /* add another entry */ X tp->linn = l1; X tp->toli = -1; X if(++eta >= &ta[MAXRLINES]) X error(24); /* out of core */ X } X if(!onfl) /* check flag */ X break; /* get next item */ X while(*q++== ' '); /* if ON and comma */ X }while( *(q-1) ==','); X if(onfl) X q--; X onfl =0; X q--; X } X out1: ; X } X numb = start; /* reset counter */ X for(p= (lpoint)fendcore ; p->linnumb ;p=(lpoint)((char *)p+lenv(p)) ){ X for(tp = ta ; tp < eta ; tp++) /* change numbers */ X if(tp->linn == p->linnumb){ X tp->toli = numb; /* inform of new number */ X break; X } X p->linnumb = numb; X numb += inc; X } X for(p= (lpoint)fendcore ; p->linnumb ;p=(lpoint)((char *)p+lenv(p)) ){ X onfl = 0; X chg = 0; /* set if line changed */ X for(r = nline, q = p->lin ; *q ; *r++ = *q++){ X if( r >= &nline[MAXLIN]) /* overflow of line */ X break; X if( !(*q & (char) 0200 )) /* repeat search for */ X continue; /* keywords */ X if(*q == (char) ON){ X onfl++; X continue; X } X if(*q == (char)ELSE || *q == (char)THEN || X *q == (char)RESUME || *q == (char)RESTORE X || *q == (char) RUNN ){ X *r++ = *q++; X while(*q == ' ' && r < &nline[MAXLIN] ) X *r++ = *q++; X if(isnumber(*q)) /* got optional line number*/ X goto ok2; X } X if(*q != (char) GOTO && *q != (char)GOSUB) X continue; X *r++ = *q++; X for(;;){ X while(*q == ' ' && r < &nline[MAXLIN] ) X *r++ = *q++; X ok2: ; X if(r>= &nline[MAXLIN] ) X break; X for(l1 = 0 ; isnumber(*q) ; q++) /* get numb*/ X l1 = l1 * 10 + *q - '0'; X if(l1 == 0) /* skip if not found */ X goto out; /* never happen ?? */ X for(tp = ta ; tp < eta ; tp++) X if(tp->linn == l1) X break; X if(tp->linn != tp->toli) X chg++; /* number has changed */ X if(tp >= eta || tp->toli == (unsigned)(-1) ){ X prints("undefined line: "); X prints(printlin(l1)); X prints(" on line "); X prints(printlin(p->linnumb)); X prints(nl); /* can't find it */ X goto out; X } X s = printlin(tp->toli); /* get new number */ X while( *s && r < &nline[MAXLIN]) X *r++ = *s++; X if(r >= &nline[MAXLIN] ) X break; X if(onfl){ /* repeat if ON statement */ X while(*q == ' ' && r < &nline[MAXLIN]) X *r++ = *q++; X if(*q == ','){ X *r++ = *q++; X continue; X } X } X break; X } X onfl = 0; X if(r >= &nline[MAXLIN]) X error(32); /* line length overflow */ X } X if(!chg) /* not changed so don't put back */ X continue; X inserted =1; /* say we have changed it */ X for(*r = 0, r = nline; *r++ ;); X r--; X size = (r - nline) + sizeof(struct olin); /* get size */ X#ifdef ALIGN4 X size = (size + 03) & ~03; X#else X if(size & 01) /* even it up */ X size++; X#endif X if(size != lenv(p) ){ /* size changed. insert */ X pl = p->linnumb; /* save line number */ X sl = lenv(p); /* save length */ X bmov((short *)p,sl); /* compress core */ X ecore -= sl; /* shrink it */ X mtest(ecore+size); /* get more core */ X ecore += size; /* add it */ X bmovu((short *)p,size); /* expand core */ X p->linnumb = pl; /* restore line number */ X lenv(p) = size; /* set size */ X } X strcpy(nline,p->lin); /* copy back new line */ X out: ; X } X reset(); X} X#else Xrenumb(){} X#endif /* RENUMB */ X X/* the load command. Load a dump image. Works fastwer than save/old */ X X#define MAGIC1 013121 X#define MAGIC2 027212 X Xloadd() X{ X register int nsize; X register fp; X int header[3]; X X stringeval(gblock); X check(); X gblock[gcursiz] = 0; X if( (fp = open(gblock,0))< 0) X error(14); X if(read(fp,(char *)header,sizeof(int)*3) != sizeof(int)*3){ X close(fp); X error(23); /* bad load / format file */ X } X if(header[0] != MAGIC1 && header[1] != MAGIC2){ X close(fp); X error(23); X } X ecore = fendcore + sizeof(xlinnumb); X mtest(ecore); /* good bye old image */ X ((lpoint)fendcore)->linnumb = 0; X inserted = 1; X readfile = fp; X mtest(ecore+header[2]); X readfile = 0; X ecore += header[2]; X nsize = read(fp,fendcore,header[2]); X close(fp); X if(nsize != header[2]){ X ecore = fendcore + sizeof(xlinnumb); X mtest(ecore); X ((lpoint)fendcore)->linnumb = 0; X error(23); X } X reset(); X} X X/* write out the core to the file */ X Xdump() X{ X register int nsize; X register fp; X int header[3]; X X stringeval(gblock); X check(); X gblock[gcursiz] = 0; X if( (fp = creat(gblock,0644))< 0) X error(15); X header[0] = MAGIC1; X header[1] = MAGIC2; X nsize = ecore - fendcore; X header[2] = nsize; X write(fp,(char *)header,sizeof(int)*3); X write(fp,fendcore,nsize); X close(fp); X normret; X} End of bas8.c chmod u=rw-,g=r,o=r bas8.c echo x - bas9.c 1>&2 sed 's/^X//' > bas9.c << 'End of bas9.c' X/* X * BASIC by Phil Cockcroft X */ X#include "bas.h" X X/* X * This file contains subroutines used by many commands X */ X X/* stringcompare will compare two strings and return a valid X * logical value X */ X Xstringcompare() X{ X char chblock[256]; X register int i; X register char *p,*q; X int cursiz; X int reslt=0; X int c; X X checksp(); X stringeval(chblock); X cursiz=gcursiz; X if(! (c=getch()) ) X error(SYNTAX); X stringeval(gblock); X if(i = ((cursiz > gcursiz) ? gcursiz : cursiz) ){ X /* X * make i the minimum of gcursiz and cursiz X */ X gcursiz -= i; cursiz -= i; X p=chblock; q=gblock; /* set pointers */ X do{ X if(*p++ != *q++){ /* do the compare */ X if( (*(p-1) & 0377) > (*(q-1) & 0377) ) X reslt++; X else X reslt--; X compare(c,reslt); X return; X } X }while(--i); X } X if(cursiz) X reslt++; X else if(gcursiz) X reslt--; X compare(c,reslt); X} X X/* given the comparison operator 'c' then returns a value X * given that 'reslt' has a value of:- X * 0: equal X * 1: greater than X * -1: less than X */ X Xcompare(c,reslt) Xregister int c; Xregister int reslt; X{ X vartype=01; X if(c==EQL){ X if(!reslt) X goto true; X } X else if(c==LTEQ){ X if( reslt<=0) X goto true; X } X else if(c==NEQE){ X if( reslt) X goto true; X } X else if(c==LTTH){ X if( reslt<0) X goto true; X } X else if(c==GTEQ){ X if( reslt>=0) X goto true; X } X else if(c==GRTH){ X if( reslt>0) X goto true; X } X else X error(SYNTAX); X res.i=0; /* false */ X return; Xtrue: X res.i = -1; X} X X/* converts a number in 'res' to a string in gblock X * the string will have a space at the start if it is positive X */ X Xgcvt() X{ X int sign, decpt; X int ndigit=9; X register char *p1, *p2; X register int i; X#ifndef SOFTFP X char *ecvt(); X#else X char *necvt(); X#endif X X#ifdef PORTABLE X if(vartype==01 || !res.f){ X#else X if(vartype==01 || !res.i){ /* integer deal with them separately */ X#endif X lgcvt(); X return; X } X#ifndef SOFTFP X p1 = ecvt(res.f, ndigit+2, &decpt, &sign); X#else X p1 = necvt(&res, ndigit+2, &decpt, &sign); X#endif X if (sign) X *gblock = '-'; X else X *gblock = ' '; X if(ndigit > 1){ X p2 = p1 + ndigit-1; X do { X if(*p2 != '0') X break; X ndigit--; X }while(--p2 > p1); X } X p2 = &gblock[1]; X/* X for (i=ndigit-1; i>0 && *(p1+i) =='0'; i--) X ndigit--; X*/ X if (decpt < 0 || decpt > 9){ X decpt--; X *p2++ = *p1++; X if(ndigit != 1){ X *p2++ = '.'; X for (i=1; i<ndigit; i++) X *p2++ = *p1++; X } X *p2++ = 'e'; X if (decpt<0) { X decpt = -decpt; X *p2++ = '-'; X } X if(decpt >= 10){ X *p2++ = decpt/10 + '0'; X decpt %= 10; X } X *p2++ = decpt + '0'; X } X else { X if (!decpt) { X *p2++ = '0'; X *p2++ = '.'; X } X for (i=1; i<=ndigit; i++) { X *p2++ = *p1++; X if (i==decpt && i != ndigit) X *p2++ = '.'; X } X while (ndigit++<decpt) X *p2++ = '0'; X } X *p2 =0; X gcursiz= p2 -gblock; X} X X/* integer version of above - a very simple algorithm */ X Xlgcvt() X{ X static char s[7]; X register char *p,*q; X int fl=0; X register unsigned l; X X l= res.i; X p= &s[6]; X if((int)l <0){ X fl++; X l= -l; X } X do{ X *p-- = l%10 +'0'; X }while(l/=10 ); X if(fl) X *p ='-'; X else X *p =' '; X q=gblock; X while(*q++ = *p++); X gcursiz= --q - gblock; X} X X/* get a linenumber or if no linenumber return a -1 X * used by all routines with optional linenumbers X */ X Xgetlin() X{ X register unsigned l=0; X register int c; X X c=getch(); X if(!isnumber(c)){ X point--; X return(-1); X } X do{ X if(l>=6553 ) X error(7); X l= l*10 + (c-'0'); X c= *point++; X }while(isnumber(c)); X point--; X return(l); X} X X/* getline() gets a line number and returns a valid pointer X * to it, if there is no linenumber or the line is not there X * then there is an error. Used by 'goto' etc. X */ X Xlpoint Xgetline() X{ X register unsigned l=0; X register lpoint p; X register int c; X X c=getch(); X if(!isnumber(c)) X error(5); X do{ X if(l>=6553) X error(7); X l= l*10+(c-'0'); X c= *point++; X }while(isnumber(c)); X point--; X if(runmode && l >= curline) /* speed it up a bit */ X p = stocurlin; /* no need to search the whole lot */ X else X p = (lpoint)fendcore; X for(; p->linnumb ;p = (lpoint)((memp)p + lenv(p))) X if(p->linnumb == l) X return(p); X error(6); X} X X/* printlin() returns a pointer to a string representing the X * the numeric value of the linenumber. linenumbers are unsigned X * quantities. X */ X Xchar * Xprintlin(l) Xregister unsigned l; X{ X static char ln[7]; X register char *p; X X p = &ln[5]; X do{ X *p-- = l %10 + '0'; X }while(l/=10); X p++; X return(p); X} X X/* routine used to check the type of expression being evaluated X * used by print and eval. X * A string expression returns a value of '1' X * A numeric expression returns a value of '0' X */ X Xchecktype() X{ X register char *tpoint; X register int c; X X if( (c= *point) & 0200){ X if( (c&0377) >= MINFUNC) X goto data; X else goto string; X } X if(isnumber(c) || c=='.' || c== '-' || c=='(') X goto data; X if(c=='"' || c=='`') X goto string; X if(!isletter(c)) X error(SYNTAX); X tpoint= point; X do{ X c= *++tpoint; X }while(isletter(c) || isnumber(c)); X if(c!='$') Xdata: return(0); Xstring: return(1); X} X X/* print out a message , used for all types of 'basic' messages X */ X Xprints(s) Xchar *s; X{ X register char *i; X X i=s; X while(*i++); X write(1,s,--i-s); X} X X/* copy a string from a to b returning the last address used in b X */ X Xchar * Xstrcpy(a,b) Xregister char *a,*b; X{ X while(*b++ = *a++); X return(--b); X} X X X#ifndef SOFTFP X X/* convert an ascii string into a number. If it is possibly an integer X * return an integer. X * Otherwise return a double ( in res ) X * should never overflow. One day I may fix the non floating point one. X */ X X X#define BIG 1.701411835e37 X Xgetop() X{ X register double x = 0; X register int exponent = 0; X register int ndigits = 0; X register int c; X register int exp; X char decp = 0; X char lzeros = 0; X int minus; X short xx; X Xdot: for(c = *point ; isnumber(c) ; c = *++point){ X if(!lzeros){ X if(c == '0'){ /* ignore leading zeros */ X if(decp) X exponent--; X continue; X } X lzeros++; X } X if(ndigits >= 15){ /* ignore insignificant digits */ X if(!decp) X exponent++; X continue; X } X if(decp) X exponent--; X ndigits++; X x = x * 10 + c - '0'; X } X if(c == '.'){ X point++; X if(decp) X return(0); X decp++; X goto dot; X } X if(c == 'e' || c == 'E'){ X minus = 0; X if( (c = *++point) == '+') X point++; X else if(c =='-'){ X minus++; X point++; X } X else if(c < '0' || c > '9') X return(0); X for(exp = 0, c = *point; c >= '0' && c <= '9' ; c = *++point){ X if(exp < 1000) X exp = exp * 10 + c - '0'; X } X if(minus) X exponent -= exp; X else X exponent += exp; X } X while(exponent < 0){ X exponent++; X x /= 10; X } X while(exponent > 0){ X exponent--; X if(x > BIG) X return(0); X x *= 10; X } X xx = x; /* see if x is == an integer */ X /* X * shouldn't need a cast below but there is a bug in the 68000 X * compiler which does the comparison wrong without it. X */ X if( (double) xx == x){ X vartype= 01; X res.i = xx; X } else { X vartype = 0; X res.f = x; X } X return(1); X} X#endif End of bas9.c chmod u=rw-,g=r,o=r bas9.c echo x - gen 1>&2 sed 's/^X//' > gen << 'End of gen' Xcase $1 in X vax) X make -f vax/Makefile ;; X pdp11) X echo "Please specify pdp11fp or pdp11nofp" ;; X X pdp11fp) X make -f pdp11/Makefile.fp ;; X X pdp11nofp) X make -f pdp11/Makefile.nofp ;; X X m68000) X make -f m68000/Makefile ;; X X pyramid) X make -f pyramid/Makefile ;; X X clean) X rm -f *.o cursor.c term.c core basic ;; X X *) X echo "please specify one of vax pdp11fp pdp11nofp m68000 pyramid" ;; Xesac End of gen chmod u=rwx,g=xr,o=xr gen