/* #define OLD_BSD if you're running < 4.2 bsd */
* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
* Fortran floating-point error handler
* call trpfpe (n, retval)
* causes floating point faults to be trapped, with the
* first 'n' errors getting a message printed.
* 'retval' is put in place of the bad result.
* causes 'k' to get the number of errors since the
* fpflag will become .true. on faults
* David Wasley, UCBerkeley, June 1983.
#include "../libI77/fiodefs.h"
#define SIG_VAL int (*)()
#if vax /* only works on VAXen */
struct arglist
{ /* what AP points to */
long al_numarg
; /* only true in CALLS format */
struct cframe
{ /* VAX call frame */
* where the registers are stored as we see them in the handler
#define iR0 reg0_6->reg[0]
#define iR1 reg0_6->reg[1]
#define iR2 reg0_6->reg[2]
#define iR3 reg0_6->reg[3]
#define iR4 reg0_6->reg[4]
#define iR5 reg0_6->reg[5]
#define iR6 reg0_6->reg[6]
#define iR7 reg7_11->reg[0]
#define iR8 reg7_11->reg[1]
#define iR9 reg7_11->reg[2]
#define iR10 reg7_11->reg[3]
#define iR11 reg7_11->reg[4]
union objects
{ /* for load/store */
union objects
*ua_anything
;
typedef union objects anything
;
enum object_type
{ BYTE
, WORD
, LONG
, FLOAT
, QUAD
, DOUBLE
, UNKNOWN
};
* assembly language assist
* There are some things you just can't do in C
asm("extzv $30,$2,4(fp),r0");
asm("addl2 ap,r0"); /* SP in caller is AP+4 here + SPA bits! */
* Where interrupted objects are
static struct cframe
**ifp
; /* addr of saved FP */
static struct arglist
**iap
; /* addr of saved AP */
static char *isp
; /* value of interrupted SP */
static char **ipc
; /* addr of saved PC */
static struct reg0_6
*reg0_6
;/* registers 0-6 are saved on the exception */
static struct reg7_11
*reg7_11
;/* we save 7-11 by our entry mask */
static anything
*result_addr
; /* where the dummy result goes */
static enum object_type result_type
; /* what kind of object it is */
} retval
; /* the user specified dummy result */
static int max_messages
= 1; /* the user can tell us */
static int fpe_count
= 0; /* how bad is it ? */
long fpeflt_
= 0; /* fortran "common /fpeflt/ flag" */
static int (*sigfpe_dfl
)() = SIG_DFL
; /* if we can't fix it ... */
* The fortran unit control table
* Fortran message table is in main
extern struct msgtbl act_fpe
[];
* Get the address of the (saved) next operand & update saved PC.
* The major purpose of this is to determine where to store the result.
* There is one case we can't deal with: -(SP) or (SP)+
* since we can't change the size of the stack.
* Let's just hope compilers don't generate that for results.
int oper_size
; /* size of operand we expect */
register int operand_code
;
operand_code
= (*(*ipc
)++ & 0xff);
operand_code
= (*(*ipc
)++ & 0xf0);
reg_addr
= (anything
*)®0_6
->reg
[regnum
];
reg_addr
= (anything
*)®7_11
->reg
[regnum
];
reg_addr
= (anything
*)iap
;
reg_addr
= (anything
*)ifp
;
reg_addr
= (anything
*)&isp
; /* We saved this ourselves */
reg_addr
= (anything
*)ipc
;
oper_addr
= (anything
*)(*ipc
);
oper_addr
= (anything
*)(**ipc
);
*ipc
+= sizeof (anything
*);
/* we don't care about the address of these */
index
= reg_addr
->ua_long
* oper_size
;
oper_addr
= (anything
*)(get_operand(sizeof (long))->ua_long
+ index
);
return(reg_addr
->ua_anything
);
fprintf(stderr
, "trp: can't fix -(SP) operand\n");
reg_addr
->ua_long
-= oper_size
;
oper_addr
= reg_addr
->ua_anything
;
fprintf(stderr
, "trp: can't fix (SP)+ operand\n");
oper_addr
= reg_addr
->ua_anything
;
reg_addr
->ua_long
+= oper_size
;
fprintf(stderr
, "trp: can't fix @(SP)+ operand\n");
oper_addr
= (reg_addr
->ua_anything
)->ua_anything
;
reg_addr
->ua_long
+= sizeof (anything
*);
index
= ((anything
*)(*ipc
))->ua_byte
;
*ipc
+= sizeof (char); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
index
= ((anything
*)(*ipc
))->ua_byte
;
*ipc
+= sizeof (char); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
oper_addr
= oper_addr
->ua_anything
;
index
= ((anything
*)(*ipc
))->ua_word
;
*ipc
+= sizeof (short); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
index
= ((anything
*)(*ipc
))->ua_word
;
*ipc
+= sizeof (short); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
oper_addr
= oper_addr
->ua_anything
;
index
= ((anything
*)(*ipc
))->ua_long
;
*ipc
+= sizeof (long); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
index
= ((anything
*)(*ipc
))->ua_long
;
*ipc
+= sizeof (long); /* do it now in case reg==PC */
oper_addr
= (anything
*)(index
+ reg_addr
->ua_long
);
oper_addr
= oper_addr
->ua_anything
;
* Trap & repair floating exceptions so that a program may proceed.
* There is no notion of "correctness" here; just the ability to continue.
* The on_fpe() routine first checks the type code to see if the
* exception is repairable. If so, it checks the opcode to see if
* it is one that it knows. If this is true, it then simulates the
* VAX cpu in retrieving operands in order to increment iPC correctly.
* It notes where the result of the operation would have been stored
* and substitutes a previously supplied value.
on_fpe(signo
, code
, myaddr
, pc
, ps
)
on_fpe(signo
, code
, sc
, grbg
)
* There must be at least 5 register variables here
* so our entry mask will save R11-R7.
register struct arglist
*ap
;
register struct cframe
*fp
;
ef
= units
[STDERR
].ufd
; /* fortran error stream */
case FPE_INTOVF_TRAP
: /* integer overflow */
case FPE_INTDIV_TRAP
: /* integer divide by zero */
case FPE_FLTOVF_TRAP
: /* floating overflow */
case FPE_FLTDIV_TRAP
: /* floating/decimal divide by zero */
case FPE_FLTUND_TRAP
: /* floating underflow */
case FPE_DECOVF_TRAP
: /* decimal overflow */
case FPE_SUBRNG_TRAP
: /* subscript out of range */
if (sigfpe_dfl
> (SIG_VAL
)7) /* user specified */
return((*sigfpe_dfl
)(signo
, code
, myaddr
, pc
, ps
));
return((*sigfpe_dfl
)(signo
, code
, sc
, grbg
));
sigdie(signo
, code
, myaddr
, pc
, ps
);
sigdie(signo
, code
, sc
, grbg
);
case FPE_FLTOVF_FAULT
: /* floating overflow fault */
case FPE_FLTDIV_FAULT
: /* divide by zero floating fault */
case FPE_FLTUND_FAULT
: /* floating underflow fault */
if (++fpe_count
<= max_messages
) {
fprintf(ef
, "trpfpe: %s",
if (fpe_count
== max_messages
)
fprintf(ef
, ": No more messages will be printed.\n");
ap
= myap(); /* my arglist pointer */
fp
= myfp(); /* my frame pointer */
ifp
= &(fp
->cf_fp
)->cf_fp
; /* user's stored in next frame back */
iap
= &(fp
->cf_fp
)->cf_ap
;
* these are likely to be system dependent
reg0_6
= (struct reg0_6
*)((char *)fp
->cf_fp
+ sizeof (struct cframe
));
reg7_11
= (struct reg7_11
*)((char *)fp
->cf_fp
- sizeof (struct reg7_11
));
isp
= (char *)&ap
->al_arg
[ap
->al_numarg
+ 2]; /* assumes 2 dummys */
ipc
= (char **)&sc
->sc_pc
;
isp
= (char *)sc
+ sizeof (struct sigcontext
);
sc
->sc_ps
&= ~(PSW_V
|PSW_FU
);
(void) get_operand(sizeof (double));
/* intentional fall-thru */
(void) get_operand(sizeof (double));
result_addr
= get_operand(sizeof (double));
(void) get_operand(sizeof (float));
/* intentional fall-thru */
(void) get_operand(sizeof (float));
result_addr
= get_operand(sizeof (float));
(void) get_operand(sizeof (double));
result_addr
= get_operand(sizeof (float));
(void) get_operand(sizeof (float));
result_addr
= get_operand(sizeof (double));
fprintf(ef
, "trpfpe: can't fix emod yet\n");
fprintf(ef
, "trpfpe: can't fix poly yet\n");
/* These can generate only reserved operand faults */
/* They are shown here for completeness */
fprintf(stderr
, "trp: opcode 0x%02x unknown\n",
if (result_type
== FLOAT
)
result_addr
->ua_float
= retval
.rv_float
;
if (result_addr
== (anything
*)&iR6
)
* special case - the R6/R7 pair is stored apart
result_addr
->ua_long
= retval
.rv_long
[0];
((anything
*)&iR7
)->ua_long
= retval
.rv_long
[1];
result_addr
->ua_double
= retval
.rv_double
;
long *count
; /* how many to announce */
double *rval
; /* dummy return value */
retval
.rv_double
= *rval
;
sigfpe_dfl
= signal(SIGFPE
, on_fpe
);