lispval
cmpx(lssp)
{
register struct argent *argp;
register struct argent *outarg;
register struct argent *onp = np;
Savestack(3);
argp = lbot + 1;
outarg = np;
while(argp < onp) {
np = outarg + 2;
lbot = outarg;
if(lssp)
*outarg = argp[-1], outarg[1] = *argp++;
else
outarg[1] = argp[-1], *outarg = *argp++;
lbot->val = Lsub();
np = lbot + 1;
if(Lnegp()==nil)
{
Restorestack();
return(nil);
}
}
Restorestack();
return(tatom);
}
/*
Ncatch is now linked to the lisp symbol *catch , which has the form
(*catch tag form)
tag is evaluated and then the catch entry is set up.
then form is evaluated
finally the catch entry is removed.
*catch is still an nlambda since its arguments should not be evaluated
before this routine is called.
(catch form [tag]) is translated to (*catch 'tag form) by a macro.
*/
lispval
Ncatch()
{
register lispval tag;
pbuf pb;
Savestack(3); /* save stack pointers */
if((TYPE(lbot->val))!=DTPR) return(nil);
protect(tag = eval(lbot->val->d.car)); /* protect tag from gc */
errp = Pushframe(F_CATCH,tag,nil);
switch(retval) {
case C_THROW: /*
* value thrown is in lispretval
*/
break;
case C_INITIAL: /*
* calculate value of expression
*/
lispretval = eval(lbot->val->d.cdr->d.car);
}
errp = Popframe();
Restorestack();
return(lispretval);
}
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
Lsub1()
{
register lispval handy;
lispval Ladd();
Savestack(1); /* fixup entry mask */
chkarg(1,"sub1");
if((TYPE(lbot->val) == INT) && (lbot->val->i > MinINT))
{
Restorestack();
return(inewint(lbot->val->i - 1));
}
handy = rdrint;
handy->i = - 1;
protect(handy);
handy=Ladd();
Restorestack();
return(handy);
}
lispval
Ladd1()
{
register lispval handy;
lispval Ladd();
Savestack(1); /* fixup entry mask */
chkarg(1,"add1");
/* simple test first */
if((TYPE(lbot->val) == INT) && (lbot->val->i < MaxINT))
{
Restorestack();
return(inewint(lbot->val->i + 1));
}
handy = rdrint;
handy->i = 1;
protect(handy);
handy=Ladd();
Restorestack();
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);
}
lispval
Lgetaddress(){
register struct argent *mlbot = lbot;
register lispval work;
register int numberofargs, i;
char ostabf[128];
struct nlist NTABLE[100];
lispval dispget();
Savestack(4);
if(np-lbot == 2) protect(nil); /* allow 2 args */
numberofargs = (np - lbot)/3;
if(numberofargs * 3 != np-lbot)
error("getaddress: arguments must come in triples ",FALSE);
for ( i=0; i<numberofargs; i++,mlbot += 3) {
NTABLE[i].n_value = 0;
mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
STASSGN(i,(char *) mlbot[0].val);
while(TYPE(mlbot[1].val) != ATOM)
mlbot[1].val = errorh1(Vermisc,
"Bad associated atom name for binding",
nil,TRUE,0,mlbot[1].val);
mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",(lispval)Vsubrou->a.pname);
}
STASSGN(numberofargs,"");
strncpy(ostabf,gstab(),128);
if ( nlist(ostabf,NTABLE) == -1 ) {
errorh1(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
} else
for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
if ( NTABLE[i].n_value == 0 )
fprintf(stderr,"Undefined symbol: %s\n",
NTABLE[i].N_name);
else {
work= newfunct();
work->bcd.start = (lispval (*) ())NTABLE[i].n_value;
work->bcd.discipline = mlbot[1].val;
mlbot->val->a.fnbnd = work;
}
};
Restorestack();
return(lbot[1].val->a.fnbnd);
};
lispval
Lwait()
{
register lispval ret, temp;
int status = -1, pid;
Savestack(2);
chkarg(0,"wait");
pid = wait(&status);
ret = newdot();
protect(ret);
temp = inewint(pid);
ret->d.car = temp;
temp = inewint(status);
ret->d.cdr = temp;
Restorestack();
return(ret);
}
lispval
Lpipe()
{
register lispval ret, temp;
int pipes[2];
Savestack(2);
chkarg(0,"pipe");
pipes[0] = -1;
pipes[1] = -1;
pipe(pipes);
ret = newdot();
protect(ret);
temp = inewint(pipes[0]);
ret->d.car = temp;
temp = inewint(pipes[1]);
ret->d.cdr = temp;
Restorestack();
return(ret);
}
lispval Nerrset()
{
lispval temp,flag;
pbuf pb;
Savestack(0);
if(TYPE(lbot->val) != DTPR) return(nil); /* no form */
/* evaluate and save flag first */
flag = lbot->val->d.cdr;
if(TYPE(flag) == DTPR) flag = eval(flag->d.car);
else flag = tatom; /* if not present , assume t */
protect(flag);
errp = Pushframe(F_CATCH,Verall,flag);
switch(retval) {
case C_THROW: /*
* error thrown to this routine, value thrown is
* in lispretval
*/
break;
case C_INITIAL: /*
* normally just evaluate expression and listify it.
*/
temp = eval(lbot->val->d.car);
protect(temp);
(lispretval = newdot())->d.car = temp;
break;
}
errp = Popframe();
Restorestack();
return(lispretval);
}
/*
*
* (oblist)
*
* oblist returns a list of all symbols in the oblist
*
* written by jkf.
*/
lispval
Loblist()
{
int indx;
lispval headp, tailp ;
struct atom *symb ;
extern int hashtop;
Savestack(0);
headp = tailp = newdot(); /* allocate first DTPR */
protect(headp); /*protect the list from garbage collection*/
/*line added by kls */
for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */
{
for( symb = hasht[indx] ;
symb != (struct atom *) CNIL ;
symb = symb-> hshlnk)
{
if(TYPE(symb) != ATOM)
{ printf(" non symbol in hasht[%d] = %x: ",indx,symb);
printr((lispval) symb,stdout);
printf(" \n");
fflush(stdout);
}
tailp->d.car = (lispval) symb ; /* remember this atom */
tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */
}
}
tailp->d.cdr = nil ; /* close the list unfortunately throwing away
the last DTPR
*/
Restorestack();
return(headp);
}
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 */
}
