[simh.git] / I1620 / i1620_fp.c

/* i1620_fp.c: IBM 1620 floating point simulator\r
\r
   Copyright (c) 2002-2008, Robert M. Supnik\r
\r
   Permission is hereby granted, free of charge, to any person obtaining a\r
   copy of this software and associated documentation files (the "Software"),\r
   to deal in the Software without restriction, including without limitation\r
   the rights to use, copy, modify, merge, publish, distribute, sublicense,\r
   and/or sell copies of the Software, and to permit persons to whom the\r
   Software is furnished to do so, subject to the following conditions:\r
\r
   The above copyright notice and this permission notice shall be included in\r
   all copies or substantial portions of the Software.\r
\r
   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\r
   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\r
   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL\r
   ROBERT M SUPNIK BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER\r
   IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\r
   CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\r
\r
   Except as contained in this notice, the name of Robert M Supnik shall not be\r
   used in advertising or otherwise to promote the sale, use or other dealings\r
   in this Software without prior written authorization from Robert M Supnik.\r
\r
   The IBM 1620 uses a variable length floating point format, with a fixed\r
   two digit decimal exponent and a variable length decimal mantissa:\r
\r
        _       S_S\r
        M.......MEE\r
\r
   where S represents flag bits if the mantissa or exponent are negative.\r
\r
   31-May-2008  RMS     Fixed add_field call (found by Peter Schorn)\r
*/\r
\r
#include "i1620_defs.h"\r
\r
#define FP_LMAX         100                             /* max fp mant lnt */\r
#define FP_EMAX         99                              /* max fp exponent */\r
\r
/* Unpacked floating point operand */\r
\r
typedef struct {\r
    int32       sign;                                   /* 0 => +, 1 => - */\r
    int32       exp;                                    /* binary exponent */\r
    uint32      lnt;                                    /* mantissa length */\r
    uint32      addr;                                   /* mantissa addr */\r
    uint32      zero;                                   /* 0 => nz, 1 => zero */\r
    } FPA;\r
\r
extern uint8 M[MAXMEMSIZE];                             /* main memory */\r
extern uint8 ind[NUM_IND];                              /* indicators */\r
extern UNIT cpu_unit;\r
\r
t_stat fp_scan_mant (uint32 ad, uint32 *lnt, uint32 *zro);\r
t_stat fp_zero (FPA *fp);\r
\r
extern t_stat xmt_field (uint32 d, uint32 s, uint32 skp);\r
extern t_stat add_field (uint32 d, uint32 s, t_bool sub, t_bool sto, uint32 skp, int32 *sta);\r
extern t_stat mul_field (uint32 d, uint32 s);\r
extern t_stat xmt_divd (uint32 d, uint32 s);\r
extern t_stat div_field (uint32 dvd, uint32 dvr, int32 *ez);\r
\r
/* Unpack and validate a floating point argument */\r
\r
t_stat fp_unpack (uint32 ad, FPA *fp)\r
{\r
uint8 d0, d1, esign;\r
\r
esign = M[ad] & FLAG;                                   /* get exp sign */\r
d0 = M[ad] & DIGIT;                                     /* get exp lo digit */\r
MM (ad);\r
if ((M[ad] & FLAG) == 0) return STOP_FPMF;              /* no flag on hi exp? */\r
d1 = M[ad] & DIGIT;                                     /* get exp hi digit */\r
MM (ad);\r
fp->addr = ad;                                          /* save mant addr */\r
if (BAD_DIGIT (d1) || BAD_DIGIT (d0)) return STOP_INVDIG; /* exp bad dig? */\r
fp->exp = ((d1 * 10) + d0) * (esign? -1: 1);            /* convert exponent */\r
fp->sign = (M[ad] & FLAG)? 1: 0;                        /* get mantissa sign */\r
return fp_scan_mant (fp->addr, &(fp->lnt), &(fp->zero));\r
}\r
\r
/* Unpack and validate source and destination arguments */\r
\r
t_stat fp_unpack_two (uint32 dad, uint32 sad, FPA *dfp, FPA *sfp)\r
{\r
t_stat r;\r
\r
if ((r = fp_unpack (dad, dfp)) != SCPE_OK) return r;    /* unpack dst */\r
if ((r = fp_unpack (sad, sfp)) != SCPE_OK) return r;    /* unpack src */\r
if (sfp->lnt != dfp->lnt) return STOP_FPUNL;            /* lnts must be equal */\r
return SCPE_OK;\r
}\r
\r
/* Pack floating point result */\r
\r
t_stat fp_pack (FPA *fp)\r
{\r
int32 e;\r
uint32 i, mad;\r
\r
e = (fp->exp >= 0)? fp->exp: -fp->exp;                  /* get |exp| */                                 \r
if (e > FP_EMAX) {                                      /* too big? */\r
    ind[IN_EXPCHK] = 1;                                 /* set indicator */\r
    if (fp->exp < 0) return fp_zero (fp);               /* underflow? */\r
    mad = fp->addr;\r
    for (i = 0; i < fp->lnt; i++) {                     /* mant = 99...99 */\r
        M[mad] = (M[mad] & FLAG) | 9;\r
        MM (mad);\r
        }\r
    e = FP_EMAX;                                        /* cap at max */\r
    }\r
M[ADDR_A (fp->addr, 1)] = (e / 10) | FLAG;              /* high exp digit */\r
M[ADDR_A (fp->addr, 2)] = (e % 10) |                    /* low exp digit */\r
     ((fp->exp < 0)? FLAG: 0);\r
return SCPE_OK;\r
}\r
\r
/* Shift mantissa right n positions */\r
\r
void fp_rsh (FPA *fp, uint32 n)\r
{\r
uint32 i, sad, dad;\r
\r
if (n == 0) return;                                     /* zero? done */\r
sad = ADDR_S (fp->addr, n);                             /* src = addr - n */\r
dad = fp->addr;                                         /* dst = n */\r
for (i = 0; i < fp->lnt; i++) {                         /* move digits */\r
    if (i >= (fp->lnt - n)) M[dad] = M[dad] & FLAG;\r
    else M[dad] = (M[dad] & FLAG) | (M[sad] & DIGIT);\r
    MM (dad);\r
    MM (sad);\r
    }\r
return;\r
}\r
\r
/* Shift mantissa left 1 position */\r
\r
void fp_lsh_1 (FPA *fp)\r
{\r
uint32 i, mad, nxt;\r
\r
mad = ADDR_S (fp->addr, fp->lnt - 1);                   /* hi order digit */\r
for (i = 0; i < (fp->lnt - 1); i++) {                   /* move lnt-1 digits */\r
    nxt = ADDR_A (mad, 1);\r
    M[mad] = (M[mad] & FLAG) | (M[nxt] & DIGIT);\r
    mad = nxt;\r
    }\r
M[mad] = M[mad] & FLAG;                                 /* clear last digit */\r
return;\r
}\r
\r
/* Clear floating point number */\r
\r
t_stat fp_zero (FPA *fp)\r
{\r
uint32 i, mad = fp->addr;\r
\r
for (i = 0; i < fp->lnt; i++) {                         /* clear mantissa */\r
    M[mad] = (i? M[mad] & FLAG: 0);                     /* clear sign bit */\r
    MM (mad);\r
    }\r
M[ADDR_A (fp->addr, 1)] = FLAG + 9;                     /* exp = -99 */\r
M[ADDR_A (fp->addr, 2)] = FLAG + 9;                     /* exp = -99 */\r
ind[IN_EZ] = 1;                                         /* result = 0 */\r
ind[IN_HP] = 0;\r
return SCPE_OK;\r
}\r
\r
/* Scan floating point mantissa for length and (optionally) zero */\r
\r
t_stat fp_scan_mant (uint32 ad, uint32 *lnt, uint32 *zro)\r
{\r
uint8 d, l, z;\r
\r
z = 1;                                                  /* assume zero */\r
for (l = 1; l <= FP_LMAX; l++) {                        /* scan to get length */\r
    d = M[ad] & DIGIT;                                  /* get mant digit */\r
    if (d) z = 0;                                       /* non-zero? */\r
    if ((l != 1) && (M[ad] & FLAG)) {                   /* flag past first dig? */\r
        *lnt = l;                                       /* set returns */\r
        if (zro) *zro = z;\r
        return SCPE_OK;\r
        }\r
    MM (ad);\r
    }\r
return STOP_FPLNT;                                      /* too long */\r
}\r
\r
/* Copy floating point mantissa */\r
\r
void fp_copy_mant (uint32 d, uint32 s, uint32 l)\r
{\r
uint32 i;\r
\r
if (ind[IN_HP]) M[d] = M[d] & ~FLAG;                    /* clr/set sign */\r
else M[d] = M[d] | FLAG;\r
for (i = 0; i < l; i++) {                               /* copy src */\r
    M[d] = (M[d] & FLAG) | (M[s] & DIGIT);              /* preserve flags */\r
    MM (d);\r
    MM (s);\r
    }\r
return;\r
}\r
\r
/* Compare floating point mantissa */\r
\r
int32 fp_comp_mant (uint32 d, uint32 s, uint32 l)\r
{\r
uint8 i, dd, sd;\r
\r
d = ADDR_S (d, l - 1);                                  /* start of mantissa */\r
s = ADDR_S (s, l - 1);\r
for (i = 0; i < l; i++) {                               /* compare dst:src */\r
    dd = M[d] & DIGIT;                                  /* get dst digit */\r
    sd = M[s] & DIGIT;                                  /* get src digit */\r
    if (dd > sd) return 1;                              /* >? done */\r
    if (dd < sd) return -1;                             /* <? done */\r
    PP (d);                                             /* =? continue */\r
    PP (s);\r
    }\r
return 0;                                               /* done, equal */\r
}\r
\r
/* Floating point add */\r
\r
t_stat fp_add (uint32 d, uint32 s, t_bool sub)\r
{\r
FPA sfp, dfp;\r
uint32 i, sad, hi;\r
int32 dif, sta;\r
uint8 sav_src[FP_LMAX];\r
t_stat r;\r
\r
r = fp_unpack_two (d, s, &dfp, &sfp);                   /* unpack operands */\r
if (r != SCPE_OK) return r;                             /* error? */\r
dif = dfp.exp - sfp.exp;                                /* exp difference */\r
\r
if (sfp.zero || (dif >= ((int32) dfp.lnt))) {           /* src = 0, or too small? */\r
    if (dfp.zero) return fp_zero (&dfp);                /* res = dst, zero? */          \r
    ind[IN_EZ] = 0;                                     /* res nz, set EZ, HP */\r
    ind[IN_HP] = (dfp.sign == 0);\r
    return SCPE_OK;\r
    }\r
if (dfp.zero || (dif <= -((int32) dfp.lnt))) {          /* dst = 0, or too small? */\r
    if (sfp.zero) return fp_zero (&dfp);                /* res = src, zero? */\r
    r = xmt_field (d, s, 3);                            /* copy src to dst */\r
    ind[IN_EZ] = 0;                                     /* res nz, set EZ, HP */\r
    ind[IN_HP] = (dfp.sign == 0);\r
    return r;\r
    }\r
\r
if (dif > 0) {                                          /* dst exp > src exp? */\r
    sad = sfp.addr;                                     /* save src in save area */\r
    for (i = 0; i < sfp.lnt; i++) {\r
        sav_src[i] = M[sad];\r
        MM (sad);\r
        }\r
    fp_rsh (&sfp, dif);                                 /* denormalize src */\r
    }\r
else if (dif < 0) {                                     /* dst exp < src exp? */\r
    dfp.exp = sfp.exp;                                  /* res exp = src exp */\r
    fp_rsh (&dfp, -dif);                                /* denormalize dst */\r
    }\r
r = add_field (dfp.addr, sfp.addr, sub, TRUE, 0, &sta); /* add mant, set EZ, HP */\r
if (dif > 0) {                                          /* src denormalized? */\r
    sad = sfp.addr;                                     /* restore src from */\r
    for (i = 0; i < sfp.lnt; i++) {                     /* save area */\r
        M[sad] = sav_src[i];\r
        MM (sad);\r
        }\r
    }\r
if (r != SCPE_OK) return r;                             /* add error? */\r
\r
hi = ADDR_S (dfp.addr, dfp.lnt - 1);                    /* addr of hi digit */\r
if (sta == ADD_CARRY) {                                 /* carry out? */\r
    fp_rsh (&dfp, 1);                                   /* shift mantissa */\r
    M[hi] = FLAG + 1;                                   /* high order 1 */\r
    dfp.exp = dfp.exp + 1;\r
    ind[IN_EZ] = 0;                                     /* not zero */\r
    ind[IN_HP] = (dfp.sign == 0);                       /* set HP */\r
    }\r
else if (ind[IN_EZ]) return fp_zero (&dfp);             /* result zero? */\r
else {\r
    while ((M[hi] & DIGIT) == 0) {                      /* until normalized */\r
        fp_lsh_1 (&dfp);                                /* left shift */\r
        dfp.exp = dfp.exp - 1;                          /* decr exponent */\r
        }\r
    }\r
\r
return fp_pack (&dfp);                                  /* pack and exit */\r
}\r
\r
/* Floating point multiply */\r
\r
t_stat fp_mul (uint32 d, uint32 s)\r
{\r
FPA sfp, dfp;\r
uint32 pad;\r
t_stat r;\r
\r
r = fp_unpack_two (d, s, &dfp, &sfp);                   /* unpack operands */\r
if (r != SCPE_OK) return r;                             /* error? */\r
if (sfp.zero || dfp.zero) return fp_zero (&dfp);        /* either zero? */\r
\r
r = mul_field (dfp.addr, sfp.addr);                     /* mul, set EZ, HP */\r
if (r != SCPE_OK) return r;\r
if (M[ADDR_S (PROD_AREA_END, 2 * dfp.lnt)] & DIGIT) {   /* hi prod dig set? */\r
    pad = ADDR_S (PROD_AREA_END - 1, dfp.lnt);          /* no normalization */\r
    dfp.exp = dfp.exp + sfp.exp;                        /* res exp = sum */\r
    }\r
else {\r
    pad = ADDR_S (PROD_AREA_END, dfp.lnt);              /* 'normalize' 1 */\r
    dfp.exp = dfp.exp + sfp.exp - 1;                    /* res exp = sum - 1 */\r
    }\r
fp_copy_mant (dfp.addr, pad, dfp.lnt);                  /* copy prod to mant */\r
\r
return fp_pack (&dfp);                                  /* pack and exit */\r
}\r
\r
/* Floating point divide */\r
\r
t_stat fp_div (uint32 d, uint32 s)\r
{\r
FPA sfp, dfp;\r
uint32 i, pad, a100ml, a99ml;\r
int32 ez;\r
t_stat r;\r
\r
r = fp_unpack_two (d, s, &dfp, &sfp);                   /* unpack operands */\r
if (r != SCPE_OK) return r;                             /* error? */\r
if (sfp.zero) {                                         /* divide by zero? */\r
    ind[IN_OVF] = 1;                                    /* dead jim */\r
    return SCPE_OK;\r
    }\r
if (dfp.zero) return fp_zero (&dfp);                    /* divide into zero? */\r
\r
for (i = 0; i < PROD_AREA_LEN; i++)                     /* clear prod area */\r
    M[PROD_AREA + i] = 0;\r
a100ml = ADDR_S (PROD_AREA_END, dfp.lnt);               /* 100 - lnt */\r
a99ml = ADDR_S (PROD_AREA_END - 1, dfp.lnt);            /* 99 - lnt */\r
if (fp_comp_mant (dfp.addr, sfp.addr, dfp.lnt) >= 0) {  /* |Mdst| >= |Msrc|? */\r
    pad = a100ml;\r
    dfp.exp = dfp.exp - sfp.exp + 1;                    /* res exp = diff + 1 */\r
    }\r
else {\r
    pad = a99ml;\r
    dfp.exp = dfp.exp - sfp.exp;                        /* res exp = diff */\r
    }\r
r = xmt_divd (pad, dfp.addr);                           /* xmt dividend */\r
if (r != SCPE_OK) return r;                             /* error? */\r
r = div_field (a100ml, sfp.addr, &ez);                  /* divide fractions */\r
if (r != SCPE_OK) return r;                             /* error? */\r
if (ez) return fp_zero (&dfp);                          /* result zero? */\r
\r
ind[IN_HP] = ((dfp.sign ^ sfp.sign) == 0);              /* set res sign */\r
ind[IN_EZ] = 0;                                         /* not zero */\r
fp_copy_mant (dfp.addr, a99ml, dfp.lnt);                /* copy result */\r
\r
return fp_pack (&dfp);\r
}\r
\r
/* Floating shift right */\r
\r
t_stat fp_fsr (uint32 d, uint32 s)\r
{\r
uint32 cnt;\r
uint8 t;\r
\r
if (d == s) return SCPE_OK;                             /* no move? */\r
\r
cnt = 0;\r
M[d] = (M[d] & FLAG) | (M[s] & DIGIT);                  /* move 1st wo flag */\r
do {\r
    MM (d);                                             /* decr ptrs */\r
    MM (s);\r
    t = M[d] = M[s] & (FLAG | DIGIT);                   /* copy others */\r
    if (cnt++ > MEMSIZE) return STOP_FWRAP;             /* (stop runaway) */\r
    } while ((t & FLAG) == 0);                          /* until src flag */\r
\r
cnt = 0;\r
do {\r
    MM (d);                                             /* decr pointer */\r
    t = M[d];                                           /* save old val */\r
    M[d] = 0;                                           /* zero field */\r
    if (cnt++ > MEMSIZE) return STOP_FWRAP;             /* (stop runaway) */\r
    } while ((t & FLAG) == 0);                          /* until dst flag */\r
return SCPE_OK;\r
} \r
\r
/* Floating shift left - note that dst is addr of high order digit */\r
\r
t_stat fp_fsl (uint32 d, uint32 s)\r
{\r
uint32 i, lnt;\r
uint8 sign;\r
t_stat r;\r
\r
if (d == s) return SCPE_OK;\r
sign = M[s] & FLAG;                                     /* get src sign */\r
r = fp_scan_mant (s, &lnt, NULL);                       /* get src length */\r
if (r != SCPE_OK) return r;                             /* error? */\r
s = ADDR_S (s, lnt - 1);                                /* hi order src */\r
M[d] = M[s] & (FLAG | DIGIT);                           /* move 1st w flag */\r
M[s] = M[s] & ~FLAG;                                    /* clr flag from src */\r
for (i = 1; i < lnt; i++) {                             /* move src to dst */\r
    PP (d);                                             /* incr ptrs */\r
    PP (s);\r
    M[d] = M[s] & DIGIT;                                /* move just digit */\r
    }\r
PP (d);                                                 /* incr pointer */\r
while ((M[d] & FLAG) == 0) {                            /* until flag */\r
    M[d] = 0;                                           /* clear field */\r
    PP (d);\r
    }\r
if (sign) M[d] = FLAG;                                  /* -? zero under sign */\r
return SCPE_OK;\r
}\r
Commit	Line	Data
196ba1fc PH	1	/* i1620_fp.c: IBM 1620 floating point simulator\r
	2	\r
	3	Copyright (c) 2002-2008, Robert M. Supnik\r
	4	\r
	5	Permission is hereby granted, free of charge, to any person obtaining a\r
	6	copy of this software and associated documentation files (the "Software"),\r
	7	to deal in the Software without restriction, including without limitation\r
	8	the rights to use, copy, modify, merge, publish, distribute, sublicense,\r
	9	and/or sell copies of the Software, and to permit persons to whom the\r
	10	Software is furnished to do so, subject to the following conditions:\r
	11	\r
	12	The above copyright notice and this permission notice shall be included in\r
	13	all copies or substantial portions of the Software.\r
	14	\r
	15	THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\r
	16	IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\r
	17	FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL\r
	18	ROBERT M SUPNIK BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER\r
	19	IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\r
	20	CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\r
	21	\r
	22	Except as contained in this notice, the name of Robert M Supnik shall not be\r
	23	used in advertising or otherwise to promote the sale, use or other dealings\r
	24	in this Software without prior written authorization from Robert M Supnik.\r
	25	\r
	26	The IBM 1620 uses a variable length floating point format, with a fixed\r
	27	two digit decimal exponent and a variable length decimal mantissa:\r
	28	\r
	29	_ S_S\r
	30	M.......MEE\r
	31	\r
	32	where S represents flag bits if the mantissa or exponent are negative.\r
	33	\r
	34	31-May-2008 RMS Fixed add_field call (found by Peter Schorn)\r
	35	*/\r
	36	\r
	37	#include "i1620_defs.h"\r
	38	\r
	39	#define FP_LMAX 100 /* max fp mant lnt */\r
	40	#define FP_EMAX 99 /* max fp exponent */\r
	41	\r
	42	/* Unpacked floating point operand */\r
	43	\r
	44	typedef struct {\r
	45	int32 sign; /* 0 => +, 1 => - */\r
	46	int32 exp; /* binary exponent */\r
	47	uint32 lnt; /* mantissa length */\r
	48	uint32 addr; /* mantissa addr */\r
	49	uint32 zero; /* 0 => nz, 1 => zero */\r
	50	} FPA;\r
	51	\r
	52	extern uint8 M[MAXMEMSIZE]; /* main memory */\r
	53	extern uint8 ind[NUM_IND]; /* indicators */\r
	54	extern UNIT cpu_unit;\r
	55	\r
	56	t_stat fp_scan_mant (uint32 ad, uint32 lnt, uint32 zro);\r
	57	t_stat fp_zero (FPA *fp);\r
	58	\r
	59	extern t_stat xmt_field (uint32 d, uint32 s, uint32 skp);\r
	60	extern t_stat add_field (uint32 d, uint32 s, t_bool sub, t_bool sto, uint32 skp, int32 *sta);\r
	61	extern t_stat mul_field (uint32 d, uint32 s);\r
	62	extern t_stat xmt_divd (uint32 d, uint32 s);\r
	63	extern t_stat div_field (uint32 dvd, uint32 dvr, int32 *ez);\r
	64	\r
65	/* Unpack and validate a floating point argument */\r
66	\r
67	t_stat fp_unpack (uint32 ad, FPA *fp)\r
68	{\r
69	uint8 d0, d1, esign;\r
70	\r
71	esign = M[ad] & FLAG; /* get exp sign */\r
72	d0 = M[ad] & DIGIT; /* get exp lo digit */\r
73	MM (ad);\r
74	if ((M[ad] & FLAG) == 0) return STOP_FPMF; /* no flag on hi exp? */\r
75	d1 = M[ad] & DIGIT; /* get exp hi digit */\r
76	MM (ad);\r
77	fp->addr = ad; /* save mant addr */\r
78	if (BAD_DIGIT (d1) \|\| BAD_DIGIT (d0)) return STOP_INVDIG; /* exp bad dig? */\r
79	fp->exp = ((d1 * 10) + d0) * (esign? -1: 1); /* convert exponent */\r
80	fp->sign = (M[ad] & FLAG)? 1: 0; /* get mantissa sign */\r
81	return fp_scan_mant (fp->addr, &(fp->lnt), &(fp->zero));\r
82	}\r
83	\r
84	/* Unpack and validate source and destination arguments */\r
85	\r
86	t_stat fp_unpack_two (uint32 dad, uint32 sad, FPA dfp, FPA sfp)\r
87	{\r
88	t_stat r;\r
89	\r
90	if ((r = fp_unpack (dad, dfp)) != SCPE_OK) return r; /* unpack dst */\r
91	if ((r = fp_unpack (sad, sfp)) != SCPE_OK) return r; /* unpack src */\r
92	if (sfp->lnt != dfp->lnt) return STOP_FPUNL; /* lnts must be equal */\r
93	return SCPE_OK;\r
94	}\r
95	\r
96	/* Pack floating point result */\r
97	\r
98	t_stat fp_pack (FPA *fp)\r
99	{\r
100	int32 e;\r
101	uint32 i, mad;\r
102	\r
103	e = (fp->exp >= 0)? fp->exp: -fp->exp; /* get \|exp\| */ \r
104	if (e > FP_EMAX) { /* too big? */\r
105	ind[IN_EXPCHK] = 1; /* set indicator */\r
106	if (fp->exp < 0) return fp_zero (fp); /* underflow? */\r
107	mad = fp->addr;\r
108	for (i = 0; i < fp->lnt; i++) { /* mant = 99...99 */\r
109	M[mad] = (M[mad] & FLAG) \| 9;\r
110	MM (mad);\r
111	}\r
112	e = FP_EMAX; /* cap at max */\r
113	}\r
114	M[ADDR_A (fp->addr, 1)] = (e / 10) \| FLAG; /* high exp digit */\r
115	M[ADDR_A (fp->addr, 2)] = (e % 10) \| /* low exp digit */\r
116	((fp->exp < 0)? FLAG: 0);\r
117	return SCPE_OK;\r
118	}\r
119	\r
120	/* Shift mantissa right n positions */\r
121	\r
122	void fp_rsh (FPA *fp, uint32 n)\r
123	{\r
124	uint32 i, sad, dad;\r
125	\r
126	if (n == 0) return; /* zero? done */\r
127	sad = ADDR_S (fp->addr, n); /* src = addr - n */\r
128	dad = fp->addr; /* dst = n */\r
129	for (i = 0; i < fp->lnt; i++) { /* move digits */\r
130	if (i >= (fp->lnt - n)) M[dad] = M[dad] & FLAG;\r
131	else M[dad] = (M[dad] & FLAG) \| (M[sad] & DIGIT);\r
132	MM (dad);\r
133	MM (sad);\r
134	}\r
135	return;\r
136	}\r
137	\r
138	/* Shift mantissa left 1 position */\r
139	\r
140	void fp_lsh_1 (FPA *fp)\r
141	{\r
142	uint32 i, mad, nxt;\r
143	\r
144	mad = ADDR_S (fp->addr, fp->lnt - 1); /* hi order digit */\r
145	for (i = 0; i < (fp->lnt - 1); i++) { /* move lnt-1 digits */\r
146	nxt = ADDR_A (mad, 1);\r
147	M[mad] = (M[mad] & FLAG) \| (M[nxt] & DIGIT);\r
148	mad = nxt;\r
149	}\r
150	M[mad] = M[mad] & FLAG; /* clear last digit */\r
151	return;\r
152	}\r
153	\r
154	/* Clear floating point number */\r
155	\r
156	t_stat fp_zero (FPA *fp)\r
157	{\r
158	uint32 i, mad = fp->addr;\r
159	\r
160	for (i = 0; i < fp->lnt; i++) { /* clear mantissa */\r
161	M[mad] = (i? M[mad] & FLAG: 0); /* clear sign bit */\r
162	MM (mad);\r
163	}\r
164	M[ADDR_A (fp->addr, 1)] = FLAG + 9; /* exp = -99 */\r
165	M[ADDR_A (fp->addr, 2)] = FLAG + 9; /* exp = -99 */\r
166	ind[IN_EZ] = 1; /* result = 0 */\r
167	ind[IN_HP] = 0;\r
168	return SCPE_OK;\r
169	}\r
170	\r
171	/* Scan floating point mantissa for length and (optionally) zero */\r
172	\r
173	t_stat fp_scan_mant (uint32 ad, uint32 lnt, uint32 zro)\r
174	{\r
175	uint8 d, l, z;\r
176	\r
177	z = 1; /* assume zero */\r
178	for (l = 1; l <= FP_LMAX; l++) { /* scan to get length */\r
179	d = M[ad] & DIGIT; /* get mant digit */\r
180	if (d) z = 0; /* non-zero? */\r
181	if ((l != 1) && (M[ad] & FLAG)) { /* flag past first dig? */\r
182	lnt = l; / set returns */\r
183	if (zro) *zro = z;\r
184	return SCPE_OK;\r
185	}\r
186	MM (ad);\r
187	}\r
188	return STOP_FPLNT; /* too long */\r
189	}\r
190	\r
191	/* Copy floating point mantissa */\r
192	\r
193	void fp_copy_mant (uint32 d, uint32 s, uint32 l)\r
194	{\r
195	uint32 i;\r
196	\r
197	if (ind[IN_HP]) M[d] = M[d] & ~FLAG; /* clr/set sign */\r
198	else M[d] = M[d] \| FLAG;\r
199	for (i = 0; i < l; i++) { /* copy src */\r
200	M[d] = (M[d] & FLAG) \| (M[s] & DIGIT); /* preserve flags */\r
201	MM (d);\r
202	MM (s);\r
203	}\r
204	return;\r
205	}\r
206	\r
207	/* Compare floating point mantissa */\r
208	\r
209	int32 fp_comp_mant (uint32 d, uint32 s, uint32 l)\r
210	{\r
211	uint8 i, dd, sd;\r
212	\r
213	d = ADDR_S (d, l - 1); /* start of mantissa */\r
214	s = ADDR_S (s, l - 1);\r
215	for (i = 0; i < l; i++) { /* compare dst:src */\r
216	dd = M[d] & DIGIT; /* get dst digit */\r
217	sd = M[s] & DIGIT; /* get src digit */\r
218	if (dd > sd) return 1; /* >? done */\r
219	if (dd < sd) return -1; /* <? done */\r
220	PP (d); /* =? continue */\r
221	PP (s);\r
222	}\r
223	return 0; /* done, equal */\r
224	}\r
225	\r
226	/* Floating point add */\r
227	\r
228	t_stat fp_add (uint32 d, uint32 s, t_bool sub)\r
229	{\r
230	FPA sfp, dfp;\r
231	uint32 i, sad, hi;\r
232	int32 dif, sta;\r
233	uint8 sav_src[FP_LMAX];\r
234	t_stat r;\r
235	\r
236	r = fp_unpack_two (d, s, &dfp, &sfp); /* unpack operands */\r
237	if (r != SCPE_OK) return r; /* error? */\r
238	dif = dfp.exp - sfp.exp; /* exp difference */\r
239	\r
240	if (sfp.zero \|\| (dif >= ((int32) dfp.lnt))) { /* src = 0, or too small? */\r
241	if (dfp.zero) return fp_zero (&dfp); /* res = dst, zero? */ \r
242	ind[IN_EZ] = 0; /* res nz, set EZ, HP */\r
243	ind[IN_HP] = (dfp.sign == 0);\r
244	return SCPE_OK;\r
245	}\r
246	if (dfp.zero \|\| (dif <= -((int32) dfp.lnt))) { /* dst = 0, or too small? */\r
247	if (sfp.zero) return fp_zero (&dfp); /* res = src, zero? */\r
248	r = xmt_field (d, s, 3); /* copy src to dst */\r
249	ind[IN_EZ] = 0; /* res nz, set EZ, HP */\r
250	ind[IN_HP] = (dfp.sign == 0);\r
251	return r;\r
252	}\r
253	\r
254	if (dif > 0) { /* dst exp > src exp? */\r
255	sad = sfp.addr; /* save src in save area */\r
256	for (i = 0; i < sfp.lnt; i++) {\r
257	sav_src[i] = M[sad];\r
258	MM (sad);\r
259	}\r
260	fp_rsh (&sfp, dif); /* denormalize src */\r
261	}\r
262	else if (dif < 0) { /* dst exp < src exp? */\r
263	dfp.exp = sfp.exp; /* res exp = src exp */\r
264	fp_rsh (&dfp, -dif); /* denormalize dst */\r
265	}\r
266	r = add_field (dfp.addr, sfp.addr, sub, TRUE, 0, &sta); /* add mant, set EZ, HP */\r
267	if (dif > 0) { /* src denormalized? */\r
268	sad = sfp.addr; /* restore src from */\r
269	for (i = 0; i < sfp.lnt; i++) { /* save area */\r
270	M[sad] = sav_src[i];\r
271	MM (sad);\r
272	}\r
273	}\r
274	if (r != SCPE_OK) return r; /* add error? */\r
275	\r
276	hi = ADDR_S (dfp.addr, dfp.lnt - 1); /* addr of hi digit */\r
277	if (sta == ADD_CARRY) { /* carry out? */\r
278	fp_rsh (&dfp, 1); /* shift mantissa */\r
279	M[hi] = FLAG + 1; /* high order 1 */\r
280	dfp.exp = dfp.exp + 1;\r
281	ind[IN_EZ] = 0; /* not zero */\r
282	ind[IN_HP] = (dfp.sign == 0); /* set HP */\r
283	}\r
284	else if (ind[IN_EZ]) return fp_zero (&dfp); /* result zero? */\r
285	else {\r
286	while ((M[hi] & DIGIT) == 0) { /* until normalized */\r
287	fp_lsh_1 (&dfp); /* left shift */\r
288	dfp.exp = dfp.exp - 1; /* decr exponent */\r
289	}\r
290	}\r
291	\r
292	return fp_pack (&dfp); /* pack and exit */\r
293	}\r
294	\r
295	/* Floating point multiply */\r
296	\r
297	t_stat fp_mul (uint32 d, uint32 s)\r
298	{\r
299	FPA sfp, dfp;\r
300	uint32 pad;\r
301	t_stat r;\r
302	\r
303	r = fp_unpack_two (d, s, &dfp, &sfp); /* unpack operands */\r
304	if (r != SCPE_OK) return r; /* error? */\r
305	if (sfp.zero \|\| dfp.zero) return fp_zero (&dfp); /* either zero? */\r
306	\r
307	r = mul_field (dfp.addr, sfp.addr); /* mul, set EZ, HP */\r
308	if (r != SCPE_OK) return r;\r
309	if (M[ADDR_S (PROD_AREA_END, 2 * dfp.lnt)] & DIGIT) { /* hi prod dig set? */\r
310	pad = ADDR_S (PROD_AREA_END - 1, dfp.lnt); /* no normalization */\r
311	dfp.exp = dfp.exp + sfp.exp; /* res exp = sum */\r
312	}\r
313	else {\r
314	pad = ADDR_S (PROD_AREA_END, dfp.lnt); /* 'normalize' 1 */\r
315	dfp.exp = dfp.exp + sfp.exp - 1; /* res exp = sum - 1 */\r
316	}\r
317	fp_copy_mant (dfp.addr, pad, dfp.lnt); /* copy prod to mant */\r
318	\r
319	return fp_pack (&dfp); /* pack and exit */\r
320	}\r
321	\r
322	/* Floating point divide */\r
323	\r
324	t_stat fp_div (uint32 d, uint32 s)\r
325	{\r
326	FPA sfp, dfp;\r
327	uint32 i, pad, a100ml, a99ml;\r
328	int32 ez;\r
329	t_stat r;\r
330	\r
331	r = fp_unpack_two (d, s, &dfp, &sfp); /* unpack operands */\r
332	if (r != SCPE_OK) return r; /* error? */\r
333	if (sfp.zero) { /* divide by zero? */\r
334	ind[IN_OVF] = 1; /* dead jim */\r
335	return SCPE_OK;\r
336	}\r
337	if (dfp.zero) return fp_zero (&dfp); /* divide into zero? */\r
338	\r
339	for (i = 0; i < PROD_AREA_LEN; i++) /* clear prod area */\r
340	M[PROD_AREA + i] = 0;\r
341	a100ml = ADDR_S (PROD_AREA_END, dfp.lnt); /* 100 - lnt */\r
342	a99ml = ADDR_S (PROD_AREA_END - 1, dfp.lnt); /* 99 - lnt */\r
343	if (fp_comp_mant (dfp.addr, sfp.addr, dfp.lnt) >= 0) { /* \|Mdst\| >= \|Msrc\|? */\r
344	pad = a100ml;\r
345	dfp.exp = dfp.exp - sfp.exp + 1; /* res exp = diff + 1 */\r
346	}\r
347	else {\r
348	pad = a99ml;\r
349	dfp.exp = dfp.exp - sfp.exp; /* res exp = diff */\r
350	}\r
351	r = xmt_divd (pad, dfp.addr); /* xmt dividend */\r
352	if (r != SCPE_OK) return r; /* error? */\r
353	r = div_field (a100ml, sfp.addr, &ez); /* divide fractions */\r
354	if (r != SCPE_OK) return r; /* error? */\r
355	if (ez) return fp_zero (&dfp); /* result zero? */\r
356	\r
357	ind[IN_HP] = ((dfp.sign ^ sfp.sign) == 0); /* set res sign */\r
358	ind[IN_EZ] = 0; /* not zero */\r
359	fp_copy_mant (dfp.addr, a99ml, dfp.lnt); /* copy result */\r
360	\r
361	return fp_pack (&dfp);\r
362	}\r
363	\r
364	/* Floating shift right */\r
365	\r
366	t_stat fp_fsr (uint32 d, uint32 s)\r
367	{\r
368	uint32 cnt;\r
369	uint8 t;\r
370	\r
371	if (d == s) return SCPE_OK; /* no move? */\r
372	\r
373	cnt = 0;\r
374	M[d] = (M[d] & FLAG) \| (M[s] & DIGIT); /* move 1st wo flag */\r
375	do {\r
376	MM (d); /* decr ptrs */\r
377	MM (s);\r
378	t = M[d] = M[s] & (FLAG \| DIGIT); /* copy others */\r
379	if (cnt++ > MEMSIZE) return STOP_FWRAP; /* (stop runaway) */\r
380	} while ((t & FLAG) == 0); /* until src flag */\r
381	\r
382	cnt = 0;\r
383	do {\r
384	MM (d); /* decr pointer */\r
385	t = M[d]; /* save old val */\r
386	M[d] = 0; /* zero field */\r
387	if (cnt++ > MEMSIZE) return STOP_FWRAP; /* (stop runaway) */\r
388	} while ((t & FLAG) == 0); /* until dst flag */\r
389	return SCPE_OK;\r
390	} \r
391	\r
392	/* Floating shift left - note that dst is addr of high order digit */\r
393	\r
394	t_stat fp_fsl (uint32 d, uint32 s)\r
395	{\r
396	uint32 i, lnt;\r
397	uint8 sign;\r
398	t_stat r;\r
399	\r
400	if (d == s) return SCPE_OK;\r
401	sign = M[s] & FLAG; /* get src sign */\r
402	r = fp_scan_mant (s, &lnt, NULL); /* get src length */\r
403	if (r != SCPE_OK) return r; /* error? */\r
404	s = ADDR_S (s, lnt - 1); /* hi order src */\r
405	M[d] = M[s] & (FLAG \| DIGIT); /* move 1st w flag */\r
406	M[s] = M[s] & ~FLAG; /* clr flag from src */\r
407	for (i = 1; i < lnt; i++) { /* move src to dst */\r
408	PP (d); /* incr ptrs */\r
409	PP (s);\r
410	M[d] = M[s] & DIGIT; /* move just digit */\r
411	}\r
412	PP (d); /* incr pointer */\r
413	while ((M[d] & FLAG) == 0) { /* until flag */\r
414	M[d] = 0; /* clear field */\r
415	PP (d);\r
416	}\r
417	if (sign) M[d] = FLAG; /* -? zero under sign */\r
418	return SCPE_OK;\r
419	}\r