lispval
Lmod()
{
register lispval arg1,arg2;
lispval handy;
struct sdot fake1, fake2;
fake2.CDR = 0;
fake1.CDR = 0;
chkarg(2,"mod");
handy = arg1 = lbot->val;
arg2 = (lbot+1)->val;
switch(TYPE(arg1)) {
case SDOT:
switch(TYPE(arg2)) {
case SDOT: /* both are already bignums */
break;
case INT: /* convert arg2 to bignum */
fake2.I = arg2->i;
arg2 =(lispval) &fake2;
break;
default:
error("non-numeric argument",FALSE);
}
break;
case INT:
switch(TYPE(arg2)) {
case SDOT: /* convert arg1 to bignum */
fake1.I = arg1->i;
arg1 =(lispval) &fake1;
break;
case INT: /* both are fixnums */
return( inewint ((arg1->i) % (arg2->i)) );
default:
error("non-numeric argument",FALSE);
}
break;
default:
error("non-numeric argument",FALSE);
}
if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0)
return(handy);
divbig(arg1,arg2,(lispval *)0,&handy);
if(handy==((lispval)&fake1))
handy = inewint(fake1.I);
if(handy==((lispval)&fake2))
handy = inewint(fake2.I);
return(handy);
}
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
Lminus()
{
register lispval arg1, handy;
lispval subbig();
chkarg(1,"minus");
arg1 = lbot->val;
handy = nil;
switch(TYPE(arg1)) {
case INT:
handy= inewint(0 - arg1->i);
break;
case DOUB:
handy = newdoub();
handy->r = -arg1->r;
break;
case SDOT: { struct sdot dummyb;
handy = (lispval) &dummyb;
handy->s.I = 0;
handy->s.CDR = (lispval) 0;
handy = subbig(handy,arg1);
break; }
default:
error("non-numeric argument",FALSE);
}
return(handy);
}
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
Lfork() {
int pid;
chkarg(0,"fork");
if ((pid=fork())) {
return(inewint(pid));
} else
return(nil);
}
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
Lflatsi()
{
register lispval current, temp;
register struct argent *mylbot = lbot;
snpand(3); /* fixup entry mask */
chkarg(2);
flen = 0; fmax = mylbot[1].val->i;
current = mylbot->val;
protect(nil); /*create space for argument to pntlen*/
Iflatsi(current);
return(inewint(flen));
}
lispval
Ldiff()
{
register lispval arg1,arg2;
register handy = 0;
chkarg(2,"Ldiff");
arg1 = lbot->val;
arg2 = (lbot+1)->val;
if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
handy=arg1->i - arg2->i;
}
else error("non-numeric argument",FALSE);
return(inewint(handy));
}
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
Lxcar()
{ register int typ;
register lispval temp, result;
chkarg(1,"xcar");
temp = lbot->val;
if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM) || HUNKP(temp))
return(temp->d.car);
else if(typ == SDOT) {
result = inewint(temp->i);
return(result);
} else if(Schainp!=nil && typ==ATOM)
return(nil);
else
return(error("Bad arg to car",FALSE));
}
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
Lonep()
{
register lispval handy;
lispval Ladd();
handy = lbot->val;
switch(TYPE(handy)) {
case INT:
return(handy->i==1?tatom:nil);
case DOUB:
return(handy->r==1.0?tatom:nil);
case SDOT:
protect(inewint(0));
handy = Ladd();
if(TYPE(handy)!=INT || handy->i !=1)
return(nil);
else
return(tatom);
}
return(nil);
}
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);
}
/* All arguments are ignored. This just returns-from-break to depth 0. */
lispval
Nreset()
{
Inonlocalgo(C_RESET,inewint(0),nil);
}
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 */
}
