4.3BSD/usr/contrib/apl/src/a0.c
static char Sccsid[] = "a0.c @(#)a0.c 1.4 6/4/85 Berkeley ";
#include <signal.h>
#include "apl.h"
#include <math.h>
int chartab[];
int mkcore = 0; /* produce core image upon fatal error */
int edmagic = 0; /* turn on "ed" magic characters */
main(argc, argp)
char **argp;
{
register char *p;
register a, b;
int c;
int fflag;
int intr(), intprws();
extern headline[];
#ifdef NBUF
struct iobuf iobf[NBUF]; /* Actual buffers */
#endif
time(&stime);
#ifdef NBUF
iobuf = iobf; /* Set up buffer pointer */
initbuf(); /* Set up to run */
#endif
/*
* setup scratch files
*/
a = getpid();
scr_file = "/tmp/apled.000000";
ws_file = "/tmp/aplws.000000";
for(c=16; c > 10; c--){
b = '0' + a%10;
scr_file[c] = b;
ws_file[c] = b;
a /= 10;
}
offexit = isatty(0);
echoflg = !offexit;
a = 1; /* catch signals */
/* Check to see if argp[0] is "prws". If so, set prwsflg */
for(p=argp[0]; *p; p++);
while(p > argp[0] && *p != '/') p--;
if (*p == '/') p++;
for(c=0; c < 4; c++)
if (!p[c] || p[c] != "prws"[c])
goto notprws;
prwsflg = 1;
CLOSEF(0);
notprws:
/* other flags... */
while(argc > 1 && argp[1][0] == '-'){
argc--;
argp++;
while(*++*argp) switch(**argp){
case 'e': echoflg = 1; break;
case 'q': echoflg = 0; break;
case 'd':
case 'D': a = 0;
case 'c':
case 'C': mkcore = 1; break;
case 't': scr_file += 5;
ws_file += 5;
case 'm': apl_term = 1; break;
case 'r': edmagic = 1; break;
case 'o': offexit = 0; break;
}
}
if (prwsflg)
echoflg = mkcore = a = 0; /* "prws" settings */
thread.iorg = 1;
srand(thread.rl = 1);
thread.width = 72;
thread.digits = 9;
thread.fuzz = 1.0e-13;
aplmod(1); /* Turn on APL mode */
if (a)
catchsigs();
if (prwsflg)
signal(SIGINT, intprws);
else
fppinit();
/*
* open ws file
*/
CLOSEF(opn(WSFILE,0600));
wfile = opn(WSFILE,2);
zero = 0;
one = 1;
maxexp = 88;
pi = 3.141592653589793238462643383;
sp = stack;
fflag = 1;
if (!prwsflg){
if((unsigned)signal(SIGINT, intr) & 01)
signal(SIGINT, 1);
printf(headline);
}
setexit();
if(fflag) {
fflag = 0;
if(argc > 1 && (a = opn(argp[1], 0)) > 0){
wsload(a);
printf(" %s\n", argp[1]);
CLOSEF(a);
} else {
if((a=OPENF("continue",0)) < 0) {
printf("clear ws\n");
} else {
wsload(a);
printf(" continue\n");
CLOSEF(a);
}
}
if (prwsflg){
ex_prws();
term(0);
}
evLlx(); /* eval latent expr, if any */
}
mainloop();
}
mainloop()
{
register char *a, *comp;
static eotcount = MAXEOT; /* maximum eot's on input */
setexit();
while(1){
if(echoflg)
echoflg = 1; /* enabled echo echo suppress off */
checksp();
if(intflg)
error("I");
putchar('\t');
a = rline(8);
if(a == 0) {
offexit &= isatty(0);
if (offexit) {
if (eotcount-- > 0)
printf("\ruse \')off\' to exit\n");
else
panic(0);
continue;
} else
term(0); /* close down and exit */
}
comp = compile(a, 0);
free(a);
if(comp == 0)
continue;
execute(comp);
free(comp);
/* note that if the execute errors out, then
* the allocated space pointed to by comp is never
* freed. This is hard to fix.
*/
}
}
intr()
{
intflg = 1;
signal(SIGINT, intr);
SEEKF(0, 0L, 2);
}
intprws()
{
/* "prws" interrupt -- restore old tty modes and exit */
term(0177);
}
char *
rline(s)
{
int rlcmp();
char line[CANBS];
register char *p;
register c, col;
char *cp, *retval;
char *dp;
int i,j;
column = 0;
col = s;
p = line;
loop:
c = getchar();
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 ' ':
col++;
goto loop;
case '\r':
col = 0;
goto loop;
default:
if (p >= line+CANBS-2 || col > 127)
error("line too long");
*p++ = col;
*p++ = c; /* was and'ed with 0177... */
col++;
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;
col = -1;
cp = (retval=alloc(c+3)) - 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;
}
#ifdef vax
i = ((i<<8) | *cp)&0177777;
#else
i |= *cp << 8;
#endif
for(j=0; chartab[j]; j++){
if(i == chartab[j]) {
*cp = j | 0200;
j = 0;
break;
}
}
if(j) {
yuck:
*cp = '\n';
pline(cp,++col);
error("Y error");
}
}
*++cp = '\n';
return(retval);
}
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;
putchar(c);
} while(c != '\n');
if(col) {
putto(col);
putchar('^');
putchar('\n');
}
}
putto(col)
{
while(col > column+8)
putchar('\t');
while(col > column)
putchar(' ');
}
term(s)
{
register j;
unlink(WSFILE);
unlink(scr_file);
putchar('\n');
aplmod(0); /* turn off APL mode */
for(j=0; j<NFDS; j++) /* Close files */
CLOSEF(j);
exit(s);
}
fix(d)
data d;
{
register i;
i = floor(d+0.5);
return(i);
}
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()
{
if(sp <= stack)
error("pop B");
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)--)
free(p[*p]);
}
free(p);
np->itemp = 0;
}
np->use = 0;
}
dealloc(p)
struct item *p;
{
switch(p->type) {
default:
printf("[dealloc botch: %d]\n", p->type);
return;
case LBL:
((struct nlist *)p)->use = 0; /* delete label */
case LV:
return;
case DA:
case CH:
case QQ:
case QD:
case QC:
case EL:
case DU:
case QX:
free(p);
}
}
struct item *
newdat(type, rank, size)
{
register i;
register struct item *p;
/* Allocate a new data item. I have searched the specifications
* for C and as far as I can tell, it should be legal to
* declare a zero-length array inside a structure. However,
* the VAX C compiler (which I think is a derivative of the
* portable C compiler) does not allow this. The Ritchie
* V7 PDP-11 compiler does. I have redeclared "dim" to
* contain MRANK elements. When the data is allocated,
* space is only allocated for as many dimensions as there
* actually are. Thus, if there are 0 dimensions, no space
* will be allocated for "dim". This had better make the
* VAX happy, since it has sure made me unhappy.
*
* --John Bruner
*/
if(rank > MRANK)
error("max R");
i = sizeof *p - SINT * (MRANK-rank);
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 = (data *)&p->dim[rank];
return(p);
}
struct item *
dupdat(ap)
struct item *ap;
{
register struct item *p1, *p2;
register i;
p1 = ap;
p2 = newdat(p1->type, p1->rank, p1->size);
for(i=0; i<p1->rank; i++)
p2->dim[i] = p1->dim[i];
copy(p1->type, p1->datap, p2->datap, p1->size);
return(p2);
}
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);
}
struct item *
fetch1()
{
register struct item *p;
p = fetch(sp[-1]);
sp[-1] = p;
return(p);
}
struct item *
fetch2()
{
register struct item *p;
sp[-2] = fetch(sp[-2]);
p = fetch(sp[-1]);
sp[-1] = p;
return(p);
}
struct item *
fetch(ip)
struct item *ip;
{
register struct item *p, *q;
register i;
struct nlist *n;
int c;
struct chrstrct *cc;
extern prolgerr;
p = ip;
loop:
switch(p->type) {
case QX:
free(p);
n = nlook("Llx");
if(n){
q = n->itemp;
p = dupdat(q);
copy(q->type, q->datap, p->datap, q->size);
} else
p = newdat(CH, 1, 0);
goto loop;
case QQ:
free(p);
cc = rline(0);
if(cc == 0)
error("eof");
for(i=0; cc->c[i] != '\n'; i++)
;
p = newdat(CH, 1, i);
copy(CH, cc, p->datap, i);
goto loop;
case QD:
case QC:
printf("L:\n\t");
i = rline(8);
if(i == 0)
error("eof");
c = compile(i, 1);
free(i);
if(c == 0)
goto loop;
i = pcp;
execute(c);
pcp = i;
free(c);
free(p);
p = *--sp;
goto loop;
case DU:
if(lastop != PRINT)
error("no fn result");
case DA:
case CH:
p->index = 0;
return(p);
case LV:
/* KLUDGE --
*
* Currently, if something prevents APL from completing
* execution of line 0 of a function, it leaves with
* the stack in an unknown state and "gsip->oldsp" is
* zero. This is nasty because there is no way to
* reset out of it. The principle cause of error
* exits from line 0 is the fetch of an undefined
* function argument. The following code attempts
* to fix this by setting an error flag and creating
* a dummy variable for the stack if "used before set"
* occurs in the function header. "ex_fun" then will
* note that the flag is high and cause an error exit
* AFTER all header processing has been completed.
*/
if(((struct nlist *)p)->use != DA){
printf("%s: used before set",
((struct nlist *)ip)->namep);
if ((!gsip) || gsip->funlc != 1)
error("");
q = newdat(DA, 0, 1); /* Dummy */
q->datap[0] = 0;
prolgerr = 1; /* ERROR flag */
return(q);
}
p = ((struct nlist *)p)->itemp;
i = p->type;
if(i == LBL)
i = DA; /* treat label as data */
q = newdat(i, p->rank, p->size);
copy(IN, p->dim, q->dim, p->rank);
copy(i, 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];
}
if (idx.dimk)
idx.size /= idx.dimk;
idx.rank--;
}
forloop(co, arg)
int (*co)();
{
register i;
if (idx.size == 0)
return; /* for null items */
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;
/* Get the data value stored at index p->index. If the
* index is out of range it will be wrapped around. If
* the data item is null, a zero or blank will be returned.
*/
p = ip;
i = p->index;
while(i >= p->size) {
if (p->size == 0) /* let the caller beware */
return((p->type == DA) ? zero : (data)' ');
/*
if (i == 0)
error("getdat B");
*/
i -= p->size;
}
if(p->type == DA) {
d = p->datap[i];
} else
if(p->type == CH) {
d = ((struct chrstrct *)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) {
((struct chrstrct *)p->datap)->c[i] = d;
} else
error("putdat B");
i++;
p->index = i;
}
/* aplmod has been moved to am.c */
struct item *
s2vect(ap)
struct item *ap;
{
register struct item *p, *q;
p = ap;
q = newdat(p->type, 1, 1);
q->datap = p->datap;
q->dim[0] = 1;
return(q);
}
struct nlist *
nlook(name)
char *name;
{
register struct nlist *np;
for(np = nlist; np->namep; np++)
if(equal(np->namep, name))
return(np);
return(0);
}
checksp()
{
if(sp >= &stack[STKS])
error("stack overflow");
}
char *
concat(s1,s2)
char *s1, *s2;
{
register i,j;
char *p,*q;
i = lsize(s1) - 1;
j = lsize(s2) - 1;
p = q = alloc(i+j);
p += copy(CH, s1, p, i);
copy(CH, s2, p, j);
return(q);
}
char *
catcode(s1,s2)
char *s1, *s2;
{
register i,j;
char *p,*q;
i = csize(s1) - 1;
j = csize(s2);
p = q = alloc(i+j);
p += copy(CH, s1, p, i);
copy(CH, s2, p, j);
return(q);
}
/*
* csize -- return size (in bytes) of a compiled string
*/
csize(s)
char *s;
{
register c,len;
register char *p;
int i;
len = 1;
p = s;
while((c = *p++) != EOF){
len++;
c &= 0377;
switch(c){
default:
i = 0;
break;
case QUOT:
i = *p++;
break;
case CONST:
i = *p++;
i *= SDAT;
len++;
break;
case NAME:
case FUN:
case ARG1:
case ARG2:
case AUTO:
case REST:
case RVAL:
i = 2;
break;
}
p += i;
len += i;
}
return(len);
}
opn(file, rw)
char file[];
{
register fd, (*p)();
char f2[100];
extern OPENF(), CREATF();
p = (rw > 2 ? CREATF : OPENF);
if((fd = (*p)(file,rw)) < 0){
for(fd=0; fd<13; fd++)
f2[fd] = LIBDIR[fd];
for(fd=0; file[fd]; fd++)
f2[fd+13] = file[fd];
f2[fd+13] = 0;
if((fd = (*p)(f2, rw)) >= 0){
printf("[using %s]\n", f2);
return(fd);
}
printf("can't open file %s\n", file);
error("");
}
return(fd);
}
catchsigs()
{
extern panic();
signal(SIGHUP, panic);
signal(SIGQUIT, panic);
signal(SIGILL, panic);
signal(SIGTRAP, panic);
signal(SIGEMT, panic);
/* signal(SIGFPE, fpe); /* (fppinit called by "main") */
signal(SIGBUS, panic);
signal(SIGSEGV, panic);
signal(SIGSYS, panic);
signal(SIGPIPE, panic);
signal(SIGTERM, panic);
}
panic(signum)
unsigned signum;
{
register fd;
static insane = 0; /* if != 0, die */
static char *abt_file = "aplws.abort";
static char *errtbl[] = {
"excessive eofs",
"hangup",
"interrupt",
"quit",
"illegal instruction",
"trace trap",
"i/o trap instruction",
"emt trap",
"floating exception",
"kill",
"bus error",
"segmentation violation",
"bad system call",
"write no pipe",
"alarm clock",
"software termination"
};
/* Attempt to save workspace. A signal out of here always
* causes immediate death.
*/
mencflg = 0;
signal(signum, panic);
printf("\nfatal signal: %s\n",
errtbl[(signum < NSIG) ? signum : 0]);
if (mkcore) abort();
if (!insane++){
if ((fd=CREATF(abt_file, 0644)) >= 0){
printf("[attempting ws dump]\n");
wssave(fd);
printf(" workspace saved in %s\n", abt_file);
CLOSEF(fd);
} else
printf("workspace lost -- sorry\n");
} else
printf("recursive errors: unrecoverable\n");
term(0);
}
#ifdef vax
abort(){
kill(getpid(), SIGIOT);
exit(1);
}
#endif