![[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] / 43BSD / usr.lib / libF77|
Return to trpfpe_.c CVS log | Up to [CSRG BSD Unix] / 43BSD / usr.lib / libF77 |
1.1 ! root 1: /* #define OLD_BSD if you're running < 4.2 bsd */ ! 2: /* ! 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: * ! 7: * @(#)trpfpe_.c 5.3 7/8/85 ! 8: * ! 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> ! 30: #include <signal.h> ! 31: #include "opcodes.h" ! 32: #include "operand.h" ! 33: #include "../libI77/fiodefs.h" ! 34: ! 35: #define SIG_VAL int (*)() ! 36: ! 37: #if vax /* only works on VAXen */ ! 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: ! 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: ! 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: ! 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: ! 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); ! 270: return(oper_addr); ! 271: ! 272: case BYTEDISPDEF: ! 273: case BYTERELDEF: ! 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); ! 277: oper_addr = oper_addr->ua_anything; ! 278: return(oper_addr); ! 279: ! 280: case WORDDISP: ! 281: case WORDREL: ! 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); ! 285: return(oper_addr); ! 286: ! 287: case WORDDISPDEF: ! 288: case WORDRELDEF: ! 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); ! 292: oper_addr = oper_addr->ua_anything; ! 293: return(oper_addr); ! 294: ! 295: case LONGDISP: ! 296: case LONGREL: ! 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); ! 300: return(oper_addr); ! 301: ! 302: case LONGDISPDEF: ! 303: case LONGRELDEF: ! 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); ! 307: oper_addr = oper_addr->ua_anything; ! 308: return(oper_addr); ! 309: ! 310: /* NOTREACHED */ ! 311: } ! 312: } ! 313: ! 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 ! 331: on_fpe(signo, code, sc, grbg) ! 332: int signo, code; ! 333: struct sigcontext *sc; ! 334: #endif ! 335: { ! 336: /* ! 337: * There must be at least 5 register variables here ! 338: * so our entry mask will save R11-R7. ! 339: */ ! 340: register long *stk; ! 341: register long *sp; ! 342: register struct arglist *ap; ! 343: register struct cframe *fp; ! 344: register FILE *ef; ! 345: ! 346: ef = units[STDERR].ufd; /* fortran error stream */ ! 347: ! 348: switch (code) ! 349: { ! 350: case FPE_INTOVF_TRAP: /* integer overflow */ ! 351: case FPE_INTDIV_TRAP: /* integer divide by zero */ ! 352: case FPE_FLTOVF_TRAP: /* floating overflow */ ! 353: case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */ ! 354: case FPE_FLTUND_TRAP: /* floating underflow */ ! 355: case FPE_DECOVF_TRAP: /* decimal overflow */ ! 356: case FPE_SUBRNG_TRAP: /* subscript out of range */ ! 357: default: ! 358: cant_fix: ! 359: if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ ! 360: #ifdef OLD_BSD ! 361: return((*sigfpe_dfl)(signo, code, myaddr, pc, ps)); ! 362: #else ! 363: return((*sigfpe_dfl)(signo, code, sc, grbg)); ! 364: #endif ! 365: else ! 366: #ifdef OLD_BSD ! 367: sigdie(signo, code, myaddr, pc, ps); ! 368: #else ! 369: sigdie(signo, code, sc, grbg); ! 370: #endif ! 371: /* NOTREACHED */ ! 372: ! 373: case FPE_FLTOVF_FAULT: /* floating overflow fault */ ! 374: case FPE_FLTDIV_FAULT: /* divide by zero floating fault */ ! 375: case FPE_FLTUND_FAULT: /* floating underflow fault */ ! 376: if (++fpe_count <= max_messages) { ! 377: fprintf(ef, "trpfpe: %s", ! 378: act_fpe[code-1].mesg); ! 379: if (fpe_count == max_messages) ! 380: fprintf(ef, ": No more messages will be printed.\n"); ! 381: else ! 382: fputc('\n', ef); ! 383: } ! 384: fpeflt_ = -1; ! 385: break; ! 386: } ! 387: ! 388: ap = myap(); /* my arglist pointer */ ! 389: fp = myfp(); /* my frame pointer */ ! 390: ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */ ! 391: iap = &(fp->cf_fp)->cf_ap; ! 392: /* ! 393: * these are likely to be system dependent ! 394: */ ! 395: reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe)); ! 396: reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11)); ! 397: ! 398: #ifdef OLD_BSD ! 399: ipc = &pc; ! 400: isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */ ! 401: ps &= ~(PSW_V|PSW_FU); ! 402: #else ! 403: ipc = (char **)&sc->sc_pc; ! 404: isp = (char *)sc + sizeof (struct sigcontext); ! 405: sc->sc_ps &= ~(PSW_V|PSW_FU); ! 406: #endif ! 407: ! 408: ! 409: switch (*(*ipc)++) ! 410: { ! 411: case ADDD3: ! 412: case DIVD3: ! 413: case MULD3: ! 414: case SUBD3: ! 415: (void) get_operand(sizeof (double)); ! 416: /* intentional fall-thru */ ! 417: ! 418: case ADDD2: ! 419: case DIVD2: ! 420: case MULD2: ! 421: case SUBD2: ! 422: case MNEGD: ! 423: case MOVD: ! 424: (void) get_operand(sizeof (double)); ! 425: result_addr = get_operand(sizeof (double)); ! 426: result_type = DOUBLE; ! 427: break; ! 428: ! 429: case ADDF3: ! 430: case DIVF3: ! 431: case MULF3: ! 432: case SUBF3: ! 433: (void) get_operand(sizeof (float)); ! 434: /* intentional fall-thru */ ! 435: ! 436: case ADDF2: ! 437: case DIVF2: ! 438: case MULF2: ! 439: case SUBF2: ! 440: case MNEGF: ! 441: case MOVF: ! 442: (void) get_operand(sizeof (float)); ! 443: result_addr = get_operand(sizeof (float)); ! 444: result_type = FLOAT; ! 445: break; ! 446: ! 447: case CVTDF: ! 448: (void) get_operand(sizeof (double)); ! 449: result_addr = get_operand(sizeof (float)); ! 450: result_type = FLOAT; ! 451: break; ! 452: ! 453: case CVTFD: ! 454: (void) get_operand(sizeof (float)); ! 455: result_addr = get_operand(sizeof (double)); ! 456: result_type = DOUBLE; ! 457: break; ! 458: ! 459: case EMODF: ! 460: case EMODD: ! 461: fprintf(ef, "trpfpe: can't fix emod yet\n"); ! 462: goto cant_fix; ! 463: ! 464: case POLYF: ! 465: case POLYD: ! 466: fprintf(ef, "trpfpe: can't fix poly yet\n"); ! 467: goto cant_fix; ! 468: ! 469: case ACBD: ! 470: case ACBF: ! 471: case CMPD: ! 472: case CMPF: ! 473: case TSTD: ! 474: case TSTF: ! 475: case CVTDB: ! 476: case CVTDL: ! 477: case CVTDW: ! 478: case CVTFB: ! 479: case CVTFL: ! 480: case CVTFW: ! 481: case CVTRDL: ! 482: case CVTRFL: ! 483: /* These can generate only reserved operand faults */ ! 484: /* They are shown here for completeness */ ! 485: ! 486: default: ! 487: fprintf(stderr, "trp: opcode 0x%02x unknown\n", ! 488: *(--(*ipc)) & 0xff); ! 489: goto cant_fix; ! 490: /* NOTREACHED */ ! 491: } ! 492: ! 493: if (result_type == FLOAT) ! 494: result_addr->ua_float = retval.rv_float; ! 495: else ! 496: { ! 497: if (result_addr == (anything *)&iR6) ! 498: { /* ! 499: * special case - the R6/R7 pair is stored apart ! 500: */ ! 501: result_addr->ua_long = retval.rv_long[0]; ! 502: ((anything *)&iR7)->ua_long = retval.rv_long[1]; ! 503: } ! 504: else ! 505: result_addr->ua_double = retval.rv_double; ! 506: } ! 507: signal(SIGFPE, on_fpe); ! 508: } ! 509: #endif vax ! 510: ! 511: trpfpe_ (count, rval) ! 512: long *count; /* how many to announce */ ! 513: double *rval; /* dummy return value */ ! 514: { ! 515: #if vax ! 516: max_messages = *count; ! 517: retval.rv_double = *rval; ! 518: sigfpe_dfl = signal(SIGFPE, on_fpe); ! 519: fpe_count = 0; ! 520: #endif ! 521: } ! 522: ! 523: long ! 524: fpecnt_ () ! 525: { ! 526: #if vax ! 527: return (fpe_count); ! 528: #else ! 529: return (0L); ! 530: #endif ! 531: } ! 532:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.