![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to error.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz|
Return to error.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 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: }
437:
438:
439:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.