![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to trpfpe_.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.lib / libF77|
Return to trpfpe_.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.lib / libF77 |
1.1 root 1: /* #define OLD_BSD if you're running < 4.2bsd */
2: /*
3: char id_trpfpe[] = "@(#)trpfpe_.c 1.3";
4: *
5: * Fortran floating-point error handler
6: *
7: * Synopsis:
8: * call trpfpe (n, retval)
9: * causes floating point faults to be trapped, with the
10: * first 'n' errors getting a message printed.
11: * 'retval' is put in place of the bad result.
12: * k = fpecnt()
13: * causes 'k' to get the number of errors since the
14: * last call to trpfpe().
15: *
16: * common /fpeflt/ fpflag
17: * logical fpflag
18: * fpflag will become .true. on faults
19: *
20: * David Wasley, UCBerkeley, June 1983.
21: */
22:
23:
24: #include <stdio.h>
25: #include <signal.h>
26: #include "opcodes.h"
27: #include "operand.h"
28: #include "../libI77/fiodefs.h"
29:
30: #define SIG_VAL int (*)()
31:
32: #if vax /* only works on VAXen */
33:
34: struct arglist { /* what AP points to */
35: long al_numarg; /* only true in CALLS format */
36: long al_arg[256];
37: };
38:
39: struct cframe { /* VAX call frame */
40: long cf_handler;
41: unsigned short cf_psw;
42: unsigned short cf_mask;
43: struct arglist *cf_ap;
44: struct cframe *cf_fp;
45: char *cf_pc;
46: };
47:
48: /*
49: * bits in the PSW
50: */
51: #define PSW_V 0x2
52: #define PSW_FU 0x40
53: #define PSW_IV 0x20
54:
55: /*
56: * where the registers are stored as we see them in the handler
57: */
58: struct reg0_6 {
59: long reg[7];
60: };
61:
62: struct reg7_11 {
63: long reg[5];
64: };
65:
66: #define iR0 reg0_6->reg[0]
67: #define iR1 reg0_6->reg[1]
68: #define iR2 reg0_6->reg[2]
69: #define iR3 reg0_6->reg[3]
70: #define iR4 reg0_6->reg[4]
71: #define iR5 reg0_6->reg[5]
72: #define iR6 reg0_6->reg[6]
73: #define iR7 reg7_11->reg[0]
74: #define iR8 reg7_11->reg[1]
75: #define iR9 reg7_11->reg[2]
76: #define iR10 reg7_11->reg[3]
77: #define iR11 reg7_11->reg[4]
78:
79: union objects { /* for load/store */
80: char ua_byte;
81: short ua_word;
82: long ua_long;
83: float ua_float;
84: double ua_double;
85: union objects *ua_anything;
86: };
87:
88: typedef union objects anything;
89: enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN };
90:
91:
92: /*
93: * assembly language assist
94: * There are some things you just can't do in C
95: */
96: asm(".text");
97:
98: struct cframe *myfp();
99: asm("_myfp: .word 0x0");
100: asm("movl 12(fp),r0");
101: asm("ret");
102:
103: struct arglist *myap();
104: asm("_myap: .word 0x0");
105: asm("movl 8(fp),r0");
106: asm("ret");
107:
108: char *mysp();
109: asm("_mysp: .word 0x0");
110: asm("extzv $30,$2,4(fp),r0");
111: asm("addl2 ap,r0"); /* SP in caller is AP+4 here + SPA bits! */
112: asm("addl2 $4,r0");
113: asm("ret");
114:
115: char *mypc();
116: asm("_mypc: .word 0x0");
117: asm("movl 16(fp),r0");
118: asm("ret");
119:
120: asm(".data");
121:
122:
123: /*
124: * Where interrupted objects are
125: */
126: static struct cframe **ifp; /* addr of saved FP */
127: static struct arglist **iap; /* addr of saved AP */
128: static char *isp; /* value of interrupted SP */
129: static char **ipc; /* addr of saved PC */
130: static struct reg0_6 *reg0_6;/* registers 0-6 are saved on the exception */
131: static struct reg7_11 *reg7_11;/* we save 7-11 by our entry mask */
132: static anything *result_addr; /* where the dummy result goes */
133: static enum object_type result_type; /* what kind of object it is */
134:
135: /*
136: * some globals
137: */
138: static union {
139: long rv_long[2];
140: float rv_float;
141: double rv_double;
142: } retval; /* the user specified dummy result */
143: static int max_messages = 1; /* the user can tell us */
144: static int fpe_count = 0; /* how bad is it ? */
145: long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */
146: static int (*sigfpe_dfl)() = SIG_DFL; /* if we can't fix it ... */
147:
148: /*
149: * The fortran unit control table
150: */
151: extern unit units[];
152:
153: /*
154: * Fortran message table is in main
155: */
156: struct msgtbl {
157: char *mesg;
158: int dummy;
159: };
160: extern struct msgtbl act_fpe[];
161:
162:
163: /*
164: * Get the address of the (saved) next operand & update saved PC.
165: * The major purpose of this is to determine where to store the result.
166: * There is one case we can't deal with: -(SP) or (SP)+
167: * since we can't change the size of the stack.
168: * Let's just hope compilers don't generate that for results.
169: */
170:
171: anything *
172: get_operand (oper_size)
173: int oper_size; /* size of operand we expect */
174: {
175: register int regnum;
176: register int operand_code;
177: int index;
178: anything *oper_addr;
179: anything *reg_addr;
180:
181: regnum = (**ipc & 0xf);
182: if (regnum == PC)
183: operand_code = (*(*ipc)++ & 0xff);
184: else
185: operand_code = (*(*ipc)++ & 0xf0);
186: if (regnum <= R6)
187: reg_addr = (anything *)®0_6->reg[regnum];
188: else if (regnum <= R11)
189: reg_addr = (anything *)®7_11->reg[regnum];
190: else if (regnum == AP)
191: reg_addr = (anything *)iap;
192: else if (regnum == FP)
193: reg_addr = (anything *)ifp;
194: else if (regnum == SP)
195: reg_addr = (anything *)&isp; /* We saved this ourselves */
196: else if (regnum == PC)
197: reg_addr = (anything *)ipc;
198:
199:
200: switch (operand_code)
201: {
202: case IMMEDIATE:
203: oper_addr = (anything *)(*ipc);
204: *ipc += oper_size;
205: return(oper_addr);
206:
207: case ABSOLUTE:
208: oper_addr = (anything *)(**ipc);
209: *ipc += sizeof (anything *);
210: return(oper_addr);
211:
212: case LITERAL0:
213: case LITERAL1:
214: case LITERAL2:
215: case LITERAL3:
216: /* we don't care about the address of these */
217: return((anything *)0);
218:
219: case INDEXED:
220: index = reg_addr->ua_long * oper_size;
221: oper_addr = (anything *)(get_operand(sizeof (long))->ua_long + index);
222: return(oper_addr);
223:
224: case REGISTER:
225: return(reg_addr);
226:
227: case REGDEFERED:
228: return(reg_addr->ua_anything);
229:
230: case AUTODEC:
231: if (regnum == SP)
232: {
233: fprintf(stderr, "trp: can't fix -(SP) operand\n");
234: exit(1);
235: }
236: reg_addr->ua_long -= oper_size;
237: oper_addr = reg_addr->ua_anything;
238: return(oper_addr);
239:
240: case AUTOINC:
241: if (regnum == SP)
242: {
243: fprintf(stderr, "trp: can't fix (SP)+ operand\n");
244: exit(1);
245: }
246: oper_addr = reg_addr->ua_anything;
247: reg_addr->ua_long += oper_size;
248: return(oper_addr);
249:
250: case AUTOINCDEF:
251: if (regnum == SP)
252: {
253: fprintf(stderr, "trp: can't fix @(SP)+ operand\n");
254: exit(1);
255: }
256: oper_addr = (reg_addr->ua_anything)->ua_anything;
257: reg_addr->ua_long += sizeof (anything *);
258: return(oper_addr);
259:
260: case BYTEDISP:
261: case BYTEREL:
262: index = ((anything *)(*ipc))->ua_byte;
263: *ipc += sizeof (char); /* do it now in case reg==PC */
264: oper_addr = (anything *)(index + reg_addr->ua_long);
265: return(oper_addr);
266:
267: case BYTEDISPDEF:
268: case BYTERELDEF:
269: index = ((anything *)(*ipc))->ua_byte;
270: *ipc += sizeof (char); /* do it now in case reg==PC */
271: oper_addr = (anything *)(index + reg_addr->ua_long);
272: oper_addr = oper_addr->ua_anything;
273: return(oper_addr);
274:
275: case WORDDISP:
276: case WORDREL:
277: index = ((anything *)(*ipc))->ua_word;
278: *ipc += sizeof (short); /* do it now in case reg==PC */
279: oper_addr = (anything *)(index + reg_addr->ua_long);
280: return(oper_addr);
281:
282: case WORDDISPDEF:
283: case WORDRELDEF:
284: index = ((anything *)(*ipc))->ua_word;
285: *ipc += sizeof (short); /* do it now in case reg==PC */
286: oper_addr = (anything *)(index + reg_addr->ua_long);
287: oper_addr = oper_addr->ua_anything;
288: return(oper_addr);
289:
290: case LONGDISP:
291: case LONGREL:
292: index = ((anything *)(*ipc))->ua_long;
293: *ipc += sizeof (long); /* do it now in case reg==PC */
294: oper_addr = (anything *)(index + reg_addr->ua_long);
295: return(oper_addr);
296:
297: case LONGDISPDEF:
298: case LONGRELDEF:
299: index = ((anything *)(*ipc))->ua_long;
300: *ipc += sizeof (long); /* do it now in case reg==PC */
301: oper_addr = (anything *)(index + reg_addr->ua_long);
302: oper_addr = oper_addr->ua_anything;
303: return(oper_addr);
304:
305: /* NOTREACHED */
306: }
307: }
308:
309: /*
310: * Trap & repair floating exceptions so that a program may proceed.
311: * There is no notion of "correctness" here; just the ability to continue.
312: *
313: * The on_fpe() routine first checks the type code to see if the
314: * exception is repairable. If so, it checks the opcode to see if
315: * it is one that it knows. If this is true, it then simulates the
316: * VAX cpu in retrieving operands in order to increment iPC correctly.
317: * It notes where the result of the operation would have been stored
318: * and substitutes a previously supplied value.
319: */
320:
321: #ifdef OLD_BSD
322: on_fpe(signo, code, myaddr, pc, ps)
323: int signo, code, ps;
324: char *myaddr, *pc;
325: #else
326: on_fpe(signo, code, sc, grbg)
327: int signo, code;
328: struct sigcontext *sc;
329: #endif
330: {
331: /*
332: * There must be at least 5 register variables here
333: * so our entry mask will save R11-R7.
334: */
335: register long *stk;
336: register long *sp;
337: register struct arglist *ap;
338: register struct cframe *fp;
339: register FILE *ef;
340:
341: ef = units[STDERR].ufd; /* fortran error stream */
342:
343: switch (code)
344: {
345: case FPE_INTOVF_TRAP: /* integer overflow */
346: case FPE_INTDIV_TRAP: /* integer divide by zero */
347: case FPE_FLTOVF_TRAP: /* floating overflow */
348: case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */
349: case FPE_FLTUND_TRAP: /* floating underflow */
350: case FPE_DECOVF_TRAP: /* decimal overflow */
351: case FPE_SUBRNG_TRAP: /* subscript out of range */
352: default:
353: cant_fix:
354: if (sigfpe_dfl > (SIG_VAL)7) /* user specified */
355: #ifdef OLD_BSD
356: return((*sigfpe_dfl)(signo, code, myaddr, pc, ps));
357: #else
358: return((*sigfpe_dfl)(signo, code, sc, grbg));
359: #endif
360: else
361: #ifdef OLD_BSD
362: sigdie(signo, code, myaddr, pc, ps);
363: #else
364: sigdie(signo, code, sc, grbg);
365: #endif
366: /* NOTREACHED */
367:
368: case FPE_FLTOVF_FAULT: /* floating overflow fault */
369: case FPE_FLTDIV_FAULT: /* divide by zero floating fault */
370: case FPE_FLTUND_FAULT: /* floating underflow fault */
371: if (++fpe_count <= max_messages) {
372: fprintf(ef, "trpfpe: %s",
373: act_fpe[code-1].mesg);
374: if (fpe_count == max_messages)
375: fprintf(ef, ": No more messages will be printed.\n");
376: else
377: fputc('\n', ef);
378: }
379: fpeflt_ = -1;
380: break;
381: }
382:
383: ap = myap(); /* my arglist pointer */
384: fp = myfp(); /* my frame pointer */
385: ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */
386: iap = &(fp->cf_fp)->cf_ap;
387: /*
388: * these are likely to be system dependent
389: */
390: reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe));
391: reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11));
392:
393: #ifdef OLD_BSD
394: ipc = &pc;
395: isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */
396: ps &= ~(PSW_V|PSW_FU);
397: #else
398: ipc = (char **)&sc->sc_pc;
399: isp = (char *)sc + sizeof (struct sigcontext);
400: sc->sc_ps &= ~(PSW_V|PSW_FU);
401: #endif
402:
403:
404: switch (*(*ipc)++)
405: {
406: case ADDD3:
407: case DIVD3:
408: case MULD3:
409: case SUBD3:
410: (void) get_operand(sizeof (double));
411: /* intentional fall-thru */
412:
413: case ADDD2:
414: case DIVD2:
415: case MULD2:
416: case SUBD2:
417: case MNEGD:
418: case MOVD:
419: (void) get_operand(sizeof (double));
420: result_addr = get_operand(sizeof (double));
421: result_type = DOUBLE;
422: break;
423:
424: case ADDF3:
425: case DIVF3:
426: case MULF3:
427: case SUBF3:
428: (void) get_operand(sizeof (float));
429: /* intentional fall-thru */
430:
431: case ADDF2:
432: case DIVF2:
433: case MULF2:
434: case SUBF2:
435: case MNEGF:
436: case MOVF:
437: (void) get_operand(sizeof (float));
438: result_addr = get_operand(sizeof (float));
439: result_type = FLOAT;
440: break;
441:
442: case CVTDF:
443: (void) get_operand(sizeof (double));
444: result_addr = get_operand(sizeof (float));
445: result_type = FLOAT;
446: break;
447:
448: case CVTFD:
449: (void) get_operand(sizeof (float));
450: result_addr = get_operand(sizeof (double));
451: result_type = DOUBLE;
452: break;
453:
454: case EMODF:
455: case EMODD:
456: fprintf(ef, "trpfpe: can't fix emod yet\n");
457: goto cant_fix;
458:
459: case POLYF:
460: case POLYD:
461: fprintf(ef, "trpfpe: can't fix poly yet\n");
462: goto cant_fix;
463:
464: case ACBD:
465: case ACBF:
466: case CMPD:
467: case CMPF:
468: case TSTD:
469: case TSTF:
470: case CVTDB:
471: case CVTDL:
472: case CVTDW:
473: case CVTFB:
474: case CVTFL:
475: case CVTFW:
476: case CVTRDL:
477: case CVTRFL:
478: /* These can generate only reserved operand faults */
479: /* They are shown here for completeness */
480:
481: default:
482: fprintf(stderr, "trp: opcode 0x%02x unknown\n",
483: *(--(*ipc)) & 0xff);
484: goto cant_fix;
485: /* NOTREACHED */
486: }
487:
488: if (result_type == FLOAT)
489: result_addr->ua_float = retval.rv_float;
490: else
491: {
492: if (result_addr == (anything *)&iR6)
493: { /*
494: * special case - the R6/R7 pair is stored apart
495: */
496: result_addr->ua_long = retval.rv_long[0];
497: ((anything *)&iR7)->ua_long = retval.rv_long[1];
498: }
499: else
500: result_addr->ua_double = retval.rv_double;
501: }
502: signal(SIGFPE, on_fpe);
503: }
504: #endif vax
505:
506: trpfpe_ (count, rval)
507: long *count; /* how many to announce */
508: double *rval; /* dummy return value */
509: {
510: #if vax
511: max_messages = *count;
512: retval.rv_double = *rval;
513: sigfpe_dfl = signal(SIGFPE, on_fpe);
514: fpe_count = 0;
515: #endif
516: }
517:
518: long
519: fpecnt_ ()
520: {
521: #if vax
522: return (fpe_count);
523: #else
524: return (0L);
525: #endif
526: }
527:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.