4.3BSD - /usr/src/ucb/lisp/franz/error.c

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: error.c,v 1.5 83/09/12 14:17:50 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Sun Sep  4 09:06:21 1983 by jkf]-
   7:  * 	error.c				$Locker:  $
   8:  * error handler
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: 
  14: #include "global.h"
  15: #include "frame.h"
  16: #include "catchfram.h"
  17: 
  18: static lispval  IEargs[5];
  19: static int  IElimit;
  20: 
  21: /* error
  22:  * this routine is always called on a non-fatal error.  The first argu-
  23:  * ment is printed out.  The second a boolean flag indicating if the
  24:  * error routine is permitted to return a pointer to a lisp value if
  25:  * the "cont" command is executed.
  26:  */
  27: 
  28: /* error from lisp C code, this temporarily replaces the old error
  29:  * allowing us to interface with the new errset scheme with minimum
  30:  * difficulty.  We assume that an error which comes to this routine
  31:  * is of an "undefined error type" ER%misc .  Soon all calls to this
  32:  * routine will be removed.
  33:  *
  34:  */
  35: 
  36: lispval
  37: error(mesg,contvl)
  38: char *mesg;
  39: int contvl;
  40: {
  41:     lispval errorh();
  42: 
  43:     return(errorh(Vermisc,mesg,nil,contvl,0));
  44: }
  45: 
  46: 
  47: /* new error handler, works with errset
  48:  *
  49:  * call is errorh(type,message,valret,contuab) where
  50:  * type is an atom which classifys the error, and whose clb, if not nil
  51:  * is the name of a function to call to handle the error.
  52:  * message is a character string to print to describe the error
  53:  * valret is the value to return to an errset if one is found,
  54:  * and contuab is non nil if this error is continuable.
  55:  */
  56: 
  57: 
  58: /* VARARGS5 */
  59: static lispval
  60: Ierrorh(type,message,valret,contuab,uniqid)
  61: lispval type,valret;
  62: int uniqid,contuab;
  63: char *message;
  64: {
  65:     register struct frame *curp, *uwpframe = (struct frame *)0;
  66:     register lispval handy;
  67:     lispval *work = IEargs;
  68:     int limit = IElimit;
  69:     int pass, curdepth;
  70:     lispval Lread(), calhan();
  71:     lispval contatm;
  72:     lispval handy2;
  73:     extern struct frame *errp;
  74:     pbuf pb;
  75:     Savestack(2);
  76: 
  77:     contatm = (contuab == TRUE ? tatom : nil);
  78: 
  79:     /* if there is a catch every error handler */
  80:     if((handy = Verall->a.clb) != nil)
  81:     {
  82:         handy = Verall->a.clb;
  83:         Verall->a.clb = nil;        /* turn off before calling */
  84:         handy = calhan(limit,work,type,uniqid,contatm,message,handy);
  85:         if(contuab && (TYPE(handy) == DTPR))
  86:         return(handy->d.car);
  87:     }
  88: 
  89:     if((handy = type->a.clb) != nil)    /* if there is an error handler */
  90:     {
  91:         handy = calhan(limit,work,type,uniqid,contatm,message,handy);
  92:         if(contuab && (TYPE(handy) == DTPR))
  93:         return(handy->d.car);
  94:     }
  95: 
  96:     pass = 1;
  97:     /* search stack for error catcher */
  98:   ps2:
  99: 
 100:     for (curp = errp ; curp != (struct frame *) 0 ; curp = curp->olderrp)
 101:     {
 102:        if(curp->class == F_CATCH)
 103:        {
 104:         /*
 105: 		 * interesting catch tags are ER%unwind-protect, generated
 106: 		 * by unwind-protect and ER%all, generated by errset
 107: 		 */
 108:         if((pass == 1) && (curp->larg1 == Veruwpt))
 109:         {
 110:             uwpframe = curp;
 111:             pass = 2;
 112:             goto ps2;
 113:         }
 114:         else if(curp->larg1 == Verall)
 115:         {
 116:             /*
 117: 		     * have found an errset to jump to. If there is an
 118: 		     * errset handler, first call that.
 119: 		     */
 120:             if((handy=Verrset->a.clb) != nil)
 121:             {
 122:             calhan(limit,work,type,uniqid,contatm,message,handy);
 123:             }
 124: 
 125:             /*
 126: 		     * if there is an unwind-protect then go to that first.
 127: 		     * The unwind protect will return to errorh after
 128: 		     * it has processed its cleanup forms.
 129: 		     * assert: if pass == 2
 130: 		     *		then there is a pending unwind-protect
 131: 		     */
 132:              if(uwpframe != (struct frame *)0)
 133:              {
 134:             /*
 135: 			 * generate form to return to unwind-protect
 136: 			 */
 137:             protect(handy2 = newdot());
 138:             handy2->d.car = Veruwpt;
 139:             handy = handy2->d.cdr = newdot();
 140:             handy->d.car = nil;     /* indicates error */
 141:             handy = handy->d.cdr = newdot();
 142:             handy->d.car = type;
 143:             handy = handy->d.cdr = newdot();
 144:             handy->d.car = matom(message);
 145:             handy = handy->d.cdr = newdot();
 146:             handy->d.car = valret;
 147:             handy = handy->d.cdr = newdot();
 148:             handy->d.car = inewint(uniqid);
 149:             handy = handy->d.cdr = newdot();
 150:             handy->d.car = inewint(contuab);
 151:             while (limit-- > 0) /* put in optional args */
 152:             {  handy = handy->d.cdr = newdot();
 153:                handy->d.car = *work++;
 154:             }
 155:             lispretval = handy2;        /* return this as value */
 156:             retval = C_THROW;
 157:             Iretfromfr(uwpframe);
 158:             /* NOTREACHED */
 159:             }
 160:             /*
 161: 		     * Will return to errset
 162: 		     * print message if flag on this frame is non nil
 163: 		     */
 164:             if(curp->larg2 != nil)
 165:             {
 166:             printf("%s  ",message);
 167:             while(limit-->0) {
 168:                 printr(*work++,stdout);
 169:                 fflush(stdout);
 170:             }
 171:             fputc('\n',stdout);
 172:             fflush(stdout);
 173:             }
 174: 
 175:             lispretval = valret;
 176:             retval = C_THROW;       /* looks like a throw */
 177:             Iretfromfr(curp);
 178:         }
 179:         }
 180:     }
 181: 
 182:     /* no one will catch this error, we must see if there is an
 183: 	   error-goes-to-top-level catcher */
 184: 
 185:     if (Vertpl->a.clb != nil)
 186:     {
 187: 
 188:         handy = calhan(limit,work,type,uniqid,contatm,message,Vertpl->a.clb);
 189:         if( contuab  && (TYPE(handy) == DTPR))
 190:            return(handy->d.car);
 191:     }
 192: 
 193:     /* at this point, print error message and break, just like
 194: 	   the current error scheme */
 195:     printf("%s ",message);
 196:     while(limit-->0) {
 197:         printr(*work++,stdout);
 198:         fflush(stdout);
 199:     }
 200: 
 201: 
 202:     /* If automatic-reset is set
 203: 	 * we will now jump to top level, calling the reset function
 204: 	 * if it exists, or using the c rest function if it does not
 205: 	 */
 206: 
 207:     if(Sautor)
 208:     {
 209:         if ((handy = reseta->a.fnbnd) != nil)
 210:         {
 211:             lispval Lapply();
 212:             lbot = np;
 213:             protect(reseta);
 214:             protect(nil);
 215:             Lapply();
 216:         }
 217:         Inonlocalgo(C_RESET,inewint(0),nil);
 218:         /* NOTREACHED */
 219:     }
 220: 
 221:     /*
 222: 	 * no one wants the error.  We set up another read-eval-print
 223: 	 * loop. The user can get out of this error by typing (return 'val)
 224: 	 * if the error is continuable.  Normally this code be replaced
 225: 	 * by more clever lisp code, when the full lisp is built
 226: 	 */
 227: 
 228:     errp = Pushframe(F_PROG,nil,nil);
 229: 
 230:     if(TYPE(Verdepth->a.clb) != INT)
 231:     {
 232:         curdepth = 1;
 233:     }
 234:     else curdepth = 1 + Verdepth->a.clb->i;
 235:     PUSHDOWN(Verdepth,inewint(curdepth));
 236: 
 237:     switch(retval) {
 238:     case C_RET: /*
 239: 			 * attempt to return from error
 240: 			 */
 241:             if(!contuab) error("Can't continue from this error",
 242:                           FALSE);
 243:             popnames(errp->svbnp);
 244:             errp = Popframe();
 245:             Restorestack();
 246:             return(lispretval);
 247: 
 248:     case C_GO:  /*
 249: 			 * this may look like a valid prog, but it really
 250: 			 * isn't, since go's are not allowed.  Let the
 251: 			 * user know.
 252: 			 */
 253:             error("Can't 'go' through an error break",FALSE);
 254:             /* NOT REACHED */
 255: 
 256:     case C_INITIAL: /*
 257: 			  * normal case, just fall through into read-eval-print
 258: 			  * loop
 259: 			  */
 260:             break;
 261:     }
 262:     lbot = np;
 263:     protect(P(stdin));
 264:     protect(eofa);
 265: 
 266:     while(TRUE) {
 267: 
 268:         fprintf(stdout,"\n%d:>",curdepth);
 269:         dmpport(stdout);
 270:         vtemp = Lread();
 271:         if(vtemp == eofa) franzexit(0);
 272:         printr(eval(vtemp),stdout);
 273:     }
 274:     /* NOTREACHED */
 275: }
 276: 
 277: lispval
 278: errorh(type,message,valret,contuab,uniqid)
 279: lispval type,valret;
 280: int uniqid,contuab;
 281: char *message;
 282: {
 283:     IElimit = 0;
 284:     Ierrorh(type,message,valret,contuab,uniqid);
 285:     /* NOTREACHED */
 286: }
 287: 
 288: lispval
 289: errorh1(type,message,valret,contuab,uniqid,arg1)
 290: lispval type,valret,arg1;
 291: int uniqid,contuab;
 292: char *message;
 293: {
 294:     IElimit = 1;
 295:     IEargs[0] = arg1;
 296:     Ierrorh(type,message,valret,contuab,uniqid);
 297:     /* NOTREACHED */
 298: }
 299: 
 300: lispval
 301: errorh2(type,message,valret,contuab,uniqid,arg1,arg2)
 302: lispval type,valret,arg1,arg2;
 303: int uniqid,contuab;
 304: char *message;
 305: {
 306:     IElimit = 2;
 307:     IEargs[0] = arg1;
 308:     IEargs[1] = arg2;
 309:     Ierrorh(type,message,valret,contuab,uniqid);
 310:     /* NOTREACHED */
 311: }
 312: 
 313: lispval
 314: calhan(limit,work,type,uniqid,contuab,message,handler)
 315: register lispval *work;
 316: lispval handler,type,contuab;
 317: register limit;
 318: register char *message;
 319: int uniqid;
 320: {
 321:         register lispval handy;
 322:         Savestack(4);
 323:         lbot = np;
 324:         protect(handler);       /* funcall the handler */
 325:         protect(handy = newdot());      /* with a list consisting of */
 326:         handy->d.car = type;            /* type, */
 327:         handy = (handy->d.cdr = newdot());
 328:         handy->d.car = inewint(uniqid); /* identifying number, */
 329:         handy = (handy->d.cdr = newdot());
 330:         handy->d.car = contuab;
 331:         handy = (handy->d.cdr = newdot());
 332:         handy->d.car = matom(message);  /* message to be typed out, */
 333:         while(limit-- > 0)
 334:         {                   /* any other args. */
 335:             handy = handy->d.cdr = newdot();
 336:             handy->d.car = *work++;
 337:         }
 338:         handy->d.cdr = nil;
 339: 
 340:         handy = Lfuncal();
 341:         Restorestack();
 342:         return(handy);
 343: }
 344: 
 345: /* lispend **************************************************************/
 346: /* Fatal errors come here, with their epitaph.				*/
 347: lispend(mesg)
 348:     char    mesg[];
 349:     {
 350:     dmpport(poport);
 351:     fprintf(errport,"%s\n",mesg);
 352:     dmpport(errport);
 353:     franzexit(0);
 354:     /* NOT REACHED */
 355:     }
 356: 
 357: /* namerr ***************************************************************/
 358: /* handles namestack overflow, at present by simply giving a message	*/
 359: 
 360: namerr()
 361: {
 362:     if((nplim = np + NAMINC) > orgnp + NAMESIZE)
 363:     {
 364:       printf("Unrecoverable Namestack Overflow, (reset) is forced\n");
 365:       fflush(stdout);
 366:       nplim = orgnp + NAMESIZE - 4*NAMINC;
 367:       lbot = np = nplim - NAMINC;
 368:       protect(matom("reset"));
 369:       Lfuncal();
 370:     }
 371:     error("NAMESTACK OVERFLOW",FALSE);
 372:     /* NOT REACHED */
 373: }
 374: 
 375: binderr()
 376: {
 377:     bnp -= 10;
 378:     error("Bindstack overflow.",FALSE);
 379:     /* NOT REACHED */
 380: }
 381: 
 382: rtaberr()
 383: {
 384:     bindfix(Vreadtable,strtab,nil);
 385:     error("Illegal read table.",FALSE);
 386:     /* NOT REACHED */
 387: }
 388: xserr()
 389: {
 390:     error("Ran out of alternate stack",FALSE);
 391: }
 392: badmem(n)
 393: {
 394:     char errbuf[256], *sprintf();
 395: 
 396:     sprintf(errbuf,"Attempt to allocate beyond static structures (%d).",n);
 397:     error(errbuf,FALSE);
 398:     /* NOT REACHED */
 399: }
 400: argerr(msg)
 401: char *msg;
 402: {
 403:     errorh1(Vermisc,"incorrect number of args to",
 404:                   nil,FALSE,0,matom(msg));
 405:     /* NOT REACHED */
 406: }
 407: 
 408: lispval Vinterrfcn = nil;
 409: 
 410: /*
 411:  * wnaerr - wrong number of arguments to a compiled function hander
 412:  * called with the function name (symbol) and a descriptor of the
 413:  * number of arguments that were expected.  The form of the descriptor
 414:  * is (considered as a decimal number) xxyy where xx is the minumum
 415:  * and yy-1 is the maximum.  A maximum of -1 means that there is no
 416:  * maximum.
 417:  *
 418:  */
 419: wnaerr(fcn,wantargs)
 420: lispval fcn;
 421: {
 422:     if (Vinterrfcn == nil)
 423:     {
 424:     Vinterrfcn = matom("int:wrong-number-of-args-error");
 425:     }
 426:     if (Vinterrfcn->a.fnbnd != nil)
 427:     {
 428:     protect(fcn);
 429:     protect(inewint(wantargs / 1000));    /* min */
 430:     protect(inewint((wantargs % 1000) - 1));  /* max */
 431:     Ifuncal(Vinterrfcn);
 432:     error("wrong number of args function should never return ", FALSE);
 433:     }
 434: 
 435:     errorh1(Vermisc,"wrong number of arguments to ",nil,FALSE,0,fcn);
 436: }

Defined functions

Defined variables