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);
	} 
}