Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume7/basic/part03

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

Subject:  v07i075:  A BASIC Interpreter, Part03/06
Newsgroups: mod.sources
Approved: mirror!rs

Submitted by: [e-mail]
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