4.3BSD/usr/contrib/apl/src/ai.c
static char Sccsid[] = "ai.c @(#)ai.c 1.2 10/1/82 Berkeley ";
#include <signal.h>
#include "apl.h"
char *bad_fn = "apl.badfn";
int prolgerr; /* Flag -- set if bad fetch in prologue */
/*
* funedit -- edit a file and read it in.
*
* If the arg to funedit is non-zero, it is used as a
* pointer to the file name to be used. If it is zero,
* the namep of the function is used for the file name.
*/
funedit(fname, editor)
char *fname;
{
register struct item *p;
register f, (*a)();
char *c;
extern edmagic;
p = sp[-1];
if(p->type != LV)
error("fed B");
sichk(p);
if(fname == 0)
fname = ((struct nlist *)p)->namep;
a = signal(SIGINT, SIG_IGN);
f = FORKF(1);
if(f == 0) {
for(f=3; f<7; f++)
close(f);
c = (editor == DEL ? "/usr/bin/apldel" : "/usr/local/xed");
execl(c+9, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
execl(c+4, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
execl(c, c+9, fname, "-f", apl_term ? "-A":"-a", "-p", edmagic ? "-r":0, 0);
printf("cannot find the editor!\n");
exit(1);
}
if(f == -1)
error("try again");
while(wait(0) != f)
;
signal(SIGINT, a);
/* Read function into workspace. If "funread" (which calls
* "fundef") returns 0, an error occurred in processing the
* header (line 0). If this happened with "editf" or "del",
* save the bad function in the file "bad_fn".
*/
if (funread(fname) == 0 && fname == scr_file){
unlink(bad_fn);
if (badfnsv(fname))
printf("function saved in %s\n", bad_fn);
}
}
funread(fname)
char *fname;
{
register struct item *p;
register f, pid;
p = sp[-1];
sp--;
if(p->type != LV)
error("fnl B");
if(fname == 0)
fname = ((struct nlist *)p)->namep;
f = opn(fname, 0);
return(fundef(f));
}
funwrite(fname)
char *fname;
{
register struct nlist *n;
register i, cnt;
int fd1, fd2;
char buf[512];
n = (struct nlist *)sp[-1];
sp--;
if(n->type != LV)
error("fnwrite B");
if(fname ==0)
fname = n->namep;
fd1 = opn(fname, 0644);
switch(n->use){
default:
CLOSEF(fd1);
error("fnwrite T");
case 0: /* undefined fn */
printf("\t[new fn]\n");
break; /* empty file already created -- do nothing */
case NF:
case MF:
case DF:
fd2 = DUPF(wfile);
SEEKF(fd2, (long)n->label, 0);
do {
cnt = READF(fd2, buf, 512);
if(cnt <= 0)
error("fnwrite eof");
for(i=0; i<cnt; i++)
if(buf[i] == 0)
break;
WRITEF(fd1, buf, i);
} while(i == 512);
CLOSEF(fd2);
break;
}
CLOSEF(fd1);
}
fundef(f)
{
register a, c;
struct nlist *np;
char b[512];
ifile = f;
a = rline(0);
if(a == 0)
error("fnd eof");
c = compile(a, 2);
free(a);
if(c == 0)
goto out;
copy(IN, c+1, &np, 1);
sichk(np);
erase(np);
np->use = ((struct chrstrct *)c)->c[0];
np->label = SEEKF(wfile, 0L, 2);
SEEKF(ifile, 0L, 0);
while((a=READF(ifile, b, 512)) > 0)
WRITEF(wfile, b, a);
WRITEF(wfile, "", 1);
out:
CLOSEF(ifile);
ifile = 0;
return(c);
}
data lnumb;
char *labcpp,*labcpe;
funcomp(np)
struct nlist *np;
{
register char *a, *c;
register *p;
int i, err, size;
char labp[MAXLAB*20], labe[MAXLAB*4];
ifile = DUPF(wfile);
SEEKF(ifile, (long)np->label, 0);
size = 0;
err = 0;
labgen = 0;
pass1:
a = rline(0);
if(a == 0) {
if(err)
goto out;
p = (int *)alloc((size+2)*SINT);
*p = size;
size = 0;
SEEKF(ifile, (long)np->label, 0);
err++;
labcpp = labp;
labcpe = labe;
labgen = 1;
goto pass2;
}
c = compile(a, size==0? 3: 5);
size++;
free(a);
if(c == 0) {
err++;
goto pass1;
}
free(c);
goto pass1;
pass2:
a = rline(0);
if(a == 0)
goto pass3;
lnumb = size;
c = compile(a, size==0? 3: 5);
size++;
free(a);
if(c == 0)
goto out;
p[size] = c;
goto pass2;
pass3:
labgen = 0;
SEEKF(ifile, (long)np->label, 0);
a = rline(0);
if(a == 0){
err++;
goto out;
}
c = compile(a, 4);
free(a);
if(c == 0)
goto out;
if(labcpp != labp){
reverse(labe);
p[size+1] = catcode(labe, c);
free(c);
/*
/* *** KLUDGE ***
/*
/* due to the "line-at-a-time" nature of the parser,
/* we have to screw around with the compiled strings.
/*
/* At this point, we have:
/*
/* fn-prologue (p[1]): <AUTOs and ARGs>, ELID, EOF
/* label-prologue (labp): <AUTOs and LABELs>, EOF
/*
/* and we want to produce:
/*
/* fn-prologue (p[1]): <AUTOs and ARGs>,<AUTOs and LABELs>, ELID, EOF.
*/
a = csize(p[1]) - 1;
c = csize(labp) - 1;
/*
* if there is an ELID at the end of the fn-prologue,
* move it to the end of the label-prologue.
*/
if (p[1]->c[(int)a-1] == ELID){
p[1]->c[(int)a-1] = EOF;
labp[(int)c] = ELID;
labp[(int)c+1] = EOF;
} else
error("elid B");
/* *** END KLUDGE *** */
a = p[1];
p[1] = catcode(a,labp);
free(a);
} else
p[size+1] = c;
if(debug) {
dump(p[1], 1);
dump(p[size+1], 1);
}
np->itemp = (struct item *)p;
err = 0;
out:
CLOSEF(ifile);
ifile = 0;
if(err)
error("syntax");
}
ex_fun()
{
struct nlist *np;
register *p, s;
struct si si;
pcp += copy(IN, pcp, &np, 1);
if (np->use < NF || np->use > DF) {
printf("%s: ", np->namep);
error("not a fn");
}
if(np->itemp == 0)
funcomp(np);
p = (int *)np->itemp;
/* setup new state indicator */
si.sip = gsip;
gsip = &si;
si.np = np;
si.oldsp = 0; /* we can add a more complicated version, later */
si.oldpcp = pcp;
si.funlc = 0;
si.suspended = 0;
prolgerr = 0; /* Reset error flag */
s = *p;
checksp();
if(funtrace)
printf("\ntrace: fn %s entered: ", np->namep);
if (setjmp(si.env))
goto reenter;
while(1){
si.funlc++;
if(funtrace)
printf("\ntrace: fn %s[%d]: ", np->namep, si.funlc-1);
execute(p[si.funlc]);
if(si.funlc == 1){
si.oldsp = sp;
if (prolgerr)
error("");
}
if(intflg)
error("I");
reenter:
if(si.funlc <= 0 || si.funlc >= s) {
si.funlc = 1; /* for pretty traceback */
if(funtrace)
printf("\ntrace: fn %s exits ", np->namep);
execute(p[s+1]);
/* restore state indicator to previous state */
gsip = si.sip;
pcp = si.oldpcp;
return;
}
pop();
}
}
ex_arg1()
{
register struct item *p;
struct nlist *np;
pcp += copy(IN, pcp, &np, 1);
p = fetch1();
sp[-1] = np->itemp;
np->itemp = p;
np->use = DA;
}
ex_arg2()
{
register struct item *p1, *p2;
struct nlist *np1, *np2;
pcp += copy(IN, pcp, &np2, 1); /* get first argument's name */
pcp++; /* skip over ARG1 */
pcp += copy(IN, pcp, &np1, 1); /* get second arg's name */
p1 = fetch1(); /* get first expr to be bound to arg */
p2 = fetch(sp[-2]); /* get second one */
sp[-1] = np1->itemp; /* save old value of name on stack */
sp[-2] = np2->itemp; /* save second */
np1->itemp = p1; /* new arg1 binding */
np2->itemp = p2; /* ditto arg2 */
np1->use = DA; /* release safety catch */
np2->use = DA;
}
ex_auto()
{
struct nlist *np;
pcp += copy(IN, pcp, &np, 1);
checksp();
*sp++ = np->itemp;
np->itemp = 0;
np->use = 0;
}
ex_rest()
{
register struct item *p;
struct nlist *np;
p = sp[-1];
/*
* the following is commented out because
* of an obscure bug in the parser, which is
* too difficult to correct right now.
* the bug is related to the way the
* "fn epilog" is compiled. To accomodate labels,
* it was kludged up to have the label restoration
* code added after the entire fn was parsed. A problem
* is that the generated code is like:
*
* "rest-lab1 rest-lab2 eol rval-result rest-arg1 ..."
*
* the "eol rval-result" pops off the previous result, and
* puts a "fetched" version of the returned value (result)
* onto the stack. The bug is that the "eol rval." should
* be output at the beginning of the fn epilog.
* The following two lines used to be a simple
* "p = fetch(p)", which is used to disallow
* a fn to return a LV, (by fetching it, it gets
* converted to a RVAL.) Since we later added
* code which returned stuff which could not be
* fetched (the DU, dummy datum, for example),
* this thing had to be eliminated. An earlier
* version only fetched LV's, but that was eliminated
* by adding the "RVAL" operator. The test below
* was made a botch, because no LV's should ever be
* passed back. However, for this to be true, the
* "eol" should be executed first, so that any possible
* LV's left around by the last line executed are
* discarded. Since we have some "rest"s in the epilog
* before the eol, the following test fails.
* I can't think of why it won't work properly as it
* is, but if I had the time, I'd fix it properly.
* --jjb
*/
/* if(p->type == LV)
error("rest B"); */
pcp += copy(IN, pcp, &np, 1);
erase(np);
np->itemp = sp[-2];
np->use = 0;
if(np->itemp)
np->use = DA;
sp--;
sp[-1] = p;
}
ex_br0()
{
gsip->funlc = 0;
ex_elid();
}
ex_br()
{
register struct item *p;
p = fetch1();
if(p->size == 0)
return;
gsip->funlc = fix(getdat(p));
}
/*
* immediate niladic branch -- reset SI
*/
ex_ibr0()
{
register struct si *s;
register *p;
s = gsip;
if(s == 0)
error("no suspended fn");
if(s->suspended == 0)
error("imm } B1");
gsip->suspended = 0;
while((s = gsip) && s->suspended == 0){
if(s->oldsp == 0 || sp < s->oldsp)
error("imm } B2");
while(sp > s->oldsp){
pop();
}
pop(); /* pop off possibly bad previous result */
ex_nilret(); /* and stick on some dummy datum */
p = (int *)s->np->itemp;
execute(p[*p + 1]);
gsip = s->sip;
}
if(gsip == 0)
while(sp > stack)
pop();
}
/*
* monadic immediate branch -- resume fn at specific line
*/
ex_ibr()
{
register struct si *s;
if((s = gsip) == 0)
error("no suspended fn");
ex_br();
if(s->oldsp == 0 || sp < s->oldsp)
error("imm }n B");
while(sp > s->oldsp){
pop();
}
pop(); /* pop off possibly bad previous result */
ex_nilret(); /* and stick on some dummy datum */
longjmp(s->env); /* warp out */
}
ex_fdef()
{
register struct item *p;
register char *p1, *p2;
struct nlist *np;
char b[512];
int i, dim0, dim1;
p = fetch1();
if((p->rank != 2 && p->rank != 1) || p->type != CH)
error("Lfx D");
/* The following code has been commented out as a
* test of slight modifications to the compiler.
* Before this change, it was impossible to use "Lfx"
* from inside an APL function, for it might damage
* an existing function by the same name. The compiler
* now checks when processing function headers to see
* if the function is suspended by calling "sichk", which
* will generate an error if so. Hopefully this will now
* allow "Lfx" to be used freely without disastrous side-
* effects.
*/
/* if(gsip)
error("si damage -- type ')reset'"); */
dim0 = p->dim[0];
dim1 = p->dim[1];
if(p->rank == 1)
dim1 = dim0;
copy(CH, p->datap, b, dim1);
b[dim1] = '\n';
p2 = compile(b, 2);
if(p2 != 0){
copy(IN, p2+1, &np, 1);
erase(np);
np->use = *p2;
free(p2);
np->label = SEEKF(wfile, 0L, 2);
fappend(wfile, p);
WRITEF(wfile,"",1);
}
pop();
*sp++ = newdat(DA, 1, 0);
}
ex_nilret()
{
checksp();
*sp++ = newdat(DU,0,0); /* put looser onto stack */
/* (should be discarded) */
}
reverse(s)
char *s;
{
register char *p, *q;
register char c;
int j;
#define EXCH(a,b) {c=a;a=b;b=c;}
p = q = s;
while(*p != EOF)
p++;
p -= 1+sizeof(char *);
while(q < p){
for(j=0; j<1+sizeof (char *); j++)
EXCH(p[j], q[j]);
q += j;
p -= j;
}
}
/*
* produce trace back info
*/
char *atfrom[] = {"at\t", "from\t", "", ""};
tback(flag)
{
register struct si *p;
register i;
p = gsip;
i = 0;
if(flag)
i = 2;
while(p){
if(flag==0 && p->suspended)
return;
if (p->funlc != 1 || i){ /* skip if at line 0 */
printf("%s%s[%d]%s\n",
atfrom[i],
p->np->namep,
p->funlc - 1,
(p->suspended ? " *" : "")
);
i |= 1;
}
p = p->sip;
}
}
sichk(n)
struct nlist *n;
{
register struct si *p;
p = gsip;
while(p){
if(n == p->np)
error("si damage -- type ')reset'");
p = p->sip;
}
}
ex_shell(){
/* If the environment variable SHELL is defined, attempt to
* execute that shell. If not, or if that exec fails, attempt
* to execute the standard shell, /bin/sh
*/
int (*addr)(), (*addr2)();
char *getenv();
register char *sh;
register i;
addr = signal(SIGINT, SIG_IGN);
addr2 = signal(SIGQUIT, SIG_IGN);
i = FORKF(1);
if (i == 0){
for(i=3; i<20; i++) close(i);
signal(SIGINT, SIG_DFL);
signal(SIGQUIT, SIG_DFL);
if (sh=getenv("SHELL"))
execl(sh, sh, 0);
execl("/bin/sh", "sh", 0);
printf("no shell!\n");
exit(1);
}
if (i == -1) error("try again");
while(wait(0) != i);
signal(SIGINT, addr);
signal(SIGQUIT, addr2);
}
badfnsv(fname)
char *fname;
{
/* This routine saves the contents of "fname" in the file
* named in "bad_fn". It is called by "funedit" if the
* header of a function just read in is messed up (thus,
* the entire file is not lost). Returns 1 if successful,
* 0 if not.
*/
register fd1, fd2, len;
char buf[512];
if ((fd1=OPENF(fname, 0)) < 0 || (fd2=CREATF(bad_fn, 0644)) < 0)
return(0);
while((len=READF(fd1, buf, 512)) > 0)
WRITEF(fd2, buf, len);
CLOSEF(fd1);
CLOSEF(fd2);
return(1);
}