4.4BSD/usr/src/old/lisp/franz/fex2.c
#ifndef lint
static char *rcsid =
"$Header: fex2.c,v 1.3 83/09/07 17:55:38 sklower Exp $";
#endif
/* -[Mon Jan 31 21:54:52 1983 by layer]-
* fex2.c $Locker: $
* nlambda functions
*
* (c) copyright 1982, Regents of the University of California
*/
#include "global.h"
#define NDOVARS 30
#include "frame.h"
/*
* Ndo maclisp do function.
*/
lispval
Ndo()
{
register lispval current, where, handy;
register struct nament *mybnp;
lispval temp, atom;
lispval body, endtest, endform, varstuff, renewals[NDOVARS] ;
struct argent *getem, *startnp;
struct nament *savedbnp = bnp;
int count, repeatdo, index;
extern struct frame *errp;
pbuf pb;
Savestack(3);
current = lbot->val;
varstuff = current->d.car;
switch( TYPE(varstuff) ) {
case ATOM: /* This is old style maclisp do;
atom is var, cadr(current) = init;
caddr(current) = repeat etc. */
if(varstuff==nil) goto newstyle;
current = current->d.cdr; /* car(current) is now init */
PUSHDOWN(varstuff,eval(current->d.car));
/* Init var. */
*renewals = (current = current->d.cdr)->d.car;
/* get repeat form */
endtest = (current = current->d.cdr)->d.car;
body = current->d.cdr;
errp = Pushframe(F_PROG,nil,nil);
switch (retval) {
case C_RET: /*
* returning from this prog, value to return
* is in lispretval
*/
errp = Popframe();
popnames(savedbnp);
return(lispretval);
case C_GO: /*
* going to a certain label, label to go to in
* in lispretval
*/
where = body;
while ((TYPE(where) == DTPR)
& (where->d.car != lispretval))
where = where->d.cdr;
if (where->d.car == lispretval) {
popnames(errp->svbnp);
where = where->d.cdr;
goto singbody;
}
/* label not found in this prog, must
* go up to higher prog
*/
Inonlocalgo(C_GO,lispretval,nil);
/* NOT REACHED */
case C_INITIAL: break; /* fall through */
}
singtop:
if(eval(endtest)!=nil) {
errp = Popframe();
popnames(savedbnp);
return(nil);
}
where = body;
singbody:
while (TYPE(where) == DTPR)
{
temp = where->d.car;
if((TYPE(temp))!=ATOM) eval(temp);
where = where->d.cdr;
}
varstuff->a.clb = eval(*renewals);
goto singtop;
newstyle:
case DTPR: /* New style maclisp do; atom is
list of things of the form
(var init repeat) */
count = 0;
startnp = np;
for(where = varstuff; where != nil; where = where->d.cdr) {
/* do inits and count do vars. */
/* requires "simultaneous" eval
of all inits */
while (TYPE(where->d.car) != DTPR)
where->d.car =
errorh1(Vermisc,"do: variable forms must be lists ",
nil,TRUE,0,where->d.car);
handy = where->d.car->d.cdr;
temp = nil;
if(handy !=nil)
temp = eval(handy->d.car);
protect(temp);
count++;
}
if(count > NDOVARS)
error("More than 15 do vars",FALSE);
where = varstuff;
getem = startnp; /* base of stack of init forms */
for(index = 0; index < count; index++) {
handy = where->d.car;
/* get var name from group */
atom = handy->d.car;
while((TYPE(atom) != ATOM) || (atom == nil))
atom = errorh1(Vermisc,"do variable must be a non nil symbol ",
nil,TRUE,0,atom);
PUSHDOWN(atom,getem->val);
getem++;
handy = handy->d.cdr->d.cdr;
if(handy==nil)
handy = CNIL; /* be sure not to rebind later */
else
handy = handy->d.car;
renewals[index] = handy;
/* more loop "increments" */
where = where->d.cdr;
}
np = startnp; /* pop off all init forms */
/* Examine End test and End form */
current = current->d.cdr;
handy = current->d.car;
body = current->d.cdr;
/*
* a do form with a test of nil just does the body once
* and returns nil
*/
if (handy == nil) repeatdo = 1; /* just do it once */
else repeatdo = -1; /* do it forever */
endtest = handy->d.car;
endform = handy->d.cdr;
where = body;
errp = Pushframe(F_PROG,nil,nil);
while(TRUE) {
switch (retval) {
case C_RET: /*
* returning from this prog, value to return
* is in lispretval
*/
errp = Popframe();
popnames(savedbnp);
Restorestack();
return(lispretval);
case C_GO: /*
* going to a certain label, label to go to in
* in lispretval
*/
where = body;
while ((TYPE(where) == DTPR)
& (where->d.car != lispretval))
where = where->d.cdr;
if (where->d.car == lispretval) {
popnames(errp->svbnp);
where = where->d.cdr;
goto bodystart;
}
/* label not found in this prog, must
* go up to higher prog
*/
Inonlocalgo(C_GO,lispretval,nil);
/* NOT REACHED */
case C_INITIAL: break; /* fall through */
}
loop:
np = startnp; /* is bumped when doing repeat forms */
if((repeatdo-- == 0) || (eval(endtest) !=nil)) {
for(handy = nil; endform!=nil; endform = endform->d.cdr)
{
handy = eval(endform->d.car);
}
errp = Popframe();
popnames(savedbnp);
Restorestack();
return(handy);
}
bodystart:
while (TYPE(where) == DTPR)
{
temp = where->d.car;
if((TYPE(temp))!=ATOM) eval(temp);
where = where->d.cdr;
}
where = body;
getem = np = startnp;
/* Simultaneously eval repeat forms */
for(index = 0; index < count; index++) {
temp = renewals[index];
if (temp == nil || temp == CNIL)
protect(temp);
else
protect(eval(temp));
}
/* now simult. rebind all the atoms */
mybnp = savedbnp;
for(index = 0; index < count; index++)
{
if( getem->val != CNIL ) /* if this atom has a repeat */
mybnp->atm->a.clb = (getem)->val; /* rebind */
mybnp++;
getem++;
}
goto loop;
}
default:
error("do: neither list nor atom follows do", FALSE);
}
/* NOTREACHED */
}
lispval
Nprogv()
{
register lispval where, handy;
register struct nament *namptr;
register struct argent *vars;
struct nament *oldbnp = bnp;
Savestack(4);
where = lbot->val;
protect(eval(where->d.car)); /* list of vars = lbot[1].val */
protect(eval((where = where->d.cdr)->d.car));
/* list of vals */
handy = lbot[2].val;
namptr = oldbnp;
/* simultaneous eval of all
args */
for(;handy!=nil; handy = handy->d.cdr) {
(np++)->val = (handy->d.car);
/* Note, each element should not be reevaluated like it
* was before. - dhl */
/* Before: (np++)->val = eval(handy->d.car);*/
TNP;
}
/*asm("# Here is where rebinding is done"); /* very cute */
for(handy=lbot[1].val,vars=lbot+3; handy!=nil; handy=handy->d.cdr) {
namptr->atm = handy->d.car;
++namptr; /* protect against interrupts
while re-lambda binding */
bnp = namptr;
namptr[-1].atm = handy->d.car;
namptr[-1].val = handy->d.car->a.clb;
if(vars < np)
handy->d.car->a.clb = vars++->val;
else
handy->d.car->a.clb = nil;
}
handy = nil;
for(where = where->d.cdr; where != nil; where = where->d.cdr)
handy = eval(where->d.car);
popnames(oldbnp);
Restorestack();
return(handy);
}
lispval
Nprogn()
{
register lispval result, where;
result = nil;
for(where = lbot->val; where != nil; where = where->d.cdr)
result = eval(where->d.car);
return(result);
}
lispval
Nprog2()
{
register lispval result, where;
where = lbot->val;
eval(where->d.car);
result = eval((where = where->d.cdr)->d.car);
protect(result);
for(where = where->d.cdr; where != nil; where = where->d.cdr)
eval(where->d.car);
np--;
return(result);
}
lispval
typred(typ,ptr)
int typ;
lispval ptr;
{ int tx;
if ((tx = TYPE(ptr)) == typ) return(tatom);
if ((tx == INT) && (typ == ATOM)) return(tatom);
return(nil);
}
/*
* function
* In the interpreter, function is the same as quote
*/
lispval
Nfunction()
{
if((lbot->val == nil) || (lbot->val->d.cdr != nil))
argerr("function");
return(lbot->val->d.car);
}