projects / unix-history / blob
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
BSD 4_2 release
[unix-history] / usr / src / usr.lib / libF77 / trapov_.c
/*
char id_trapov[] = "@(#)trapov_.c 1.2";
*
* Fortran/C floating-point overflow handler
*
* The idea of these routines is to catch floating-point overflows
* and print an eror message. When we then get a reserved operand
* exception, we then fix up the value to the highest possible
* number. Keen, no?
* Messy, yes!
*
* Synopsis:
* call trapov(n)
* causes overflows to be trapped, with the first 'n'
* overflows getting an "Overflow!" message printed.
* k = ovcnt(0)
* causes 'k' to get the number of overflows since the
* last call to trapov().
*
* Gary Klimowicz, April 17, 1981
* Integerated with libF77: David Wasley, UCB, July 1981.
*/
# include <stdio.h>
# include <signal.h>
# include "opcodes.h"
# include "../libI77/fiodefs.h"
# define SIG_VAL int (*)()
/*
* Operand modes
*/
# define LITERAL0 0x0
# define LITERAL1 0x1
# define LITERAL2 0x2
# define LITERAL3 0x3
# define INDEXED 0x4
# define REGISTER 0x5
# define REG_DEF 0x6
# define AUTO_DEC 0x7
# define AUTO_INC 0x8
# define AUTO_INC_DEF 0x9
# define BYTE_DISP 0xa
# define BYTE_DISP_DEF 0xb
# define WORD_DISP 0xc
# define WORD_DISP_DEF 0xd
# define LONG_DISP 0xe
# define LONG_DISP_DEF 0xf
/*
* Operand value types
*/
# define F 1
# define D 2
# define IDUNNO 3
# define PC 0xf
# define SP 0xe
# define FP 0xd
# define AP 0xc
/*
* trap type codes
*/
# define INT_OVF_T 1
# define INT_DIV_T 2
# define FLT_OVF_T 3
# define FLT_DIV_T 4
# define FLT_UND_T 5
# define DEC_OVF_T 6
# define SUB_RNG_T 7
# define FLT_OVF_F 8
# define FLT_DIV_F 9
# define FLT_UND_F 10
# define RES_ADR_F 0
# define RES_OPC_F 1
# define RES_OPR_F 2
/*
* Potential operand values
*/
typedef union operand_types {
char o_byte;
short o_word;
long o_long;
float o_float;
long o_quad[2];
double o_double;
} anyval;
/*
* GLOBAL VARIABLES (we need a few)
*
* Actual program counter and locations of registers.
*/
#if vax
static char *pc;
static int *regs0t6;
static int *regs7t11;
static int max_messages;
static int total_overflows;
static union {
long v_long[2];
double v_double;
} retrn;
static int (*sigill_default)() = (SIG_VAL)-1;
static int (*sigfpe_default)();
#endif vax
/*
* the fortran unit control table
*/
extern unit units[];
/*
* Fortran message table is in main
*/
struct msgtbl {
char *mesg;
int dummy;
};
extern struct msgtbl act_fpe[];
anyval *get_operand_address(), *addr_of_reg();
char *opcode_name();
\f
/*
* This routine sets up the signal handler for the floating-point
* and reserved operand interrupts.
*/
trapov_(count, rtnval)
int *count;
double *rtnval;
{
#if vax
extern got_overflow(), got_illegal_instruction();
sigfpe_default = signal(SIGFPE, got_overflow);
if (sigill_default == (SIG_VAL)-1)
sigill_default = signal(SIGILL, got_illegal_instruction);
total_overflows = 0;
max_messages = *count;
retrn.v_double = *rtnval;
}
/*
* got_overflow - routine called when overflow occurs
*
* This routine just prints a message about the overflow.
* It is impossible to find the bad result at this point.
* Instead, we wait until we get the reserved operand exception
* when we try to use it. This raises the SIGILL signal.
*/
/*ARGSUSED*/
got_overflow(signo, codeword, myaddr, pc, ps)
char *myaddr, *pc;
{
int *sp, i;
FILE *ef;
signal(SIGFPE, got_overflow);
ef = units[STDERR].ufd;
switch (codeword) {
case INT_OVF_T:
case INT_DIV_T:
case FLT_UND_T:
case DEC_OVF_T:
case SUB_RNG_T:
case FLT_OVF_F:
case FLT_DIV_F:
case FLT_UND_F:
if (sigfpe_default > (SIG_VAL)7)
return((*sigfpe_default)(signo, codeword, myaddr, pc, ps));
else
sigdie(signo, codeword, myaddr, pc, ps);
/* NOTREACHED */
case FLT_OVF_T:
case FLT_DIV_T:
if (++total_overflows <= max_messages) {
fprintf(ef, "trapov: %s",
act_fpe[codeword-1].mesg);
if (total_overflows == max_messages)
fprintf(ef, ": No more messages will be printed.\n");
else
fputc('\n', ef);
}
return;
}
#endif vax
}
int
ovcnt_()
{
return total_overflows;
}
\f
#if vax
/*
* got_illegal_instruction - handle "illegal instruction" signals.
*
* This really deals only with reserved operand exceptions.
* Since there is no way to check this directly, we look at the
* opcode of the instruction we are executing to see if it is a
* floating-point operation (with floating-point operands, not
* just results).
*
* This is complicated by the fact that the registers that will
* eventually be restored are saved in two places. registers 7-11
* are saved by this routine, and are in its call frame. (we have
* to take special care that these registers are specified in
* the procedure entry mask here.)
* Registers 0-6 are saved at interrupt time, and are at a offset
* -8 from the 'signo' parameter below.
* There is ane extremely inimate connection between the value of
* the entry mask set by the 'makefile' script, and the constants
* used in the register offset calculations below.
* Can someone think of a better way to do this?
*/
/*ARGSUSED*/
got_illegal_instruction(signo, codeword, myaddr, trap_pc, ps)
char *myaddr, *trap_pc;
{
int first_local[1]; /* must be first */
int i, opcode, type, o_no, no_reserved;
anyval *opnd;
regs7t11 = &first_local[0];
regs0t6 = &signo - 8;
pc = trap_pc;
opcode = fetch_byte() & 0xff;
no_reserved = 0;
if (codeword != RES_OPR_F || !is_floating_operation(opcode)) {
if (sigill_default > (SIG_VAL)7)
return((*sigill_default)(signo, codeword, myaddr, trap_pc, ps));
else
sigdie(signo, codeword, myaddr, trap_pc, ps);
/* NOTREACHED */
}
if (opcode == POLYD || opcode == POLYF) {
got_illegal_poly(opcode);
return;
}
if (opcode == EMODD || opcode == EMODF) {
got_illegal_emod(opcode);
return;
}
/*
* This opcode wasn't "unusual".
* Look at the operands to try and find a reserved operand.
*/
for (o_no = 1; o_no <= no_operands(opcode); ++o_no) {
type = operand_type(opcode, o_no);
if (type != F && type != D) {
advance_pc(type);
continue;
}
/* F or D operand. Check it out */
opnd = get_operand_address(type);
if (opnd == NULL) {
fprintf(units[STDERR].ufd, "Can't get operand address: 0x%x, %d\n",
pc, o_no);
force_abort();
}
if (type == F && opnd->o_long == 0x00008000) {
/* found one */
opnd->o_long = retrn.v_long[0];
++no_reserved;
} else if (type == D && opnd->o_long == 0x00008000) {
/* found one here, too! */
opnd->o_quad[0] = retrn.v_long[0];
/* Fix next pointer */
if (opnd == addr_of_reg(6)) opnd = addr_of_reg(7);
else opnd = (anyval *) ((char *) opnd + 4);
opnd->o_quad[0] = retrn.v_long[1];
++no_reserved;
}
}
if (no_reserved == 0) {
fprintf(units[STDERR].ufd, "Can't find any reserved operand!\n");
force_abort();
}
}
\f/*
* is_floating_exception - was the operation code for a floating instruction?
*/
is_floating_operation(opcode)
int opcode;
{
switch (opcode) {
case ACBD: case ACBF: case ADDD2: case ADDD3:
case ADDF2: case ADDF3: case CMPD: case CMPF:
case CVTDB: case CVTDF: case CVTDL: case CVTDW:
case CVTFB: case CVTFD: case CVTFL: case CVTFW:
case CVTRDL: case CVTRFL: case DIVD2: case DIVD3:
case DIVF2: case DIVF3: case EMODD: case EMODF:
case MNEGD: case MNEGF: case MOVD: case MOVF:
case MULD2: case MULD3: case MULF2: case MULF3:
case POLYD: case POLYF: case SUBD2: case SUBD3:
case SUBF2: case SUBF3: case TSTD: case TSTF:
return 1;
default:
return 0;
}
}
\f/*
* got_illegal_poly - handle an illegal POLY[DF] instruction.
*
* We don't do anything here yet.
*/
/*ARGSUSED*/
got_illegal_poly(opcode)
{
fprintf(units[STDERR].ufd, "Can't do 'poly' instructions yet\n");
force_abort();
}
/*
* got_illegal_emod - handle illegal EMOD[DF] instruction.
*
* We don't do anything here yet.
*/
/*ARGSUSED*/
got_illegal_emod(opcode)
{
fprintf(units[STDERR].ufd, "Can't do 'emod' instructions yet\n");
force_abort();
}
/*
* no_operands - determine the number of operands in this instruction.
*
*/
no_operands(opcode)
{
switch (opcode) {
case ACBD:
case ACBF:
return 3;
case MNEGD:
case MNEGF:
case MOVD:
case MOVF:
case TSTD:
case TSTF:
return 1;
default:
return 2;
}
}
/*
* operand_type - is the operand a D or an F?
*
* We are only descriminating between Floats and Doubles here.
* Other operands may be possible on exotic instructions.
*/
/*ARGSUSED*/
operand_type(opcode, no)
{
if (opcode >= 0x40 && opcode <= 0x56) return F;
if (opcode >= 0x60 && opcode <= 0x76) return D;
return IDUNNO;
}
/*
* advance_pc - Advance the program counter past an operand.
*
* We just bump the pc by the appropriate values.
*/
advance_pc(type)
{
register int mode, reg;
mode = fetch_byte();
reg = mode & 0xf;
mode = (mode >> 4) & 0xf;
switch (mode) {
case LITERAL0:
case LITERAL1:
case LITERAL2:
case LITERAL3:
return;
case INDEXED:
advance_pc(type);
return;
case REGISTER:
case REG_DEF:
case AUTO_DEC:
return;
case AUTO_INC:
if (reg == PC) {
if (type == F) (void) fetch_long();
else if (type == D) {
(void) fetch_long();
(void) fetch_long();
} else {
fprintf(units[STDERR].ufd, "Bad type %d in advance\n",
type);
force_abort();
}
}
return;
case AUTO_INC_DEF:
if (reg == PC) (void) fetch_long();
return;
case BYTE_DISP:
case BYTE_DISP_DEF:
(void) fetch_byte();
return;
case WORD_DISP:
case WORD_DISP_DEF:
(void) fetch_word();
return;
case LONG_DISP:
case LONG_DISP_DEF:
(void) fetch_long();
return;
default:
fprintf(units[STDERR].ufd, "Bad mode 0x%x in op_length()\n", mode);
force_abort();
}
}
anyval *
get_operand_address(type)
{
register int mode, reg, base;
mode = fetch_byte() & 0xff;
reg = mode & 0xf;
mode = (mode >> 4) & 0xf;
switch (mode) {
case LITERAL0:
case LITERAL1:
case LITERAL2:
case LITERAL3:
return NULL;
case INDEXED:
base = (int) get_operand_address(type);
if (base == NULL) return NULL;
base += contents_of_reg(reg)*type_length(type);
return (anyval *) base;
case REGISTER:
return addr_of_reg(reg);
case REG_DEF:
return (anyval *) contents_of_reg(reg);
case AUTO_DEC:
return (anyval *) (contents_of_reg(reg)
- type_length(type));
case AUTO_INC:
return (anyval *) contents_of_reg(reg);
case AUTO_INC_DEF:
return (anyval *) * (long *) contents_of_reg(reg);
case BYTE_DISP:
base = fetch_byte();
base += contents_of_reg(reg);
return (anyval *) base;
case BYTE_DISP_DEF:
base = fetch_byte();
base += contents_of_reg(reg);
return (anyval *) * (long *) base;
case WORD_DISP:
base = fetch_word();
base += contents_of_reg(reg);
return (anyval *) base;
case WORD_DISP_DEF:
base = fetch_word();
base += contents_of_reg(reg);
return (anyval *) * (long *) base;
case LONG_DISP:
base = fetch_long();
base += contents_of_reg(reg);
return (anyval *) base;
case LONG_DISP_DEF:
base = fetch_long();
base += contents_of_reg(reg);
return (anyval *) * (long *) base;
default:
fprintf(units[STDERR].ufd, "Bad mode 0x%x in get_addr()\n", mode);
force_abort();
}
return NULL;
}
contents_of_reg(reg)
{
int value;
if (reg == PC) value = (int) pc;
else if (reg == SP) value = (int) &regs0t6[6];
else if (reg == FP) value = regs0t6[-2];
else if (reg == AP) value = regs0t6[-3];
else if (reg >= 0 && reg <= 6) value = regs0t6[reg];
else if (reg >= 7 && reg <= 11) value = regs7t11[reg];
else {
fprintf(units[STDERR].ufd, "Bad register 0x%x to contents_of()\n", reg);
force_abort();
value = -1;
}
return value;
}
anyval *
addr_of_reg(reg)
{
if (reg >= 0 && reg <= 6) {
return (anyval *) &regs0t6[reg];
}
if (reg >= 7 && reg <= 11) {
return (anyval *) &regs7t11[reg];
}
fprintf(units[STDERR].ufd, "Bad reg 0x%x to addr_of()\n", reg);
force_abort();
return NULL;
}
\f/*
* fetch_{byte, word, long} - extract values from the PROGRAM area.
*
* These routines are used in the operand decoding to extract various
* fields from where the program counter points. This is because the
* addressing on the Vax is dynamic: the program counter advances
* while we are grabbing operands, as well as when we pass instructions.
* This makes things a bit messy, but I can't help it.
*/
fetch_byte()
{
return *pc++;
}
fetch_word()
{
int *old_pc;
old_pc = (int *) pc;
pc += 2;
return *old_pc;
}
fetch_long()
{
long *old_pc;
old_pc = (long *) pc;
pc += 4;
return *old_pc;
}
\f/*
* force_abort - force us to abort.
*
* We have to change the signal handler for illegal instructions back,
* or we'll end up calling 'got_illegal_instruction()' again when
* abort() does it's dirty work.
*/
force_abort()
{
signal(SIGILL, SIG_DFL);
abort();
}
type_length(type)
{
if (type == F) return 4;
if (type == D) return 8;
fprintf(units[STDERR].ufd, "Bad type 0x%x in type_length()\n", type);
force_abort();
return -1;
}
char *opcode_name(opcode)
{
switch (opcode) {
case ACBD: return "ACBD";
case ACBF: return "ACBF";
case ADDD2: return "ADDD2";
case ADDD3: return "ADDD3";
case ADDF2: return "ADDF2";
case ADDF3: return "ADDF3";
case CMPD: return "CMPD";
case CMPF: return "CMPF";
case CVTDB: return "CVTDB";
case CVTDF: return "CVTDF";
case CVTDL: return "CVTDL";
case CVTDW: return "CVTDW";
case CVTFB: return "CVTFB";
case CVTFD: return "CVTFD";
case CVTFL: return "CVTFL";
case CVTFW: return "CVTFW";
case CVTRDL: return "CVTRDL";
case CVTRFL: return "CVTRFL";
case DIVD2: return "DIVD2";
case DIVD3: return "DIVD3";
case DIVF2: return "DIVF2";
case DIVF3: return "DIVF3";
case EMODD: return "EMODD";
case EMODF: return "EMODF";
case MNEGD: return "MNEGD";
case MNEGF: return "MNEGF";
case MOVD: return "MOVD";
case MOVF: return "MOVF";
case MULD2: return "MULD2";
case MULD3: return "MULD3";
case MULF2: return "MULF2";
case MULF3: return "MULF3";
case POLYD: return "POLYD";
case POLYF: return "POLYF";
case SUBD2: return "SUBD2";
case SUBD3: return "SUBD3";
case SUBF2: return "SUBF2";
case SUBF3: return "SUBF3";
case TSTD: return "TSTD";
case TSTF: return "TSTF";
}
}
#endif vax
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.