lispval
Lflatsi()
{
register lispval current;
Savestack(1); /* fixup entry mask */
fmax = 0x7fffffff; /* biggest integer by default */
switch(np-lbot)
{
case 2: current = lbot[1].val;
while(TYPE(current) != INT)
current = errorh1(Vermisc,
"flatsize: second arg not integer",
nil,TRUE,0,current);
fmax = current->i;
case 1: break;
default: argerr("flatsize");
}
flen = 0;
current = lbot->val;
protect(nil); /*create space for argument to pntlen*/
Iflatsi(current);
Restorestack();
return(inewint(flen));
}
lispval
Levalhook()
{
register lispval handy;
register lispval funhval = CNIL;
switch (np-lbot)
{
case 2: break;
case 3: funhval = (lbot+2)->val;
break;
default: argerr("evalhook");
}
/* Don't do this check any longer
* if (evalhsw == 0)
* error("evalhook called before doing sstatus-evalhook", TRUE);
* if (rsetsw == 0 || rsetatom->a.clb == nil)
* error("evalhook called while not in *rset mode", TRUE);
*/
if(funhval != CNIL) { PUSHDOWN(funhatom,funhval); }
PUSHDOWN(evalhatom,(lispval)(lbot+1)->val);
/* eval checks evalhcall to see if this is a LISP call to evalhook
in which case it avoids call to evalhook function, but clobbers
value to nil so recursive calls will check. */
evalhcallsw = TRUE;
handy = eval(lbot->val);
POP;
if(funhval != CNIL) { POP; }
return(handy);
}
lispval
Lfunhook()
{
register lispval handy;
register lispval evalhval = CNIL;
Savestack(2);
switch (np-lbot)
{
case 2: break;
case 3: evalhval = (lbot+2)->val;
break;
default: argerr("funcallhook");
}
/* Don't do this check any longer
* if (evalhsw == 0)
* error("funcallhook called before doing sstatus-evalhook", TRUE);
*if (rsetsw == 0 || rsetatom->a.clb == nil)
* error("funcallhook called while not in *rset mode", TRUE);
*/
handy = lbot->val;
while (TYPE(handy) != DTPR)
handy = errorh1(Vermisc,"funcallhook: first arg must be a list",nil,TRUE,
0,handy);
if(evalhval != CNIL) { PUSHDOWN(evalhatom,evalhval); }
PUSHDOWN(funhatom,(lispval)(lbot+1)->val);
/* funcall checks funcallhcall to see if this is a LISP call to evalhook
in which case it avoids call to evalhook function, but clobbers
value to nil so recursive calls will check. */
funhcallsw = TRUE;
/*
* the first argument to funhook is a list of already evaluated expressions
* which we just stack can call funcall on
*/
lbot = np; /* base of new args */
for ( ; handy != nil ; handy = handy->d.cdr)
{
protect(handy->d.car);
}
handy = Lfuncal();
POP;
if(evalhval != CNIL) { POP; }
Restorestack();
return(handy);
}
/* this was changed from throw to *throw 21nov79
it is now a lambda and really should be called Lthrow
*/
lispval
Nthrow()
{
switch(np-lbot) {
case 0:
protect(nil);
case 1:
protect(nil);
case 2: break;
default:
argerr("throw");
}
Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
/* NOT REACHED */
}
lispval
Lexece()
{
lispval fname, arglist, envlist, temp;
char *args[100], *envs[100], estrs[1024];
char *p, *cp, **argsp;
fname = nil;
arglist = nil;
envlist = nil;
switch(np-lbot) {
case 3: envlist = lbot[2].val;
case 2: arglist = lbot[1].val;
case 1: fname = lbot[0].val;
case 0: break;
default:
argerr("exece");
}
while (TYPE(fname)!=ATOM)
fname = error("exece: non atom function name",TRUE);
while (TYPE(arglist)!=DTPR && arglist!=nil)
arglist = error("exece: non list arglist",TRUE);
for (argsp=args; arglist!=nil; arglist=arglist->d.cdr) {
temp = arglist->d.car;
if (TYPE(temp)!=ATOM)
error("exece: non atom argument seen",FALSE);
*argsp++ = temp->a.pname;
}
*argsp = 0;
if (TYPE(envlist)!=DTPR && envlist!=nil)
return(nil);
for (argsp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
temp = envlist->d.car;
if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
|| TYPE(temp->d.cdr)!=ATOM)
error("exece: Bad enviroment list",FALSE);
*argsp++ = cp;
for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
*(cp-1) = '=';
for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
}
*argsp = 0;
return(inewint(execve(fname->a.pname, args, envs)));
}
lispval
Lsetsyn()
{
register lispval s, c;
register struct argent *mynp;
register index;
lispval x /* ,debugmode */;
extern unsigned char *ctable;
extern lispval Istsrch();
switch(np-lbot) {
case 2:
x= nil; /* only 2 args given */
case 3:
x = lbot[2].val; /* all three args given */
break;
default:
argerr("setsyntax");
}
s = Vreadtable->a.clb;
chkrtab(s);
/* debugging code
debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
if(debugmode) printf("Readtable addr: %x\n",ctable);
end debugging code */
mynp = lbot;
c = (mynp++)->val;
s = (mynp++)->val;
switch(TYPE(c)) {
default:
error("neither fixnum, atom or string as char to setsyntax",FALSE);
case ATOM:
index = *(c->a.pname);
if((c->a.pname)[1])
errorh1(Vermisc,"Only 1 char atoms to setsyntax",
nil,FALSE,0,c);
break;
case INT:
index = c->i;
break;
case STRNG:
index = (int) *((char *) c);
}
switch(TYPE(s)) {
case ATOM:
if(s==splice || s==macro) {
if(s==splice)
ctable[index] = VSPL;
else if(s==macro)
ctable[index] = VMAC;
if(TYPE(c)!=ATOM) {
strbuf[0] = index;
strbuf[1] = 0;
c = (getatom(TRUE));
}
Iputprop(c,x,lastrtab);
return(tatom);
}
/* ... fall into */
default: errorh1(Vermisc,"int:setsyntax : illegal second argument ",
nil,FALSE,0,s);
/* not reached */
case INT:
switch(synclass(s->i)) {
case CESC: Xesc = (char) index; break;
case CDQ: Xdqc = (char) index; break;
case CSD: Xsdc = (char) index; /* string */
}
if(synclass(ctable[index])==CESC /* if we changed the current esc */
&& (synclass(s->i)!=CESC) /* to something else, pick current */
&& Xesc == (char) index) {
ctable[index] = s->i;
rpltab(CESC,&Xesc);
}
else if(synclass(ctable[index])==CDQ /* likewise for double quote */
&& synclass(s->i) != CDQ
&& Xdqc == (char) index) {
ctable[index] = s->i;
rpltab(CDQ,&Xdqc);
}
else if(synclass(ctable[index]) == CSD /* and for string delimiter */
&& synclass(s->i) != CSD
&& Xsdc == (char) index) {
ctable[index] = s->i;
rpltab(CSD,&Xsdc);
}
else ctable[index] = s->i;
break;
}
return(tatom);
}
lispval
Lprocess()
{
int wflag , childsi , childso , child;
lispval handy;
char *command, *p;
int writep, readp;
int itemp;
int (*handler)(), (*signal())();
FILE *bufs[2],*obufs[2], *fpipe();
Savestack(0);
writep = readp = FALSE;
wflag = TRUE;
switch(np-lbot) {
case 3: if(lbot[2].val != nil) writep = TRUE;
case 2: if(lbot[1].val != nil) readp = TRUE;
wflag = 0;
case 1: command = (char *) verify(lbot[0].val,
"*process: non atom first arg");
break;
default:
argerr("*process");
}
childsi = 0;
childso = 1;
/* if there will be communication between the processes,
* it will be through these pipes:
* parent -> bufs[1] -> bufs[0] -> child if writep
* parent <- obufs[0] <- obufs[1] <- parent if readp
*/
if(writep) {
fpipe(bufs);
childsi = fileno(bufs[0]);
}
if(readp) {
fpipe(obufs);
childso = fileno(obufs[1]);
}
handler = signal(SIGINT,SIG_IGN);
if((child = vfork()) == 0 ) {
/* if we will wait for the child to finish
* and if the process had ignored interrupts before
* we were called, then leave them ignored, else
* set it back the the default (death)
*/
if(wflag && handler != SIG_IGN)
signal(2,SIG_DFL);
if(writep) {
close(0);
dup(childsi);
}
if (readp) {
close(1);
dup(childso);
}
if ((p = (char *)getenv("SHELL")) != (char *)0) {
execlp(p , p, "-c",command,0);
_exit(-1); /* if exec fails, signal problems*/
} else {
execlp("csh", "csh", "-c",command,0);
execlp("sh", "sh", "-c",command,0);
_exit(-1); /* if exec fails, signal problems*/
}
}
/* close the duplicated file descriptors
* e.g. if writep is true then we've created two desriptors,
* bufs[0] and bufs[1], we will write to bufs[1] and the
* child (who has a copy of our bufs[0]) will read from bufs[0]
* We (the parent) close bufs[0] since we will not be reading
* from it.
*/
if(writep) fclose(bufs[0]);
if(readp) fclose(obufs[1]);
if(wflag && child!= -1) {
int status=0;
/* we await the death of the child */
while(wait(&status)!=child) {}
/* the child has died */
signal(2,handler); /* restore the interrupt handler */
itemp = status >> 8;
Restorestack();
return(inewint(itemp)); /* return its status */
}
