+#ifndef lint
+static char *rcsid =
+ "$Header: fex1.c,v 1.5 85/03/24 11:03:51 sklower Exp $";
+#endif
+
+/* -[Sat Mar 5 19:50:28 1983 by layer]-
+ * fex1.c $Locker: $
+ * nlambda functions
+ *
+ * (c) copyright 1982, Regents of the University of California
+ */
+
+
+#include "global.h"
+#include "frame.h"
+
+/* Nprog ****************************************************************/
+/* This first sets the local variables to nil while saving their old */
+/* values on the name stack. Then, pointers to various things are */
+/* saved as this function may be returned to by an "Ngo" or by a */
+/* "Lreturn". At the end is the loop that cycles through the contents */
+/* of the prog. */
+
+lispval
+Nprog() {
+ register lispval where, temp;
+ struct nament *savedbnp = bnp;
+ extern struct frame *errp;
+ pbuf pb;
+ extern int retval;
+ extern lispval lispretval;
+
+ if((np-lbot) < 1) chkarg(1,"prog");
+
+ /* shallow bind the local variables to nil */
+ if(lbot->val->d.car != nil)
+ {
+ for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
+ {
+ if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
+ errorh1(Vermisc,
+ "Illegal local variable list in prog ",nil,FALSE,
+ 1,where);
+ PUSHDOWN(temp,nil);
+ }
+ }
+
+ /* put a frame on the stack which can be 'return'ed to or 'go'ed to */
+ errp = Pushframe(F_PROG,nil,nil);
+
+ where = lbot->val->d.cdr; /* first thing in the prog body */
+
+ 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 = (lbot->val)->d.cdr;
+ while ((TYPE(where) == DTPR)
+ && (where->d.car != lispretval))
+ where = where->d.cdr;
+ if (where->d.car == lispretval) {
+ popnames(errp->svbnp);
+ break;
+ }
+ /* label not found in this prog, must
+ * go up to higher prog
+ */
+ errp = Popframe(); /* go to next frame */
+ Inonlocalgo(C_GO,lispretval,nil);
+
+ /* NOT REACHED */
+
+ case C_INITIAL: break;
+
+ }
+
+ while (TYPE(where) == DTPR)
+ {
+ temp = where->d.car;
+ if((TYPE(temp))!=ATOM) eval(temp);
+ where = where->d.cdr;
+ }
+ if((where != nil) && (TYPE(where) != DTPR))
+ errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
+ errp = Popframe();
+ popnames(savedbnp); /* pop off locals */
+ return(nil);
+}
+
+lispval globtag;
+/*
+ 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);
+}
+/* (errset form [flag])
+ if present, flag determines if the error message will be printed
+ if an error reaches the errset.
+ if no error occurs, errset returns a list of one element, the
+ value returned from form.
+ if an error occurs, nil is usually returned although it could
+ be non nil if err threw a non nil value
+ */
+
+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);
+}
+
+/* this was changed from throw to *throw 21nov79
+ it is now a lambda and really should be called Lthrow
+*/
+lispval
+Nthrow()
+{
+ switch(np-lbot) {
+ case 0:
+ protect(nil);
+ case 1:
+ protect(nil);
+ case 2: break;
+ default:
+ argerr("throw");
+ }
+ Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
+ /* NOT REACHED */
+}
+
+
+
+/* Ngo ******************************************************************/
+/* First argument only is checked - and must be an atom or evaluate */
+/* to one. */
+lispval
+Ngo()
+{
+ register lispval temp;
+ chkarg(1,"go");
+
+ temp = (lbot->val)->d.car;
+ if (TYPE(temp) != ATOM)
+ {
+ temp = eval(temp);
+ while(TYPE(temp) != ATOM)
+ temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
+ }
+ Inonlocalgo(C_GO,temp,nil);
+ /* NOT REACHED */
+}
+
+
+/* Nreset ***************************************************************/
+/* All arguments are ignored. This just returns-from-break to depth 0. */
+lispval
+Nreset()
+{
+ Inonlocalgo(C_RESET,inewint(0),nil);
+}
+
+
+
+/* Nbreak ***************************************************************/
+/* If first argument is not nil, this is evaluated and printed. Then */
+/* error is called with the "breaking" message. */
+
+lispval
+Nbreak()
+{
+ register lispval hold; register FILE *port;
+ port = okport(Vpoport->a.clb,stdout);
+ fprintf(port,"Breaking:");
+
+ if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
+ {
+ printr(hold,port);
+ }
+ putc('\n',port);
+ dmpport(port);
+ return(errorh(Verbrk,"",nil,TRUE,0));
+}
+
+
+/* Nexit ****************************************************************/
+/* Just calls lispend with no message. */
+Nexit()
+ {
+ lispend("");
+ }
+
+
+/* Nsys *****************************************************************/
+/* Just calls lispend with no message. */
+
+lispval
+Nsys()
+ {
+ lispend("");
+ }
+
+
+
+
+lispval
+Ndef() {
+ register lispval arglist, body, name, form;
+
+ form = lbot->val;
+ name = form->d.car;
+ body = form->d.cdr->d.car;
+ arglist = body->d.cdr->d.car;
+ if((TYPE(arglist))!=DTPR && arglist != nil)
+ error("Warning: defining function with nonlist of args",
+ TRUE);
+ name->a.fnbnd = body;
+ return(name);
+}
+
+
+lispval
+Nquote()
+{
+ return((lbot->val)->d.car);
+}
+
+
+lispval
+Nsetq()
+{ register lispval handy, where, value;
+ register int lefttype;
+
+ value = nil;
+
+ for(where = lbot->val; where != nil; where = handy->d.cdr) {
+ handy = where->d.cdr;
+ if((TYPE(handy))!=DTPR)
+ error("odd number of args to setq",FALSE);
+ if((lefttype=TYPE(where->d.car))==ATOM) {
+ if(where->d.car==nil)
+ error("Attempt to set nil",FALSE);
+ where->d.car->a.clb = value = eval(handy->d.car);
+ }else if(lefttype==VALUE)
+ where->d.car->l = value = eval(handy->d.car);
+ else errorh1(Vermisc,
+ "Can only setq atoms or values",nil,FALSE,0,
+ where->d.car);
+ }
+ return(value);
+}
+
+
+lispval
+Ncond()
+{
+ register lispval where, last;
+
+ where = lbot->val;
+ last = nil;
+ for(;;) {
+ if ((TYPE(where))!=DTPR)
+ break;
+ if ((TYPE(where->d.car))!=DTPR)
+ break;
+ if ((last=eval((where->d.car)->d.car)) != nil)
+ break;
+ where = where->d.cdr;
+ }
+
+ if ((TYPE(where)) != DTPR)
+ return(nil);
+ where = (where->d.car)->d.cdr;
+ while ((TYPE(where))==DTPR) {
+ last = eval(where->d.car);
+ where = where->d.cdr;
+ }
+ return(last);
+}
+
+lispval
+Nand()
+{
+ register lispval current, temp;
+
+ current = lbot->val;
+ temp = tatom;
+ while (current != nil)
+ if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil)
+ current = current->d.cdr;
+ else {
+ current = nil;
+ temp = nil;
+ }
+ return(temp);
+}
+
+
+lispval
+Nor()
+{
+ register lispval current, temp;
+
+ current = lbot->val;
+ temp = nil;
+ while (current != nil)
+ if ( (temp = eval(current->d.car)) == nil)
+ current = current->d.cdr;
+ else
+ break;
+ return(temp);
+}
projects / unix-history / commitdiff