+
+#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);
+}
projects / unix-history / commitdiff