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