Annotation of 43BSDReno/lib/libF77/trpfpe_.c, revision 1.1.1.1

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.6     2/14/90
                      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 <sys/signal.h>
                     31: #include "../libI77/fiodefs.h"
                     32: 
                     33: #define        SIG_VAL         void (*)()
                     34: 
                     35: #ifdef vax
                     36: #include "opcodes.h"
                     37: #include "operand.h"
                     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 sig_t   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 *)&reg0_6->reg[regnum];
                    193:        else if (regnum <= R11)
                    194:                reg_addr = (anything *)&reg7_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: void
                    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
                    362:                                (*sigfpe_dfl)(signo, code, myaddr, pc, ps);
                    363: #else
                    364:                                (*sigfpe_dfl)(signo, code, sc, grbg);
                    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;
                    405:        isp = (char *)sc + sizeof (struct sigcontext);
                    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: }
                    510: 
                    511: trpfpe_ (count, rval)
                    512:        long    *count; /* how many to announce */
                    513:        double  *rval;  /* dummy return value */
                    514: {
                    515:        max_messages = *count;
                    516:        retval.rv_double = *rval;
                    517:        sigfpe_dfl = signal(SIGFPE, on_fpe);
                    518:        fpe_count = 0;
                    519: }
                    520: 
                    521: long
                    522: fpecnt_ ()
                    523: {
                    524:        return (fpe_count);
                    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: 
                    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: 
                    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" */
                    649: static sig_t sigfpe_dfl                = SIG_DFL;      /* if we can't fix it ... */
                    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: 
                    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: 
                    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:  */
                    688: void
                    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 */
                    719:                                (*sigfpe_dfl)(signo, code, sc);
                    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);
                    773: }
                    774: 
                    775: #endif tahoe

unix.superglobalmegacorp.com

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.