Commit | Line | Data |
---|---|---|
27635624 | 1 | /* #define OLD_BSD if you're running < 4.2 bsd */ |
799e6b82 | 2 | /* |
42a118aa RE |
3 | * Copyright (c) 1980 Regents of the University of California. |
4 | * All rights reserved. The Berkeley software License Agreement | |
5 | * specifies the terms and conditions for redistribution. | |
6 | * | |
c7b2a3dd | 7 | * @(#)trpfpe_.c 5.5 %G% |
a2b867fb | 8 | * |
799e6b82 DW |
9 | * |
10 | * Fortran floating-point error handler | |
11 | * | |
12 | * Synopsis: | |
13 | * call trpfpe (n, retval) | |
14 | * causes floating point faults to be trapped, with the | |
15 | * first 'n' errors getting a message printed. | |
16 | * 'retval' is put in place of the bad result. | |
17 | * k = fpecnt() | |
18 | * causes 'k' to get the number of errors since the | |
19 | * last call to trpfpe(). | |
20 | * | |
21 | * common /fpeflt/ fpflag | |
22 | * logical fpflag | |
23 | * fpflag will become .true. on faults | |
24 | * | |
25 | * David Wasley, UCBerkeley, June 1983. | |
26 | */ | |
27 | ||
28 | ||
29 | #include <stdio.h> | |
c7b2a3dd | 30 | #include <sys/signal.h> |
799e6b82 DW |
31 | #include "../libI77/fiodefs.h" |
32 | ||
c7b2a3dd | 33 | #define SIG_VAL void (*)() |
799e6b82 | 34 | |
815666cb KM |
35 | #ifdef vax |
36 | #include "opcodes.h" | |
37 | #include "operand.h" | |
799e6b82 DW |
38 | |
39 | struct arglist { /* what AP points to */ | |
40 | long al_numarg; /* only true in CALLS format */ | |
41 | long al_arg[256]; | |
42 | }; | |
43 | ||
44 | struct cframe { /* VAX call frame */ | |
45 | long cf_handler; | |
46 | unsigned short cf_psw; | |
47 | unsigned short cf_mask; | |
48 | struct arglist *cf_ap; | |
49 | struct cframe *cf_fp; | |
50 | char *cf_pc; | |
51 | }; | |
52 | ||
53 | /* | |
54 | * bits in the PSW | |
55 | */ | |
56 | #define PSW_V 0x2 | |
57 | #define PSW_FU 0x40 | |
58 | #define PSW_IV 0x20 | |
59 | ||
60 | /* | |
61 | * where the registers are stored as we see them in the handler | |
62 | */ | |
63 | struct reg0_6 { | |
64 | long reg[7]; | |
65 | }; | |
66 | ||
67 | struct reg7_11 { | |
68 | long reg[5]; | |
69 | }; | |
70 | ||
71 | #define iR0 reg0_6->reg[0] | |
72 | #define iR1 reg0_6->reg[1] | |
73 | #define iR2 reg0_6->reg[2] | |
74 | #define iR3 reg0_6->reg[3] | |
75 | #define iR4 reg0_6->reg[4] | |
76 | #define iR5 reg0_6->reg[5] | |
77 | #define iR6 reg0_6->reg[6] | |
78 | #define iR7 reg7_11->reg[0] | |
79 | #define iR8 reg7_11->reg[1] | |
80 | #define iR9 reg7_11->reg[2] | |
81 | #define iR10 reg7_11->reg[3] | |
82 | #define iR11 reg7_11->reg[4] | |
83 | ||
84 | union objects { /* for load/store */ | |
85 | char ua_byte; | |
86 | short ua_word; | |
87 | long ua_long; | |
88 | float ua_float; | |
89 | double ua_double; | |
90 | union objects *ua_anything; | |
91 | }; | |
92 | ||
93 | typedef union objects anything; | |
94 | enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN }; | |
95 | ||
96 | \f | |
97 | /* | |
98 | * assembly language assist | |
99 | * There are some things you just can't do in C | |
100 | */ | |
101 | asm(".text"); | |
102 | ||
103 | struct cframe *myfp(); | |
104 | asm("_myfp: .word 0x0"); | |
105 | asm("movl 12(fp),r0"); | |
106 | asm("ret"); | |
107 | ||
108 | struct arglist *myap(); | |
109 | asm("_myap: .word 0x0"); | |
110 | asm("movl 8(fp),r0"); | |
111 | asm("ret"); | |
112 | ||
113 | char *mysp(); | |
114 | asm("_mysp: .word 0x0"); | |
115 | asm("extzv $30,$2,4(fp),r0"); | |
116 | asm("addl2 ap,r0"); /* SP in caller is AP+4 here + SPA bits! */ | |
117 | asm("addl2 $4,r0"); | |
118 | asm("ret"); | |
119 | ||
120 | char *mypc(); | |
121 | asm("_mypc: .word 0x0"); | |
122 | asm("movl 16(fp),r0"); | |
123 | asm("ret"); | |
124 | ||
125 | asm(".data"); | |
126 | ||
127 | \f | |
128 | /* | |
129 | * Where interrupted objects are | |
130 | */ | |
131 | static struct cframe **ifp; /* addr of saved FP */ | |
132 | static struct arglist **iap; /* addr of saved AP */ | |
133 | static char *isp; /* value of interrupted SP */ | |
134 | static char **ipc; /* addr of saved PC */ | |
135 | static struct reg0_6 *reg0_6;/* registers 0-6 are saved on the exception */ | |
136 | static struct reg7_11 *reg7_11;/* we save 7-11 by our entry mask */ | |
137 | static anything *result_addr; /* where the dummy result goes */ | |
138 | static enum object_type result_type; /* what kind of object it is */ | |
139 | ||
140 | /* | |
141 | * some globals | |
142 | */ | |
143 | static union { | |
144 | long rv_long[2]; | |
145 | float rv_float; | |
146 | double rv_double; | |
147 | } retval; /* the user specified dummy result */ | |
148 | static int max_messages = 1; /* the user can tell us */ | |
149 | static int fpe_count = 0; /* how bad is it ? */ | |
150 | long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */ | |
151 | static int (*sigfpe_dfl)() = SIG_DFL; /* if we can't fix it ... */ | |
152 | ||
153 | /* | |
154 | * The fortran unit control table | |
155 | */ | |
156 | extern unit units[]; | |
157 | ||
158 | /* | |
159 | * Fortran message table is in main | |
160 | */ | |
161 | struct msgtbl { | |
162 | char *mesg; | |
163 | int dummy; | |
164 | }; | |
165 | extern struct msgtbl act_fpe[]; | |
166 | ||
167 | \f | |
168 | /* | |
169 | * Get the address of the (saved) next operand & update saved PC. | |
170 | * The major purpose of this is to determine where to store the result. | |
171 | * There is one case we can't deal with: -(SP) or (SP)+ | |
172 | * since we can't change the size of the stack. | |
173 | * Let's just hope compilers don't generate that for results. | |
174 | */ | |
175 | ||
176 | anything * | |
177 | get_operand (oper_size) | |
178 | int oper_size; /* size of operand we expect */ | |
179 | { | |
180 | register int regnum; | |
181 | register int operand_code; | |
182 | int index; | |
183 | anything *oper_addr; | |
184 | anything *reg_addr; | |
185 | ||
186 | regnum = (**ipc & 0xf); | |
187 | if (regnum == PC) | |
188 | operand_code = (*(*ipc)++ & 0xff); | |
189 | else | |
190 | operand_code = (*(*ipc)++ & 0xf0); | |
191 | if (regnum <= R6) | |
192 | reg_addr = (anything *)®0_6->reg[regnum]; | |
193 | else if (regnum <= R11) | |
194 | reg_addr = (anything *)®7_11->reg[regnum]; | |
195 | else if (regnum == AP) | |
196 | reg_addr = (anything *)iap; | |
197 | else if (regnum == FP) | |
198 | reg_addr = (anything *)ifp; | |
199 | else if (regnum == SP) | |
200 | reg_addr = (anything *)&isp; /* We saved this ourselves */ | |
201 | else if (regnum == PC) | |
202 | reg_addr = (anything *)ipc; | |
203 | ||
204 | ||
205 | switch (operand_code) | |
206 | { | |
207 | case IMMEDIATE: | |
208 | oper_addr = (anything *)(*ipc); | |
209 | *ipc += oper_size; | |
210 | return(oper_addr); | |
211 | ||
212 | case ABSOLUTE: | |
213 | oper_addr = (anything *)(**ipc); | |
214 | *ipc += sizeof (anything *); | |
215 | return(oper_addr); | |
216 | ||
217 | case LITERAL0: | |
218 | case LITERAL1: | |
219 | case LITERAL2: | |
220 | case LITERAL3: | |
221 | /* we don't care about the address of these */ | |
222 | return((anything *)0); | |
223 | ||
224 | case INDEXED: | |
225 | index = reg_addr->ua_long * oper_size; | |
226 | oper_addr = (anything *)(get_operand(sizeof (long))->ua_long + index); | |
227 | return(oper_addr); | |
228 | ||
229 | case REGISTER: | |
230 | return(reg_addr); | |
231 | ||
232 | case REGDEFERED: | |
233 | return(reg_addr->ua_anything); | |
234 | ||
235 | case AUTODEC: | |
236 | if (regnum == SP) | |
237 | { | |
238 | fprintf(stderr, "trp: can't fix -(SP) operand\n"); | |
239 | exit(1); | |
240 | } | |
241 | reg_addr->ua_long -= oper_size; | |
242 | oper_addr = reg_addr->ua_anything; | |
243 | return(oper_addr); | |
244 | ||
245 | case AUTOINC: | |
246 | if (regnum == SP) | |
247 | { | |
248 | fprintf(stderr, "trp: can't fix (SP)+ operand\n"); | |
249 | exit(1); | |
250 | } | |
251 | oper_addr = reg_addr->ua_anything; | |
252 | reg_addr->ua_long += oper_size; | |
253 | return(oper_addr); | |
254 | ||
255 | case AUTOINCDEF: | |
256 | if (regnum == SP) | |
257 | { | |
258 | fprintf(stderr, "trp: can't fix @(SP)+ operand\n"); | |
259 | exit(1); | |
260 | } | |
261 | oper_addr = (reg_addr->ua_anything)->ua_anything; | |
262 | reg_addr->ua_long += sizeof (anything *); | |
263 | return(oper_addr); | |
264 | ||
265 | case BYTEDISP: | |
266 | case BYTEREL: | |
b9f2a0ee DW |
267 | index = ((anything *)(*ipc))->ua_byte; |
268 | *ipc += sizeof (char); /* do it now in case reg==PC */ | |
269 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
270 | return(oper_addr); |
271 | ||
272 | case BYTEDISPDEF: | |
273 | case BYTERELDEF: | |
b9f2a0ee DW |
274 | index = ((anything *)(*ipc))->ua_byte; |
275 | *ipc += sizeof (char); /* do it now in case reg==PC */ | |
276 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 277 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
278 | return(oper_addr); |
279 | ||
280 | case WORDDISP: | |
281 | case WORDREL: | |
b9f2a0ee DW |
282 | index = ((anything *)(*ipc))->ua_word; |
283 | *ipc += sizeof (short); /* do it now in case reg==PC */ | |
284 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
285 | return(oper_addr); |
286 | ||
287 | case WORDDISPDEF: | |
288 | case WORDRELDEF: | |
b9f2a0ee DW |
289 | index = ((anything *)(*ipc))->ua_word; |
290 | *ipc += sizeof (short); /* do it now in case reg==PC */ | |
291 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 292 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
293 | return(oper_addr); |
294 | ||
295 | case LONGDISP: | |
296 | case LONGREL: | |
b9f2a0ee DW |
297 | index = ((anything *)(*ipc))->ua_long; |
298 | *ipc += sizeof (long); /* do it now in case reg==PC */ | |
299 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
300 | return(oper_addr); |
301 | ||
302 | case LONGDISPDEF: | |
303 | case LONGRELDEF: | |
b9f2a0ee DW |
304 | index = ((anything *)(*ipc))->ua_long; |
305 | *ipc += sizeof (long); /* do it now in case reg==PC */ | |
306 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 307 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
308 | return(oper_addr); |
309 | ||
310 | /* NOTREACHED */ | |
311 | } | |
312 | } | |
313 | \f | |
314 | /* | |
315 | * Trap & repair floating exceptions so that a program may proceed. | |
316 | * There is no notion of "correctness" here; just the ability to continue. | |
317 | * | |
318 | * The on_fpe() routine first checks the type code to see if the | |
319 | * exception is repairable. If so, it checks the opcode to see if | |
320 | * it is one that it knows. If this is true, it then simulates the | |
321 | * VAX cpu in retrieving operands in order to increment iPC correctly. | |
322 | * It notes where the result of the operation would have been stored | |
323 | * and substitutes a previously supplied value. | |
324 | */ | |
325 | ||
326 | #ifdef OLD_BSD | |
327 | on_fpe(signo, code, myaddr, pc, ps) | |
328 | int signo, code, ps; | |
329 | char *myaddr, *pc; | |
330 | #else | |
c7b2a3dd | 331 | void |
799e6b82 DW |
332 | on_fpe(signo, code, sc, grbg) |
333 | int signo, code; | |
334 | struct sigcontext *sc; | |
335 | #endif | |
336 | { | |
337 | /* | |
338 | * There must be at least 5 register variables here | |
339 | * so our entry mask will save R11-R7. | |
340 | */ | |
341 | register long *stk; | |
342 | register long *sp; | |
343 | register struct arglist *ap; | |
344 | register struct cframe *fp; | |
345 | register FILE *ef; | |
346 | ||
347 | ef = units[STDERR].ufd; /* fortran error stream */ | |
348 | ||
349 | switch (code) | |
350 | { | |
351 | case FPE_INTOVF_TRAP: /* integer overflow */ | |
352 | case FPE_INTDIV_TRAP: /* integer divide by zero */ | |
353 | case FPE_FLTOVF_TRAP: /* floating overflow */ | |
354 | case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */ | |
355 | case FPE_FLTUND_TRAP: /* floating underflow */ | |
356 | case FPE_DECOVF_TRAP: /* decimal overflow */ | |
357 | case FPE_SUBRNG_TRAP: /* subscript out of range */ | |
358 | default: | |
359 | cant_fix: | |
360 | if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ | |
361 | #ifdef OLD_BSD | |
c7b2a3dd | 362 | (*sigfpe_dfl)(signo, code, myaddr, pc, ps); |
799e6b82 | 363 | #else |
c7b2a3dd | 364 | (*sigfpe_dfl)(signo, code, sc, grbg); |
799e6b82 DW |
365 | #endif |
366 | else | |
367 | #ifdef OLD_BSD | |
368 | sigdie(signo, code, myaddr, pc, ps); | |
369 | #else | |
370 | sigdie(signo, code, sc, grbg); | |
371 | #endif | |
372 | /* NOTREACHED */ | |
373 | ||
374 | case FPE_FLTOVF_FAULT: /* floating overflow fault */ | |
375 | case FPE_FLTDIV_FAULT: /* divide by zero floating fault */ | |
376 | case FPE_FLTUND_FAULT: /* floating underflow fault */ | |
377 | if (++fpe_count <= max_messages) { | |
378 | fprintf(ef, "trpfpe: %s", | |
379 | act_fpe[code-1].mesg); | |
380 | if (fpe_count == max_messages) | |
381 | fprintf(ef, ": No more messages will be printed.\n"); | |
382 | else | |
383 | fputc('\n', ef); | |
384 | } | |
385 | fpeflt_ = -1; | |
386 | break; | |
387 | } | |
388 | ||
389 | ap = myap(); /* my arglist pointer */ | |
390 | fp = myfp(); /* my frame pointer */ | |
391 | ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */ | |
392 | iap = &(fp->cf_fp)->cf_ap; | |
393 | /* | |
394 | * these are likely to be system dependent | |
395 | */ | |
396 | reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe)); | |
397 | reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11)); | |
398 | ||
399 | #ifdef OLD_BSD | |
400 | ipc = &pc; | |
401 | isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */ | |
402 | ps &= ~(PSW_V|PSW_FU); | |
403 | #else | |
404 | ipc = (char **)&sc->sc_pc; | |
09f50985 | 405 | isp = (char *)sc + sizeof (struct sigcontext); |
799e6b82 DW |
406 | sc->sc_ps &= ~(PSW_V|PSW_FU); |
407 | #endif | |
408 | ||
409 | ||
410 | switch (*(*ipc)++) | |
411 | { | |
412 | case ADDD3: | |
413 | case DIVD3: | |
414 | case MULD3: | |
415 | case SUBD3: | |
416 | (void) get_operand(sizeof (double)); | |
417 | /* intentional fall-thru */ | |
418 | ||
419 | case ADDD2: | |
420 | case DIVD2: | |
421 | case MULD2: | |
422 | case SUBD2: | |
423 | case MNEGD: | |
424 | case MOVD: | |
425 | (void) get_operand(sizeof (double)); | |
426 | result_addr = get_operand(sizeof (double)); | |
427 | result_type = DOUBLE; | |
428 | break; | |
429 | ||
430 | case ADDF3: | |
431 | case DIVF3: | |
432 | case MULF3: | |
433 | case SUBF3: | |
434 | (void) get_operand(sizeof (float)); | |
435 | /* intentional fall-thru */ | |
436 | ||
437 | case ADDF2: | |
438 | case DIVF2: | |
439 | case MULF2: | |
440 | case SUBF2: | |
441 | case MNEGF: | |
442 | case MOVF: | |
443 | (void) get_operand(sizeof (float)); | |
444 | result_addr = get_operand(sizeof (float)); | |
445 | result_type = FLOAT; | |
446 | break; | |
447 | ||
448 | case CVTDF: | |
449 | (void) get_operand(sizeof (double)); | |
450 | result_addr = get_operand(sizeof (float)); | |
451 | result_type = FLOAT; | |
452 | break; | |
453 | ||
454 | case CVTFD: | |
455 | (void) get_operand(sizeof (float)); | |
456 | result_addr = get_operand(sizeof (double)); | |
457 | result_type = DOUBLE; | |
458 | break; | |
459 | ||
460 | case EMODF: | |
461 | case EMODD: | |
462 | fprintf(ef, "trpfpe: can't fix emod yet\n"); | |
463 | goto cant_fix; | |
464 | ||
465 | case POLYF: | |
466 | case POLYD: | |
467 | fprintf(ef, "trpfpe: can't fix poly yet\n"); | |
468 | goto cant_fix; | |
469 | ||
470 | case ACBD: | |
471 | case ACBF: | |
472 | case CMPD: | |
473 | case CMPF: | |
474 | case TSTD: | |
475 | case TSTF: | |
476 | case CVTDB: | |
477 | case CVTDL: | |
478 | case CVTDW: | |
479 | case CVTFB: | |
480 | case CVTFL: | |
481 | case CVTFW: | |
482 | case CVTRDL: | |
483 | case CVTRFL: | |
484 | /* These can generate only reserved operand faults */ | |
485 | /* They are shown here for completeness */ | |
486 | ||
487 | default: | |
488 | fprintf(stderr, "trp: opcode 0x%02x unknown\n", | |
489 | *(--(*ipc)) & 0xff); | |
490 | goto cant_fix; | |
491 | /* NOTREACHED */ | |
492 | } | |
493 | ||
494 | if (result_type == FLOAT) | |
495 | result_addr->ua_float = retval.rv_float; | |
496 | else | |
497 | { | |
498 | if (result_addr == (anything *)&iR6) | |
499 | { /* | |
500 | * special case - the R6/R7 pair is stored apart | |
501 | */ | |
502 | result_addr->ua_long = retval.rv_long[0]; | |
503 | ((anything *)&iR7)->ua_long = retval.rv_long[1]; | |
504 | } | |
505 | else | |
506 | result_addr->ua_double = retval.rv_double; | |
507 | } | |
508 | signal(SIGFPE, on_fpe); | |
509 | } | |
799e6b82 DW |
510 | |
511 | trpfpe_ (count, rval) | |
512 | long *count; /* how many to announce */ | |
513 | double *rval; /* dummy return value */ | |
514 | { | |
799e6b82 DW |
515 | max_messages = *count; |
516 | retval.rv_double = *rval; | |
517 | sigfpe_dfl = signal(SIGFPE, on_fpe); | |
518 | fpe_count = 0; | |
799e6b82 DW |
519 | } |
520 | ||
521 | long | |
522 | fpecnt_ () | |
523 | { | |
799e6b82 | 524 | return (fpe_count); |
815666cb KM |
525 | } |
526 | #endif vax | |
527 | ||
528 | #ifdef tahoe | |
529 | /* | |
530 | * This handler just prints a message. It cannot fix anything | |
531 | * on Power6 because of its fpp architecture. In any case, there | |
532 | * are no arithmetic faults (only traps) around, so that no instruction | |
533 | * is interrupted befor it completes, and PC points to the next floating | |
534 | * point instruction (not necessarily next executable instr after the one | |
535 | * that got the exception). | |
536 | */ | |
537 | ||
538 | struct arglist { /* what AP points to */ | |
539 | long al_arg[256]; | |
540 | }; | |
541 | ||
542 | struct reg0_1 { | |
543 | long reg[2]; | |
544 | }; | |
545 | struct reg2_12 { | |
546 | long reg[11]; | |
547 | }; | |
548 | #include <sys/types.h> | |
549 | #include <frame.h> | |
550 | #include "sigframe.h" | |
551 | ||
552 | /* | |
553 | * bits in the PSL | |
554 | */ | |
555 | #include <machine/psl.h> | |
556 | ||
557 | /* | |
558 | * where the registers are stored as we see them in the handler | |
559 | */ | |
560 | ||
561 | ||
562 | #define iR0 reg0_1->reg[1] | |
563 | #define iR1 reg0_1->reg[0] | |
564 | ||
565 | #define iR2 reg2_12->reg[0] | |
566 | #define iR3 reg2_12->reg[1] | |
567 | #define iR4 reg2_12->reg[2] | |
568 | #define iR5 reg2_12->reg[3] | |
569 | #define iR6 reg2_12->reg[4] | |
570 | #define iR7 reg2_12->reg[5] | |
571 | #define iR8 reg2_12->reg[6] | |
572 | #define iR9 reg2_12->reg[7] | |
573 | #define iR10 reg2_12->reg[8] | |
574 | #define iR11 reg2_12->reg[9] | |
575 | #define iR12 reg2_12->reg[10] | |
576 | ||
577 | union objects { /* for load/store */ | |
578 | char ua_byte; | |
579 | short ua_word; | |
580 | long ua_long; | |
581 | float ua_float; | |
582 | double ua_double; | |
583 | union objects *ua_anything; | |
584 | }; | |
585 | ||
586 | typedef union objects anything; | |
587 | enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN }; | |
588 | ||
589 | \f | |
590 | /* | |
591 | * assembly language assist | |
592 | * There are some things you just can't do in C | |
593 | */ | |
594 | asm(".text"); | |
595 | ||
596 | long *myfp(); | |
597 | asm("_myfp: .word 0"); | |
598 | asm("movl (fp),r0"); | |
599 | asm("ret"); | |
600 | ||
601 | struct frame *framep(p) | |
602 | long *p; | |
603 | { | |
604 | return((struct frame *)(p-2)); | |
605 | } | |
606 | ||
607 | struct arglist *argp(p) | |
608 | long *p; | |
609 | { | |
610 | return((struct arglist *)(p+1)); | |
611 | } | |
612 | ||
613 | char *mysp(); | |
614 | asm("_mysp: .word 0"); | |
615 | asm("addl3 $4,fp,r0"); | |
616 | asm("ret"); | |
617 | ||
618 | char *mypc(); | |
619 | asm("_mypc: .word 0"); | |
620 | asm("movl -8(fp),r0"); | |
621 | asm("ret"); | |
622 | ||
623 | asm(".data"); | |
624 | ||
625 | \f | |
626 | /* | |
627 | * Where interrupted objects are | |
628 | */ | |
629 | static struct frame *ifp; /* addr of saved FP */ | |
630 | static struct arglist *iap; /* addr of saved AP */ | |
631 | static char *isp; /* value of interrupted SP */ | |
632 | static char **ipc; /* addr of saved PC */ | |
633 | static struct reg0_1 *reg0_1;/* registers 0-1 are saved on the exception */ | |
634 | static struct reg2_12 *reg2_12;/* we save 2-12 by our entry mask */ | |
635 | static anything *result_addr; /* where the dummy result goes */ | |
636 | static enum object_type result_type; /* what kind of object it is */ | |
637 | ||
638 | /* | |
639 | * some globals | |
640 | */ | |
641 | static union { | |
642 | long rv_long[2]; | |
643 | float rv_float; | |
644 | double rv_double; | |
645 | } retval; /* the user specified dummy result */ | |
646 | static int max_messages = 1; /* the user can tell us */ | |
647 | static int fpe_count = 0; /* how bad is it ? */ | |
648 | long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */ | |
c7b2a3dd | 649 | static sig_t sigfpe_dfl = SIG_DFL; /* if we can't fix it ... */ |
815666cb KM |
650 | |
651 | /* | |
652 | * The fortran unit control table | |
653 | */ | |
654 | extern unit units[]; | |
655 | ||
656 | /* | |
657 | * Fortran message table is in main | |
658 | */ | |
659 | struct msgtbl { | |
660 | char *mesg; | |
661 | int dummy; | |
662 | }; | |
663 | extern struct msgtbl act_fpe[]; | |
664 | ||
665 | \f | |
666 | /* VALID ONLY ON VAX !!! | |
667 | * | |
668 | * Get the address of the (saved) next operand & update saved PC. | |
669 | * The major purpose of this is to determine where to store the result. | |
670 | * There is one case we can't deal with: -(SP) or (SP)+ | |
671 | * since we can't change the size of the stack. | |
672 | * Let's just hope compilers don't generate that for results. | |
673 | */ | |
674 | ||
675 | \f | |
676 | /* | |
677 | * Trap & repair floating exceptions so that a program may proceed. | |
678 | * There is no notion of "correctness" here; just the ability to continue. | |
679 | * | |
680 | * The on_fpe() routine first checks the type code to see if the | |
681 | * exception is repairable. If so, it checks the opcode to see if | |
682 | * it is one that it knows. If this is true, it then simulates the | |
683 | * VAX cpu in retrieving operands in order to increment iPC correctly. | |
684 | * It notes where the result of the operation would have been stored | |
685 | * and substitutes a previously supplied value. | |
686 | * DOES NOT REPAIR ON TAHOE !!! | |
687 | */ | |
c7b2a3dd | 688 | void |
815666cb KM |
689 | on_fpe(signo, code, sc) |
690 | int signo, code; | |
691 | struct sigcontext *sc; | |
692 | { | |
693 | /* | |
694 | * There must be at least 11 register variables here | |
695 | * so our entry mask will save R12-R2. | |
696 | */ | |
697 | register long *stk; | |
698 | register long *sp, *rfp; | |
699 | register struct arglist *ap; | |
700 | register struct frame *fp; | |
701 | register FILE *ef; | |
702 | register struct sigframe *sfp; | |
703 | register long dmy1, dmy2, dmy3, dmy4; | |
704 | ||
705 | dmy1 = dmy2 = dmy3 = dmy4 = 0; | |
706 | ||
707 | ef = units[STDERR].ufd; /* fortran error stream */ | |
708 | ||
709 | switch (code) | |
710 | { | |
711 | case FPE_INTOVF_TRAP: /* integer overflow */ | |
712 | case FPE_INTDIV_TRAP: /* integer divide by zero */ | |
713 | case FPE_FLTOVF_TRAP: /* floating overflow */ | |
714 | case FPE_FLTDIV_TRAP: /* floating divide by zero */ | |
715 | case FPE_FLTUND_TRAP: /* floating underflow */ | |
716 | default: | |
717 | cant_fix: | |
718 | if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ | |
c7b2a3dd | 719 | (*sigfpe_dfl)(signo, code, sc); |
815666cb KM |
720 | else |
721 | if (++fpe_count <= max_messages) { | |
722 | fprintf(ef, "trpfpe: %s", | |
723 | act_fpe[code-1].mesg); | |
724 | if (fpe_count == max_messages) | |
725 | fprintf(ef, ": No more messages will be printed.\n"); | |
726 | else | |
727 | fputc('\n', ef); | |
728 | } | |
729 | fpeflt_ = -1; | |
730 | break; | |
731 | } | |
732 | ||
733 | /* | |
734 | * Find all the registers just in case something better can be done. | |
735 | */ | |
736 | ||
737 | rfp = myfp(); /* contents of fp register */ | |
738 | ap = argp(rfp); /* my arglist pointer */ | |
739 | fp = framep(rfp); /* my frame pointer */ | |
740 | ifp = framep(*rfp); /* user's stored in next frame back */ | |
741 | iap = argp(*rfp); | |
742 | ||
743 | sfp = (struct sigframe *)ap; /* sigframe contains at its bottom the | |
744 | signal handler arguments */ | |
745 | ||
746 | reg0_1 = (struct reg0_1 *)&sfp->r1; | |
747 | reg2_12 = (struct reg2_12 *)((char *)fp - sizeof (struct reg2_12)); | |
748 | ||
749 | ipc = (char **)&sc->sc_pc; | |
750 | isp = (char *)sc + sizeof (struct sigcontext); | |
751 | sc->sc_ps &= ~(PSL_V|PSL_FU); | |
752 | ||
753 | fprintf(ef, "Current PC = %X \n", sc->sc_pc); | |
754 | ||
755 | signal(SIGFPE, on_fpe); | |
756 | sigdie(signo, code, sc); | |
757 | } | |
758 | ||
759 | trpfpe_ (count, rval) | |
760 | long *count; /* how many to announce */ | |
761 | double *rval; /* dummy return value */ | |
762 | { | |
763 | max_messages = *count; | |
764 | retval.rv_double = *rval; | |
765 | sigfpe_dfl = signal(SIGFPE, on_fpe); | |
766 | fpe_count = 0; | |
767 | } | |
768 | ||
769 | long | |
770 | fpecnt_ () | |
771 | { | |
772 | return (fpe_count); | |
799e6b82 DW |
773 | } |
774 | ||
815666cb | 775 | #endif tahoe |