![[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.