BSD 3 development

[unix-history] / usr / src / cmd / apl / a0.c

#include "apl.h"
/*#include "/usr/sys/tty.h"     /* pick up TECO-mode bit */
#define APLMOD  01000
short TERMtype = 0 ; /* for now ( very stupid variable) */

short   chartab[];
char    partab[1];

int     ifile = 0,
       ofile = 1;

data    zero    =  0.0;
data    one     =  1.0;
data    pi      =  3.141592653589793238462643383;
data    maxexp  = 88.0;

struct  env thread = {
       1.0e-13,   1,
       9,        72
};

main(ac,av)
char  **av;
{
       register a, c;
       int fflag;
       int intr();
       int floatover();
       extern headline[];

       memstart = sbrk(0);

       Reset();
       signal(8,floatover);
       if(--ac&&*av[1]=='-')
               ++echoflg;
       time(stime);
       setterm(1);                             /* turn off APL mode */
       aprintf(headline);
       
       if(ttyname(0) == 'x')
               echoflg++;

       a = "apl_ws";
       while((wfile = open(a, 2)) < 0) {
               c = creat(a, 0666);
               if(c < 0) {
                       aprintf("cannot create apl_ws");
                       exit(0);
               }
               close(c);
       }

       fflag = 1;

       sp = stack;
       signal(2, intr);
       setexit();

       if(fflag) {
               fflag =0;
               if((a=open("continue",0)) < 0) {
                       aprintf("clear ws\n");
                       goto loop;
               }
               wsload(a);
               aprintf(" continue\n");
       }

loop:
       while(sp > stack)
               pop();
       Reset();
       signal(8,floatover);
       if(intflg)
               error("I");
               if(!ifile&&ofile==1)
               aputchar('\t');
       a = rline(8);
       if(a==0) {
               if(ifile) {
                       ifile = 0;
                       goto loop;
               }
               ctrld();
       }
       c = compile(a, 0);
       afree(a);
       if(c == 0)
               goto loop;
       execute(c);
       afree(c);
       goto loop;
}

/* this procedure is for trapping floating point exceptions, and        */
/* then reset the program.  added june 1979                             */

floatover() {
       printf("\t\nerror -- floating point exception\n");
       signal(8,floatover);
       reset();
};



setterm(toggle) 
{       TERMtype = toggle;
       aplmod(toggle + 1);
}


nargs()
{
       return 1;
}

Reset()
{
       afree(stack);
       cs_size = STKS;
       stack = alloc(sizeof(sp)*STKS); /* Set up internal stack */
       sp = stack;
       staktop = &stack[STKS-1];
}

intr()
{

       intflg = 1;
       signal(2, intr);
       lseek(0, 0, 2);
}

rline(s)
{
       int rlcmp();
       char line[CANBS];
       register char *p;
       register c, col;
       char *cp;
       char *dp;
       short  i;
       int     j;

       column = 0;
       col = s;
       p = line;
loop:
       c = agetchar();
       if(intflg)
               error("I");
       switch(c) {

       case '\0':
       case -1:
               return(0);

       case '\b':
               if(col)
                       col--;
               goto loop;

       case '\t':
               col = (col+8) & ~7;
               goto loop;

       case ' ':
       case 016:       /* cursor right */
               col++;
               goto loop;

       case '\r':
               col = 0;
               goto loop;

       default:
               *p++ = col;
               *p++ = c & 0177;
               col++;
               goto loop;

       case 033:       /* escape - APL line feed */
               for(cp=dp=line; cp<p; cp+= 2)
                       if(*cp < col) {
                               *dp++ = *cp;
                               *dp++ = cp[1];
                       }
               p = dp;
               aputchar('\n');
               putto(col);
               aputchar(')');
               aputchar('\n');
               putto(col);
               column=0;
               goto loop;

       case '\n':
               ;
       }
       qsort(line, (p-line)/2, 2, rlcmp);
       c = p[-2];
       if(p == line)
               c = 1;  /* check for blank line */
       *p = -1;
       c = alloc((int)(c+3));
       col = -1;
       cp = c - 1;
       for(p=line; p[0] != -1; p+=2) {
               while(++col != p[0])
                       *++cp = ' ';
               *++cp = p[1];
               while(p[2] == col) {
                       if(p[3] != *cp) {
                               i = *cp ;
                               *cp = p[3];
                               break;
                       }
                       p += 2;
               }
               if(p[2] != col) continue;
               while(p[2] == col) {
                       if(p[3] != *cp)
                               goto yuck;
                       p += 2;
               }
               i |= *cp << 8;
               for (j=41;j>=0;j--) 
                       if ((i.c[0] == chartab[j].a1) && ( i.c[1]==chartab[j].a2)) {
                               *cp = j | 0200;
                               j = 0;
                               break;
                       }
               if(j) {
yuck:
                       *cp = '\n';
                       pline(c,++col);
                       error("Y E");
               }
       }
       *++cp = '\n';
       return(c);
}

rlcmp(a, b)
char *a, *b;
{
       register c;

       if(c = a[0] - b[0])
               return(c);
       return(a[1] - b[1]);
}

pline(str, loc)
char *str;
{
       register c, l, col;

       col = 0;
       l = 0;
       do {
               c = *str++;
               l++;
               if(l == loc)
                       col = column;
               aputchar(c);
       } while(c != '\n');
       if(col) {
               putto(col);
               if (TERMtype == 0)aputchar(')');
               else aputchar('^');
               aputchar('\n');
       }
}

putto(col)
{
       while(col > column+8)
               aputchar('\t');
       while(col > column)
               aputchar(' ');
}

term()
{

       unlink("apl_ws");
       aputchar('\n');
       aplmod(0);      /*turn off APL mode */
       exit(0);
}

fix(d)
data d;
{
       register i;

       i = floor(d+0.5);
       return(i);
}

xeq_mark()
{
       if(now_xeq.name) {
               aprintf(now_xeq.name);
               aprintf(" ;%d'\n", now_xeq.line);
       }
       now_xeq.name = now_xeq.line = 0;
}

error(s)
char *s;
{
       register c;
       register char *cp;

       intflg = 0;
       if(ifile)
               close(ifile);
       if(ofile&&ofile!=1)
               close(ofile);
       ifile = 0;
       ofile = 1;
       xeq_mark();
       cp = s;
       while(c = *cp++) {
               if(c >= 'A' && c <= 'Z') {
                       switch(c) {

                       case 'L':
                               c = "length";
                               break;
                       case 'I':
                               c = "\ninterrupt";
                               break;

                       case 'C':
                               c = "conformability";
                               break;

                       case 'S':
                               c = "syntax";
                               break;

                       case 'R':
                               c = "rank";
                               break;

                       case 'X':
                               c = "index";
                               break;

                       case 'Y':
                               c = "character";
                               break;

                       case 'M':
                               c = "memory";
                               break;

                       case 'D':
                               c = "domain";
                               break;

                       case 'T':
                               c = "type";
                               break;

                       case 'E':
                               c = "error";
                               break;

                       case 'B':
                       default:
                               c = "botch";
                       }
                       aprintf(c);
                       continue;
               }
               aputchar(c);
       }
       aputchar('\n');
       reset();
};

/* procedure to catch control d and prevent it from logging out the user*/

ctrld(){
       aprintf("\nto exit type \"off\nto exit and save workspace type \"continue\n");
       reset();
}

aprintf(f, a)
char *f;
{
       register char *s;
       register *p;

       s = f;
       p = &a;
       while(*s) {
               if(s[0] == '%' && s[1] == 'd') {
                       putn(*p++);
                       s += 2;
                       continue;
               }
               aputchar(*s++);
       }
}  

putn(n)
{
       register a;

       if(n < 0) {
               n = -n;
               if(n < 0) {
                       aprintf("2147483648");
                       return;
               }
               aputchar('@');  /* apl minus sign */
       }
       if(a=n/10)
               putn(a);
       aputchar(n%10 + '0');
}
agetchar()
{
       int c;

       c = 0;
       read(ifile, &c, 1);
       if(echoflg)
               write(1, &c, 1);
       return(c);
}

aputchar(c)
register c;
{
       register i;
       unsigned char c2;
       extern unsigned char changeoutput[];

       if(TERMtype == 1)               /* ascii terminal */
               c = changeoutput [ (0377 & c) ];


       switch(c) {

       case '\0':
               return;

       case '\b':
               if(column)
                       column--;
               break;

       case '\t':
               column = (column+8) & ~7;
               break;

       case '\r':
       case '\n':
               column = 0;
               break;

       default:
               column++;
       }
       /* for encode numbers */  
       if(mencflg) {
               if(c != '\n') {
                       mencflg = 1;
                       *mencptr++ = c;
               }
               else
                       if(mencflg > 1)
                               mencptr += rowsz;
                       else
                               mencflg = 2;
               return;
       }
       if(intflg == 0) {
               if(c & 0200) {
                       i = chartab[c & 0177];
                       aputchar(i>>8);
                       c = i & 0177;
                       aputchar('\b');
               }
               c2 = c;
               write(ofile, &c2, 1);
       }
} 

fuzz(d1, d2)
data d1, d2;
{
       double f1, f2;

       f1 = d1;
       if(f1 < 0.)
               f1 = -f1;
       f2 = d2;
       if(f2 < 0.)
               f2 = -f2;
       if(f2 > f1)
               f1 = f2;
       f1 *= thread.fuzz;
       if(d1 > d2) {
               if(d2+f1 >= d1)
                       return(0);
               return(1);
       }
       if(d1+f1 >= d2)
               return(0);
       return(-1);
}

pop()
{
       dealloc(*--sp);
}

erase(np)
struct nlist *np;
{
       register *p;

       p = np->itemp;
       if(p) {
               switch(np->use) {
               case NF:
               case MF:
               case DF:
                       for(; *p>0; (*p)--)
                               afree(p[*p]);

               }
               afree(p);
               np->itemp = 0;
       }
       np->use = 0;
}

dealloc(p)
struct item *p;
{

       switch(p->type) {

       case DA:
       case CH:
       case QQ:
       case QD:
       case QC:
       case EL:
               afree(p);
       }
}

newdat(type, rank, size)
{
       register i;
       register struct item *p;

       if(rank > MRANK)
               error("R E");
       i = sizeof *p + rank * SINT;
       if(type == DA)
               i += size * SDAT; else
       if(type == CH)
               i += size;
       p = alloc(i);
       p->rank = rank;
       p->type = type;
       p->size = size;
       p->index = 0;
       if(rank == 1)
               p->dim[0] = size;
       p->datap = &p->dim[rank];
       return(p);
}

copy(type, from, to, size)
char *from, *to;
{
       register i;
       register char *a, *b;
       int s;
       


       if((i = size) == 0)
               return(0);
       a = from;
       b = to;
       if(type == DA)
               i *= SDAT; else
       if(type == IN)
               i *= SINT;
       s = i;
       do
               *b++ = *a++;
       while(--i);
       return(s);
}

fetch1()
{
       return sp[-1] = fetch(sp[-1]);
}

fetch2()
{
       sp[-2] = fetch(sp[-2]);
       return sp[-1] = fetch(sp[-1]);
}

fetch(ip)
struct item *ip;
{
       register struct item *p, *q;
       char *ubset;
       register i;
       int c;

       p = ip;

loop:
       switch(p->type) {

       case QQ:
               afree(p);
               c = rline(0);
               if(c == 0)
                       error("eof");
               for(i=0; c->c[i] != '\n'; i++)
                       continue;
               p = newdat(CH, 1, i);
               copy(CH, c, p->datap, i);
               goto loop;

       case QD:
       case QC:
               if(!ifile&&ofile==1)
                       aprintf("L>\n\t");
               i = rline(8);
               if(i == 0)
                       error("eof");
               c = compile(i, 1);
               afree(i);
               if(c == 0)
                       goto loop;
               i = pcp;
               execute(c);
               pcp = i;
               afree(c);
               afree(p);
               p = *--sp;
               goto loop;

       case DA:
       case CH:
               p->index = 0;
               return(p);

       case LV:
               if(p->use != DA) {
                       ubset = ip->namep;
                       xeq_mark();
                       while(*ubset)
                               aputchar(*ubset++);
                       error("> used before set\n");
               }
               p = p->itemp;
               q = newdat(p->type, p->rank, p->size);
               copy(IN, p->dim, q->dim, p->rank);
               copy(p->type, p->datap, q->datap, p->size);
               return(q);

       default:
               error("fetch B");
       }
}

topfix()
{
       register struct item *p;
       register i;

       p = fetch1();
       if(p->type != DA || p->size != 1)
               error("topval C");
       i = fix(p->datap[0]);
       pop();
       return(i);
}

bidx(ip)
struct item *ip;
{
       register struct item *p;

       p = ip;
       idx.type = p->type;
       idx.rank = p->rank;
       copy(IN, p->dim, idx.dim, idx.rank);
       size();
}

size()
{
       register i, s;

       s = 1;
       for(i=idx.rank-1; i>=0; i--) {
               idx.del[i] = s;
               s *= idx.dim[i];
       }
       idx.size = s;
       return(s);
}

colapse(k)
{
       register i;

       if(k < 0 || k >= idx.rank)
               error("collapse X");
       idx.dimk = idx.dim[k];
       idx.delk = idx.del[k];
       for(i=k; i<idx.rank; i++) {
               idx.del[i] = idx.del[i+1];
               idx.dim[i] = idx.dim[i+1];
       }
       idx.size /= idx.dimk;
       idx.rank--;
}

forloop(co, arg)
int (*co)();
{
       register i;

       if(idx.rank == 0) {
               (*co)(arg);
               return;
       }
       for(i=0;;) {
               while(i < idx.rank)
                       idx.idx[i++] = 0;
               (*co)(arg);
               while(++idx.idx[i-1] >= idx.dim[i-1])
                       if(--i <= 0)
                               return;
       }
}

access()
{
       register i, n;

       n = 0;
       for(i=0; i<idx.rank; i++)
               n += idx.idx[i] * idx.del[i];
       return(n);
}

data
getdat(ip)
struct item *ip;
{
       register struct item *p;
       register i;
       data d;

       p = ip;
       i = p->index;
       while(i >= p->size) {
               if(i == 0)
                       error("getdat B");
               i -= p->size;
       }
       if(p->type == DA) {
               d = p->datap[i];
       } else
       if(p->type == CH) {
               d = p->datap->c[i];
       } else
               error("getdat B");
       i++;
       p->index = i;
       return(d);
}

putdat(ip, d)
data d;
struct item *ip;
{
       register struct item *p;
       register i;

       p = ip;
       i = p->index;
       if(i >= p->size)
               error("putdat B");
       if(p->type == DA) {
               p->datap[i] = d;
       } else
       if(p->type == CH) {
               p->datap->c[i] = d;
       } else
               error("putdat B");
       i++;
       p->index = i;
}

aplmod(xyz)
{
static firstvisit=0;
static short  old[3], new[3];
static short  diff;
       if(xyz> 0) {
               if (firstvisit == 0){
                       if(gtty(0,old)<0) {
                               diff = 0;
                               return;
                       }
                       diff = 1;
               }
               if (diff == 1) {
                       gtty(0, new);
                       if (xyz == 1)new[1] = 'W'|'A'<<8; /* apl terminal */
                       else new[1] = '\b'|'@'<<8;  /* ascii terminal */
                       stty(0, new);
                       if (firstvisit)
                       if (xyz == 1)aprintf("erase%KWK kill%KAK\n\n");
                       else aprintf("erase ^H kill @\n\n");
               }
               firstvisit++;
       } else {
               if(diff)
                       stty(0, old);
       } 
}