[unix-history] / usr / src / usr.bin / f77 / libF77 / trpfpe_.c

/* #define	OLD_BSD		if you're running < 4.2bsd */
/*
char	id_trpfpe[] = "@(#)trpfpe_.c	1.1";
 *
 *	Fortran floating-point error handler
 *
 *	Synopsis:
 *		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.
 *		k = fpecnt()
 *			causes 'k' to get the number of errors since the
 *			last call to trpfpe().
 *
 *		common /fpeflt/ fpflag
 *		logical fpflag
 *			fpflag will become .true. on faults
 *
 *	David Wasley, UCBerkeley, June 1983.
 */


#include <stdio.h>
#include <signal.h>
#include "opcodes.h"
#include "operand.h"
#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 */
	long	al_arg[256];
};

struct cframe {			/* VAX call frame */
	long		cf_handler;
	unsigned short	cf_psw;
	unsigned short	cf_mask;
	struct arglist	*cf_ap;
	struct cframe	*cf_fp;
	char		*cf_pc;
};

/*
 * bits in the PSW
 */
#define	PSW_V	0x2
#define	PSW_FU	0x40
#define	PSW_IV	0x20

/*
 * where the registers are stored as we see them in the handler
 */
struct reg0_6 {
	long	reg[7];
};

struct reg7_11 {
	long	reg[5];
};

#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 */
	char	ua_byte;
	short	ua_word;
	long	ua_long;
	float	ua_float;
	double	ua_double;
	union objects	*ua_anything;
};

typedef union objects	anything;
enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN };

\f
/*
 * assembly language assist
 * There are some things you just can't do in C
 */
asm(".text");

struct cframe	*myfp();
asm("_myfp: .word 0x0");
	asm("movl 12(fp),r0");
	asm("ret");

struct arglist	*myap();
asm("_myap: .word 0x0");
	asm("movl 8(fp),r0");
	asm("ret");

char	*mysp();
asm("_mysp: .word 0x0");
	asm("extzv $30,$2,4(fp),r0");
	asm("addl2 ap,r0");	/* SP in caller is AP+4 here + SPA bits! */
	asm("addl2 $4,r0");
	asm("ret");

char	*mypc();
asm("_mypc: .word 0x0");
	asm("movl 16(fp),r0");
	asm("ret");

asm(".data");

\f
/*
 * 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 */

/*
 * some globals
 */
static union {
	long	rv_long[2];
	float	rv_float;
	double	rv_double;
			} 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
 */
extern unit units[];

/*
 * Fortran message table is in main
 */
struct msgtbl {
	char	*mesg;
	int	dummy;
};
extern struct msgtbl	act_fpe[];

\f
/*
 * 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.
 */

anything *
get_operand (oper_size)
	int	oper_size;	/* size of operand we expect */
{
	register int	regnum;
	register int	operand_code;
	int		index;
	anything	*oper_addr;
	anything	*reg_addr;

	regnum = (**ipc & 0xf);
	if (regnum == PC)
		operand_code = (*(*ipc)++ & 0xff);
	else
		operand_code = (*(*ipc)++ & 0xf0);
	if (regnum <= R6)
		reg_addr = (anything *)&reg0_6->reg[regnum];
	else if (regnum <= R11)
		reg_addr = (anything *)&reg7_11->reg[regnum];
	else if (regnum == AP)
		reg_addr = (anything *)iap;
	else if (regnum == FP)
		reg_addr = (anything *)ifp;
	else if (regnum == SP)
		reg_addr = (anything *)&isp;	/* We saved this ourselves */
	else if (regnum == PC)
		reg_addr = (anything *)ipc;


	switch (operand_code)
	{
		case IMMEDIATE:
			oper_addr = (anything *)(*ipc);
			*ipc += oper_size;
			return(oper_addr);

		case ABSOLUTE:
			oper_addr = (anything *)(**ipc);
			*ipc += sizeof (anything *);
			return(oper_addr);

		case LITERAL0:
		case LITERAL1:
		case LITERAL2:
		case LITERAL3:
			/* we don't care about the address of these */
			return((anything *)0);

		case INDEXED:
			index = reg_addr->ua_long * oper_size;
			oper_addr = (anything *)(get_operand(sizeof (long))->ua_long + index);
			return(oper_addr);

		case REGISTER:
			return(reg_addr);

		case REGDEFERED:
			return(reg_addr->ua_anything);

		case AUTODEC:
			if (regnum == SP)
			{
				fprintf(stderr, "trp: can't fix -(SP) operand\n");
				exit(1);
			}
			reg_addr->ua_long -= oper_size;
			oper_addr = reg_addr->ua_anything;
			return(oper_addr);

		case AUTOINC:
			if (regnum == SP)
			{
				fprintf(stderr, "trp: can't fix (SP)+ operand\n");
				exit(1);
			}
			oper_addr = reg_addr->ua_anything;
			reg_addr->ua_long += oper_size;
			return(oper_addr);

		case AUTOINCDEF:
			if (regnum == SP)
			{
				fprintf(stderr, "trp: can't fix @(SP)+ operand\n");
				exit(1);
			}
			oper_addr = (reg_addr->ua_anything)->ua_anything;
			reg_addr->ua_long += sizeof (anything *);
			return(oper_addr);

		case BYTEDISP:
		case BYTEREL:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_byte + reg_addr->ua_long);
			*ipc += sizeof (char);
			return(oper_addr);

		case BYTEDISPDEF:
		case BYTERELDEF:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_byte + reg_addr->ua_long);
			oper_addr = oper_addr->ua_anything;
			*ipc += sizeof (char);
			return(oper_addr);

		case WORDDISP:
		case WORDREL:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_word + reg_addr->ua_long);
			*ipc += sizeof (short);
			return(oper_addr);

		case WORDDISPDEF:
		case WORDRELDEF:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_word + reg_addr->ua_long);
			oper_addr = oper_addr->ua_anything;
			*ipc += sizeof (short);
			return(oper_addr);

		case LONGDISP:
		case LONGREL:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_long + reg_addr->ua_long);
			*ipc += sizeof (long);
			return(oper_addr);

		case LONGDISPDEF:
		case LONGRELDEF:
			oper_addr = (anything *)(((anything *)(*ipc))->ua_long + reg_addr->ua_long);
			oper_addr = oper_addr->ua_anything;
			*ipc += sizeof (long);
			return(oper_addr);

		/* NOTREACHED */
	}
}
\f
/*
 * 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.
 */

#ifdef	OLD_BSD
on_fpe(signo, code, myaddr, pc, ps)
	int signo, code, ps;
	char *myaddr, *pc;
#else
on_fpe(signo, code, sc, grbg)
	int signo, code;
	struct sigcontext *sc;
#endif
{
	/*
	 * There must be at least 5 register variables here
	 * so our entry mask will save R11-R7.
	 */
	register long	*stk;
	register long	*sp;
	register struct arglist	*ap;
	register struct cframe	*fp;
	register FILE	*ef;

	ef = units[STDERR].ufd;		/* fortran error stream */

	switch (code)
	{
		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 */
		default:
cant_fix:
			if (sigfpe_dfl > (SIG_VAL)7)	/* user specified */
#ifdef	OLD_BSD
				return((*sigfpe_dfl)(signo, code, myaddr, pc, ps));
#else
				return((*sigfpe_dfl)(signo, code, sc, grbg));
#endif
			else
#ifdef	OLD_BSD
				sigdie(signo, code, myaddr, pc, ps);
#else
				sigdie(signo, code, sc, grbg);
#endif
			/* NOTREACHED */

		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",
					act_fpe[code-1].mesg);
				if (fpe_count == max_messages)
					fprintf(ef, ": No more messages will be printed.\n");
				else
					fputc('\n', ef);
			}
			fpeflt_ = -1;
			break;
	}

	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));

#ifdef	OLD_BSD
	ipc = &pc;
	isp = (char *)&ap->al_arg[ap->al_numarg + 2];	/* assumes 2 dummys */
	ps &= ~(PSW_V|PSW_FU);
#else
	ipc = (char **)&sc->sc_pc;
	isp = (char *)&ap->al_arg[ap->al_numarg] + sizeof (struct sigcontext);
	sc->sc_ps &= ~(PSW_V|PSW_FU);
#endif


	switch (*(*ipc)++)
	{
		case ADDD3:
		case DIVD3:
		case MULD3:
		case SUBD3:
			(void) get_operand(sizeof (double));
			/* intentional fall-thru */

		case ADDD2:
		case DIVD2:
		case MULD2:
		case SUBD2:
		case MNEGD:
		case MOVD:
			(void) get_operand(sizeof (double));
			result_addr = get_operand(sizeof (double));
			result_type = DOUBLE;
			break;

		case ADDF3:
		case DIVF3:
		case MULF3:
		case SUBF3:
			(void) get_operand(sizeof (float));
			/* intentional fall-thru */

		case ADDF2:
		case DIVF2:
		case MULF2:
		case SUBF2:
		case MNEGF:
		case MOVF:
			(void) get_operand(sizeof (float));
			result_addr = get_operand(sizeof (float));
			result_type = FLOAT;
			break;

		case CVTDF:
			(void) get_operand(sizeof (double));
			result_addr = get_operand(sizeof (float));
			result_type = FLOAT;
			break;

		case CVTFD:
			(void) get_operand(sizeof (float));
			result_addr = get_operand(sizeof (double));
			result_type = DOUBLE;
			break;

		case EMODF:
		case EMODD:
			fprintf(ef, "trpfpe: can't fix emod yet\n");
			goto cant_fix;

		case POLYF:
		case POLYD:
			fprintf(ef, "trpfpe: can't fix poly yet\n");
			goto cant_fix;

		case ACBD:
		case ACBF:
		case CMPD:
		case CMPF:
		case TSTD:
		case TSTF:
		case CVTDB:
		case CVTDL:
		case CVTDW:
		case CVTFB:
		case CVTFL:
		case CVTFW:
		case CVTRDL:
		case CVTRFL:
			/* These can generate only reserved operand faults */
			/* They are shown here for completeness */

		default:
			fprintf(stderr, "trp: opcode 0x%02x unknown\n",
				*(--(*ipc)) & 0xff);
			goto cant_fix;
			/* NOTREACHED */
	}

	if (result_type == FLOAT)
		result_addr->ua_float = retval.rv_float;
	else
	{
		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];
		}
		else
			result_addr->ua_double = retval.rv_double;
	}
	signal(SIGFPE, on_fpe);
}
#endif	vax

trpfpe_ (count, rval)
	long	*count;	/* how many to announce */
	double	*rval;	/* dummy return value */
{
#if	vax
	max_messages = *count;
	retval.rv_double = *rval;
	sigfpe_dfl = signal(SIGFPE, on_fpe);
	fpe_count = 0;
#endif
}

long
fpecnt_ ()
{
#if	vax
	return (fpe_count);
#else
	return (0L);
#endif
}
Commit	Line	Data
799e6b82 DW	1	/* #define OLD_BSD if you're running < 4.2bsd */
	2	/*
	3	char id_trpfpe[] = "@(#)trpfpe_.c 1.1";
	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	\f
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	\f
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	\f
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 *)&reg0_6->reg[regnum];
188	else if (regnum <= R11)
189	reg_addr = (anything *)&reg7_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	oper_addr = (anything )(((anything )(*ipc))->ua_byte + reg_addr->ua_long);
263	*ipc += sizeof (char);
264	return(oper_addr);
265
266	case BYTEDISPDEF:
267	case BYTERELDEF:
268	oper_addr = (anything )(((anything )(*ipc))->ua_byte + reg_addr->ua_long);
269	oper_addr = oper_addr->ua_anything;
270	*ipc += sizeof (char);
271	return(oper_addr);
272
273	case WORDDISP:
274	case WORDREL:
275	oper_addr = (anything )(((anything )(*ipc))->ua_word + reg_addr->ua_long);
276	*ipc += sizeof (short);
277	return(oper_addr);
278
279	case WORDDISPDEF:
280	case WORDRELDEF:
281	oper_addr = (anything )(((anything )(*ipc))->ua_word + reg_addr->ua_long);
282	oper_addr = oper_addr->ua_anything;
283	*ipc += sizeof (short);
284	return(oper_addr);
285
286	case LONGDISP:
287	case LONGREL:
288	oper_addr = (anything )(((anything )(*ipc))->ua_long + reg_addr->ua_long);
289	*ipc += sizeof (long);
290	return(oper_addr);
291
292	case LONGDISPDEF:
293	case LONGRELDEF:
294	oper_addr = (anything )(((anything )(*ipc))->ua_long + reg_addr->ua_long);
295	oper_addr = oper_addr->ua_anything;
296	*ipc += sizeof (long);
297	return(oper_addr);
298
299	/* NOTREACHED */
300	}
301	}
302	\f
303	/*
304	* Trap & repair floating exceptions so that a program may proceed.
305	* There is no notion of "correctness" here; just the ability to continue.
306	*
307	* The on_fpe() routine first checks the type code to see if the
308	* exception is repairable. If so, it checks the opcode to see if
309	* it is one that it knows. If this is true, it then simulates the
310	* VAX cpu in retrieving operands in order to increment iPC correctly.
311	* It notes where the result of the operation would have been stored
312	* and substitutes a previously supplied value.
313	*/
314
315	#ifdef OLD_BSD
316	on_fpe(signo, code, myaddr, pc, ps)
317	int signo, code, ps;
318	char myaddr, pc;
319	#else
320	on_fpe(signo, code, sc, grbg)
321	int signo, code;
322	struct sigcontext *sc;
323	#endif
324	{
325	/*
326	* There must be at least 5 register variables here
327	* so our entry mask will save R11-R7.
328	*/
329	register long *stk;
330	register long *sp;
331	register struct arglist *ap;
332	register struct cframe *fp;
333	register FILE *ef;
334
335	ef = units[STDERR].ufd; /* fortran error stream */
336
337	switch (code)
338	{
339	case FPE_INTOVF_TRAP: /* integer overflow */
340	case FPE_INTDIV_TRAP: /* integer divide by zero */
341	case FPE_FLTOVF_TRAP: /* floating overflow */
342	case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */
343	case FPE_FLTUND_TRAP: /* floating underflow */
344	case FPE_DECOVF_TRAP: /* decimal overflow */
345	case FPE_SUBRNG_TRAP: /* subscript out of range */
346	default:
347	cant_fix:
348	if (sigfpe_dfl > (SIG_VAL)7) /* user specified */
349	#ifdef OLD_BSD
350	return((*sigfpe_dfl)(signo, code, myaddr, pc, ps));
351	#else
352	return((*sigfpe_dfl)(signo, code, sc, grbg));
353	#endif
354	else
355	#ifdef OLD_BSD
356	sigdie(signo, code, myaddr, pc, ps);
357	#else
358	sigdie(signo, code, sc, grbg);
359	#endif
360	/* NOTREACHED */
361
362	case FPE_FLTOVF_FAULT: /* floating overflow fault */
363	case FPE_FLTDIV_FAULT: /* divide by zero floating fault */
364	case FPE_FLTUND_FAULT: /* floating underflow fault */
365	if (++fpe_count <= max_messages) {
366	fprintf(ef, "trpfpe: %s",
367	act_fpe[code-1].mesg);
368	if (fpe_count == max_messages)
369	fprintf(ef, ": No more messages will be printed.\n");
370	else
371	fputc('\n', ef);
372	}
373	fpeflt_ = -1;
374	break;
375	}
376
377	ap = myap(); /* my arglist pointer */
378	fp = myfp(); /* my frame pointer */
379	ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */
380	iap = &(fp->cf_fp)->cf_ap;
381	/*
382	* these are likely to be system dependent
383	*/
384	reg0_6 = (struct reg0_6 )((char )fp->cf_fp + sizeof (struct cframe));
385	reg7_11 = (struct reg7_11 )((char )fp->cf_fp - sizeof (struct reg7_11));
386
387	#ifdef OLD_BSD
388	ipc = &pc;
389	isp = (char )&ap->al_arg[ap->al_numarg + 2]; / assumes 2 dummys */
390	ps &= ~(PSW_V\|PSW_FU);
391	#else
392	ipc = (char **)&sc->sc_pc;
393	isp = (char *)&ap->al_arg[ap->al_numarg] + sizeof (struct sigcontext);
394	sc->sc_ps &= ~(PSW_V\|PSW_FU);
395	#endif
396
397
398	switch ((ipc)++)
399	{
400	case ADDD3:
401	case DIVD3:
402	case MULD3:
403	case SUBD3:
404	(void) get_operand(sizeof (double));
405	/* intentional fall-thru */
406
407	case ADDD2:
408	case DIVD2:
409	case MULD2:
410	case SUBD2:
411	case MNEGD:
412	case MOVD:
413	(void) get_operand(sizeof (double));
414	result_addr = get_operand(sizeof (double));
415	result_type = DOUBLE;
416	break;
417
418	case ADDF3:
419	case DIVF3:
420	case MULF3:
421	case SUBF3:
422	(void) get_operand(sizeof (float));
423	/* intentional fall-thru */
424
425	case ADDF2:
426	case DIVF2:
427	case MULF2:
428	case SUBF2:
429	case MNEGF:
430	case MOVF:
431	(void) get_operand(sizeof (float));
432	result_addr = get_operand(sizeof (float));
433	result_type = FLOAT;
434	break;
435
436	case CVTDF:
437	(void) get_operand(sizeof (double));
438	result_addr = get_operand(sizeof (float));
439	result_type = FLOAT;
440	break;
441
442	case CVTFD:
443	(void) get_operand(sizeof (float));
444	result_addr = get_operand(sizeof (double));
445	result_type = DOUBLE;
446	break;
447
448	case EMODF:
449	case EMODD:
450	fprintf(ef, "trpfpe: can't fix emod yet\n");
451	goto cant_fix;
452
453	case POLYF:
454	case POLYD:
455	fprintf(ef, "trpfpe: can't fix poly yet\n");
456	goto cant_fix;
457
458	case ACBD:
459	case ACBF:
460	case CMPD:
461	case CMPF:
462	case TSTD:
463	case TSTF:
464	case CVTDB:
465	case CVTDL:
466	case CVTDW:
467	case CVTFB:
468	case CVTFL:
469	case CVTFW:
470	case CVTRDL:
471	case CVTRFL:
472	/* These can generate only reserved operand faults */
473	/* They are shown here for completeness */
474
475	default:
476	fprintf(stderr, "trp: opcode 0x%02x unknown\n",
477	(--(ipc)) & 0xff);
478	goto cant_fix;
479	/* NOTREACHED */
480	}
481
482	if (result_type == FLOAT)
483	result_addr->ua_float = retval.rv_float;
484	else
485	{
486	if (result_addr == (anything *)&iR6)
487	{ /*
488	* special case - the R6/R7 pair is stored apart
489	*/
490	result_addr->ua_long = retval.rv_long[0];
491	((anything *)&iR7)->ua_long = retval.rv_long[1];
492	}
493	else
494	result_addr->ua_double = retval.rv_double;
495	}
496	signal(SIGFPE, on_fpe);
497	}
498	#endif vax
499
500	trpfpe_ (count, rval)
501	long count; / how many to announce */
502	double rval; / dummy return value */
503	{
504	#if vax
505	max_messages = *count;
506	retval.rv_double = *rval;
507	sigfpe_dfl = signal(SIGFPE, on_fpe);
508	fpe_count = 0;
509	#endif
510	}
511
512	long
513	fpecnt_ ()
514	{
515	#if vax
516	return (fpe_count);
517	#else
518	return (0L);
519	#endif
520	}
521