From 56dd67ae68568eb374eee8745b9d46ea35fd05ac Mon Sep 17 00:00:00 2001 From: CSRG Date: Wed, 7 Sep 1983 02:55:46 -0800 Subject: [PATCH] BSD 4_3_Reno development Work on file usr/src/pgrm/lisp/franz/fex2.c Synthesized-from: CSRG/cd2/4.3reno --- usr/src/pgrm/lisp/franz/fex2.c | 348 +++++++++++++++++++++++++++++++++ 1 file changed, 348 insertions(+) create mode 100644 usr/src/pgrm/lisp/franz/fex2.c diff --git a/usr/src/pgrm/lisp/franz/fex2.c b/usr/src/pgrm/lisp/franz/fex2.c new file mode 100644 index 0000000000..8a1c88055b --- /dev/null +++ b/usr/src/pgrm/lisp/franz/fex2.c @@ -0,0 +1,348 @@ + +#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); +} -- 2.20.1