+#ifndef lint
+static char *rcsid =
+ "$Header: error.c,v 1.6 87/12/14 14:40:57 sklower Exp $";
+#endif
+
+/*
+ * error.c $Locker: $
+ * error handler
+ *
+ * (c) copyright 1982, Regents of the University of California
+ */
+
+
+#include "global.h"
+#include "frame.h"
+#include "catchfram.h"
+
+static lispval IEargs[5];
+static int IElimit;
+
+/* error
+ * this routine is always called on a non-fatal error. The first argu-
+ * ment is printed out. The second a boolean flag indicating if the
+ * error routine is permitted to return a pointer to a lisp value if
+ * the "cont" command is executed.
+ */
+
+/* error from lisp C code, this temporarily replaces the old error
+ * allowing us to interface with the new errset scheme with minimum
+ * difficulty. We assume that an error which comes to this routine
+ * is of an "undefined error type" ER%misc . Soon all calls to this
+ * routine will be removed.
+ *
+ */
+
+lispval
+error(mesg,contvl)
+char *mesg;
+int contvl;
+{
+ lispval errorh();
+
+ return(errorh(Vermisc,mesg,nil,contvl,0));
+}
+
+
+/* new error handler, works with errset
+ *
+ * call is errorh(type,message,valret,contuab) where
+ * type is an atom which classifys the error, and whose clb, if not nil
+ * is the name of a function to call to handle the error.
+ * message is a character string to print to describe the error
+ * valret is the value to return to an errset if one is found,
+ * and contuab is non nil if this error is continuable.
+ */
+
+
+/* VARARGS5 */
+static lispval
+Ierrorh(type,message,valret,contuab,uniqid)
+lispval type,valret;
+int uniqid,contuab;
+char *message;
+{
+ register struct frame *curp, *uwpframe = (struct frame *)0;
+ register lispval handy;
+ lispval *work = IEargs;
+ int limit = IElimit;
+ int pass, curdepth;
+ lispval Lread(), calhan();
+ lispval contatm;
+ lispval handy2;
+ extern struct frame *errp;
+ pbuf pb;
+ Savestack(2);
+
+ contatm = (contuab == TRUE ? tatom : nil);
+
+ /* if there is a catch every error handler */
+ if((handy = Verall->a.clb) != nil)
+ {
+ handy = Verall->a.clb;
+ Verall->a.clb = nil; /* turn off before calling */
+ handy = calhan(limit,work,type,uniqid,contatm,message,handy);
+ if(contuab && (TYPE(handy) == DTPR))
+ return(handy->d.car);
+ }
+
+ if((handy = type->a.clb) != nil) /* if there is an error handler */
+ {
+ handy = calhan(limit,work,type,uniqid,contatm,message,handy);
+ if(contuab && (TYPE(handy) == DTPR))
+ return(handy->d.car);
+ }
+
+ pass = 1;
+ /* search stack for error catcher */
+ ps2:
+
+ for (curp = errp ; curp != (struct frame *) 0 ; curp = curp->olderrp)
+ {
+ if(curp->class == F_CATCH)
+ {
+ /*
+ * interesting catch tags are ER%unwind-protect, generated
+ * by unwind-protect and ER%all, generated by errset
+ */
+ if((pass == 1) && (curp->larg1 == Veruwpt))
+ {
+ uwpframe = curp;
+ pass = 2;
+ goto ps2;
+ }
+ else if(curp->larg1 == Verall)
+ {
+ /*
+ * have found an errset to jump to. If there is an
+ * errset handler, first call that.
+ */
+ if((handy=Verrset->a.clb) != nil)
+ {
+ calhan(limit,work,type,uniqid,contatm,message,handy);
+ }
+
+ /*
+ * if there is an unwind-protect then go to that first.
+ * The unwind protect will return to errorh after
+ * it has processed its cleanup forms.
+ * assert: if pass == 2
+ * then there is a pending unwind-protect
+ */
+ if(uwpframe != (struct frame *)0)
+ {
+ /*
+ * generate form to return to unwind-protect
+ */
+ protect(handy2 = newdot());
+ handy2->d.car = Veruwpt;
+ handy = handy2->d.cdr = newdot();
+ handy->d.car = nil; /* indicates error */
+ handy = handy->d.cdr = newdot();
+ handy->d.car = type;
+ handy = handy->d.cdr = newdot();
+ handy->d.car = matom(message);
+ handy = handy->d.cdr = newdot();
+ handy->d.car = valret;
+ handy = handy->d.cdr = newdot();
+ handy->d.car = inewint(uniqid);
+ handy = handy->d.cdr = newdot();
+ handy->d.car = inewint(contuab);
+ while (limit-- > 0) /* put in optional args */
+ { handy = handy->d.cdr = newdot();
+ handy->d.car = *work++;
+ }
+ lispretval = handy2; /* return this as value */
+ retval = C_THROW;
+ Iretfromfr(uwpframe);
+ /* NOTREACHED */
+ }
+ /*
+ * Will return to errset
+ * print message if flag on this frame is non nil
+ */
+ if(curp->larg2 != nil)
+ {
+ printf("%s ",message);
+ while(limit-->0) {
+ printr(*work++,stdout);
+ fflush(stdout);
+ }
+ fputc('\n',stdout);
+ fflush(stdout);
+ }
+
+ lispretval = valret;
+ retval = C_THROW; /* looks like a throw */
+ Iretfromfr(curp);
+ }
+ }
+ }
+
+ /* no one will catch this error, we must see if there is an
+ error-goes-to-top-level catcher */
+
+ if (Vertpl->a.clb != nil)
+ {
+
+ handy = calhan(limit,work,type,uniqid,contatm,message,Vertpl->a.clb);
+ if( contuab && (TYPE(handy) == DTPR))
+ return(handy->d.car);
+ }
+
+ /* at this point, print error message and break, just like
+ the current error scheme */
+ printf("%s ",message);
+ while(limit-->0) {
+ printr(*work++,stdout);
+ fflush(stdout);
+ }
+
+
+ /* If automatic-reset is set
+ * we will now jump to top level, calling the reset function
+ * if it exists, or using the c rest function if it does not
+ */
+
+ if(Sautor)
+ {
+ if ((handy = reseta->a.fnbnd) != nil)
+ {
+ lispval Lapply();
+ lbot = np;
+ protect(reseta);
+ protect(nil);
+ Lapply();
+ }
+ Inonlocalgo(C_RESET,inewint(0),nil);
+ /* NOTREACHED */
+ }
+
+ /*
+ * no one wants the error. We set up another read-eval-print
+ * loop. The user can get out of this error by typing (return 'val)
+ * if the error is continuable. Normally this code be replaced
+ * by more clever lisp code, when the full lisp is built
+ */
+
+ errp = Pushframe(F_PROG,nil,nil);
+
+ if(TYPE(Verdepth->a.clb) != INT)
+ {
+ curdepth = 1;
+ }
+ else curdepth = 1 + Verdepth->a.clb->i;
+ PUSHDOWN(Verdepth,inewint(curdepth));
+
+ switch(retval) {
+ case C_RET: /*
+ * attempt to return from error
+ */
+ if(!contuab) error("Can't continue from this error",
+ FALSE);
+ popnames(errp->svbnp);
+ errp = Popframe();
+ Restorestack();
+ return(lispretval);
+
+ case C_GO: /*
+ * this may look like a valid prog, but it really
+ * isn't, since go's are not allowed. Let the
+ * user know.
+ */
+ error("Can't 'go' through an error break",FALSE);
+ /* NOT REACHED */
+
+ case C_INITIAL: /*
+ * normal case, just fall through into read-eval-print
+ * loop
+ */
+ break;
+ }
+ lbot = np;
+ protect(P(stdin));
+ protect(eofa);
+
+ while(TRUE) {
+
+ fprintf(stdout,"\n%d:>",curdepth);
+ dmpport(stdout);
+ vtemp = Lread();
+ if(vtemp == eofa) franzexit(0);
+ printr(eval(vtemp),stdout);
+ }
+ /* NOTREACHED */
+}
+
+lispval
+errorh(type,message,valret,contuab,uniqid)
+lispval type,valret;
+int uniqid,contuab;
+char *message;
+{
+ IElimit = 0;
+ Ierrorh(type,message,valret,contuab,uniqid);
+ /* NOTREACHED */
+}
+
+lispval
+errorh1(type,message,valret,contuab,uniqid,arg1)
+lispval type,valret,arg1;
+int uniqid,contuab;
+char *message;
+{
+ IElimit = 1;
+ IEargs[0] = arg1;
+ Ierrorh(type,message,valret,contuab,uniqid);
+ /* NOTREACHED */
+}
+
+lispval
+errorh2(type,message,valret,contuab,uniqid,arg1,arg2)
+lispval type,valret,arg1,arg2;
+int uniqid,contuab;
+char *message;
+{
+ IElimit = 2;
+ IEargs[0] = arg1;
+ IEargs[1] = arg2;
+ Ierrorh(type,message,valret,contuab,uniqid);
+ /* NOTREACHED */
+}
+
+lispval
+calhan(limit,work,type,uniqid,contuab,message,handler)
+register lispval *work;
+lispval handler,type,contuab;
+register limit;
+register char *message;
+int uniqid;
+{
+ register lispval handy;
+ Savestack(4);
+ lbot = np;
+ protect(handler); /* funcall the handler */
+ protect(handy = newdot()); /* with a list consisting of */
+ handy->d.car = type; /* type, */
+ handy = (handy->d.cdr = newdot());
+ handy->d.car = inewint(uniqid); /* identifying number, */
+ handy = (handy->d.cdr = newdot());
+ handy->d.car = contuab;
+ handy = (handy->d.cdr = newdot());
+ handy->d.car = matom(message); /* message to be typed out, */
+ while(limit-- > 0)
+ { /* any other args. */
+ handy = handy->d.cdr = newdot();
+ handy->d.car = *work++;
+ }
+ handy->d.cdr = nil;
+
+ handy = Lfuncal();
+ Restorestack();
+ return(handy);
+}
+
+/* lispend **************************************************************/
+/* Fatal errors come here, with their epitaph. */
+lispend(mesg)
+ char mesg[];
+ {
+ dmpport(poport);
+ fprintf(errport,"%s\n",mesg);
+ dmpport(errport);
+ franzexit(0);
+ /* NOT REACHED */
+ }
+
+/* namerr ***************************************************************/
+/* handles namestack overflow, at present by simply giving a message */
+
+namerr()
+{
+ if((nplim = np + NAMINC) > orgnp + NAMESIZE)
+ {
+ printf("Unrecoverable Namestack Overflow, (reset) is forced\n");
+ fflush(stdout);
+ nplim = orgnp + NAMESIZE - 4*NAMINC;
+ lbot = np = nplim - NAMINC;
+ protect(matom("reset"));
+ Lfuncal();
+ }
+ error("NAMESTACK OVERFLOW",FALSE);
+ /* NOT REACHED */
+}
+
+binderr()
+{
+ bnp -= 10;
+ error("Bindstack overflow.",FALSE);
+ /* NOT REACHED */
+}
+
+rtaberr()
+{
+ bindfix(Vreadtable,strtab,nil);
+ error("Illegal read table.",FALSE);
+ /* NOT REACHED */
+}
+xserr()
+{
+ error("Ran out of alternate stack",FALSE);
+}
+badmem(n)
+{
+ char errbuf[256];
+
+ sprintf(errbuf,"Attempt to allocate beyond static structures (%d).",n);
+ error(errbuf,FALSE);
+ /* NOT REACHED */
+}
+argerr(msg)
+char *msg;
+{
+ errorh1(Vermisc,"incorrect number of args to",
+ nil,FALSE,0,matom(msg));
+ /* NOT REACHED */
+}
+
+lispval Vinterrfcn = nil;
+
+/*
+ * wnaerr - wrong number of arguments to a compiled function hander
+ * called with the function name (symbol) and a descriptor of the
+ * number of arguments that were expected. The form of the descriptor
+ * is (considered as a decimal number) xxyy where xx is the minumum
+ * and yy-1 is the maximum. A maximum of -1 means that there is no
+ * maximum.
+ *
+ */
+wnaerr(fcn,wantargs)
+lispval fcn;
+{
+ if (Vinterrfcn == nil)
+ {
+ Vinterrfcn = matom("int:wrong-number-of-args-error");
+ }
+ if (Vinterrfcn->a.fnbnd != nil)
+ {
+ protect(fcn);
+ protect(inewint(wantargs / 1000)); /* min */
+ protect(inewint((wantargs % 1000) - 1)); /* max */
+ Ifuncal(Vinterrfcn);
+ error("wrong number of args function should never return ", FALSE);
+ }
+
+ errorh1(Vermisc,"wrong number of arguments to ",nil,FALSE,0,fcn);
+}
+
+
+
projects / unix-history / commitdiff