From 6deb05b9f2ad2170506064098fecf3b651803b31 Mon Sep 17 00:00:00 2001 From: CSRG Date: Sun, 13 Dec 1987 23:41:16 -0800 Subject: [PATCH 1/1] BSD 4_4 development Work on file usr/src/old/lisp/franz/error.c Synthesized-from: CSRG/cd3/4.4 --- usr/src/old/lisp/franz/error.c | 439 +++++++++++++++++++++++++++++++++ 1 file changed, 439 insertions(+) create mode 100644 usr/src/old/lisp/franz/error.c diff --git a/usr/src/old/lisp/franz/error.c b/usr/src/old/lisp/franz/error.c new file mode 100644 index 0000000000..6bb2d2df01 --- /dev/null +++ b/usr/src/old/lisp/franz/error.c @@ -0,0 +1,439 @@ +#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); +} + + + -- 2.20.1