1 /* i1620_fp.c: IBM 1620 floating point simulator
3 Copyright (c) 2002-2008, Robert M. Supnik
5 Permission is hereby granted, free of charge, to any person obtaining a
6 copy of this software and associated documentation files (the "Software"),
7 to deal in the Software without restriction, including without limitation
8 the rights to use, copy, modify, merge, publish, distribute, sublicense,
9 and/or sell copies of the Software, and to permit persons to whom the
10 Software is furnished to do so, subject to the following conditions:
12 The above copyright notice and this permission notice shall be included in
13 all copies or substantial portions of the Software.
15 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
18 ROBERT M SUPNIK BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19 IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20 CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22 Except as contained in this notice, the name of Robert M Supnik shall not be
23 used in advertising or otherwise to promote the sale, use or other dealings
24 in this Software without prior written authorization from Robert M Supnik.
26 The IBM 1620 uses a variable length floating point format, with a fixed
27 two digit decimal exponent and a variable length decimal mantissa:
32 where S represents flag bits if the mantissa or exponent are negative.
34 31-May-2008 RMS Fixed add_field call (found by Peter Schorn)
37 #include "i1620_defs.h"
39 #define FP_LMAX 100 /* max fp mant lnt */
40 #define FP_EMAX 99 /* max fp exponent */
42 /* Unpacked floating point operand */
45 int32 sign
; /* 0 => +, 1 => - */
46 int32 exp
; /* binary exponent */
47 uint32 lnt
; /* mantissa length */
48 uint32 addr
; /* mantissa addr */
49 uint32 zero
; /* 0 => nz, 1 => zero */
52 extern uint8 M
[MAXMEMSIZE
]; /* main memory */
53 extern uint8 ind
[NUM_IND
]; /* indicators */
56 t_stat
fp_scan_mant (uint32 ad
, uint32
*lnt
, uint32
*zro
);
57 t_stat
fp_zero (FPA
*fp
);
59 extern t_stat
xmt_field (uint32 d
, uint32 s
, uint32 skp
);
60 extern t_stat
add_field (uint32 d
, uint32 s
, t_bool sub
, t_bool sto
, uint32 skp
, int32
*sta
);
61 extern t_stat
mul_field (uint32 d
, uint32 s
);
62 extern t_stat
xmt_divd (uint32 d
, uint32 s
);
63 extern t_stat
div_field (uint32 dvd
, uint32 dvr
, int32
*ez
);
65 /* Unpack and validate a floating point argument */
67 t_stat
fp_unpack (uint32 ad
, FPA
*fp
)
71 esign
= M
[ad
] & FLAG
; /* get exp sign */
72 d0
= M
[ad
] & DIGIT
; /* get exp lo digit */
74 if ((M
[ad
] & FLAG
) == 0) return STOP_FPMF
; /* no flag on hi exp? */
75 d1
= M
[ad
] & DIGIT
; /* get exp hi digit */
77 fp
->addr
= ad
; /* save mant addr */
78 if (BAD_DIGIT (d1
) || BAD_DIGIT (d0
)) return STOP_INVDIG
; /* exp bad dig? */
79 fp
->exp
= ((d1
* 10) + d0
) * (esign
? -1: 1); /* convert exponent */
80 fp
->sign
= (M
[ad
] & FLAG
)? 1: 0; /* get mantissa sign */
81 return fp_scan_mant (fp
->addr
, &(fp
->lnt
), &(fp
->zero
));
84 /* Unpack and validate source and destination arguments */
86 t_stat
fp_unpack_two (uint32 dad
, uint32 sad
, FPA
*dfp
, FPA
*sfp
)
90 if ((r
= fp_unpack (dad
, dfp
)) != SCPE_OK
) return r
; /* unpack dst */
91 if ((r
= fp_unpack (sad
, sfp
)) != SCPE_OK
) return r
; /* unpack src */
92 if (sfp
->lnt
!= dfp
->lnt
) return STOP_FPUNL
; /* lnts must be equal */
96 /* Pack floating point result */
98 t_stat
fp_pack (FPA
*fp
)
103 e
= (fp
->exp
>= 0)? fp
->exp
: -fp
->exp
; /* get |exp| */
104 if (e
> FP_EMAX
) { /* too big? */
105 ind
[IN_EXPCHK
] = 1; /* set indicator */
106 if (fp
->exp
< 0) return fp_zero (fp
); /* underflow? */
108 for (i
= 0; i
< fp
->lnt
; i
++) { /* mant = 99...99 */
109 M
[mad
] = (M
[mad
] & FLAG
) | 9;
112 e
= FP_EMAX
; /* cap at max */
114 M
[ADDR_A (fp
->addr
, 1)] = (e
/ 10) | FLAG
; /* high exp digit */
115 M
[ADDR_A (fp
->addr
, 2)] = (e
% 10) | /* low exp digit */
116 ((fp
->exp
< 0)? FLAG
: 0);
120 /* Shift mantissa right n positions */
122 void fp_rsh (FPA
*fp
, uint32 n
)
126 if (n
== 0) return; /* zero? done */
127 sad
= ADDR_S (fp
->addr
, n
); /* src = addr - n */
128 dad
= fp
->addr
; /* dst = n */
129 for (i
= 0; i
< fp
->lnt
; i
++) { /* move digits */
130 if (i
>= (fp
->lnt
- n
)) M
[dad
] = M
[dad
] & FLAG
;
131 else M
[dad
] = (M
[dad
] & FLAG
) | (M
[sad
] & DIGIT
);
138 /* Shift mantissa left 1 position */
140 void fp_lsh_1 (FPA
*fp
)
144 mad
= ADDR_S (fp
->addr
, fp
->lnt
- 1); /* hi order digit */
145 for (i
= 0; i
< (fp
->lnt
- 1); i
++) { /* move lnt-1 digits */
146 nxt
= ADDR_A (mad
, 1);
147 M
[mad
] = (M
[mad
] & FLAG
) | (M
[nxt
] & DIGIT
);
150 M
[mad
] = M
[mad
] & FLAG
; /* clear last digit */
154 /* Clear floating point number */
156 t_stat
fp_zero (FPA
*fp
)
158 uint32 i
, mad
= fp
->addr
;
160 for (i
= 0; i
< fp
->lnt
; i
++) { /* clear mantissa */
161 M
[mad
] = (i
? M
[mad
] & FLAG
: 0); /* clear sign bit */
164 M
[ADDR_A (fp
->addr
, 1)] = FLAG
+ 9; /* exp = -99 */
165 M
[ADDR_A (fp
->addr
, 2)] = FLAG
+ 9; /* exp = -99 */
166 ind
[IN_EZ
] = 1; /* result = 0 */
171 /* Scan floating point mantissa for length and (optionally) zero */
173 t_stat
fp_scan_mant (uint32 ad
, uint32
*lnt
, uint32
*zro
)
177 z
= 1; /* assume zero */
178 for (l
= 1; l
<= FP_LMAX
; l
++) { /* scan to get length */
179 d
= M
[ad
] & DIGIT
; /* get mant digit */
180 if (d
) z
= 0; /* non-zero? */
181 if ((l
!= 1) && (M
[ad
] & FLAG
)) { /* flag past first dig? */
182 *lnt
= l
; /* set returns */
188 return STOP_FPLNT
; /* too long */
191 /* Copy floating point mantissa */
193 void fp_copy_mant (uint32 d
, uint32 s
, uint32 l
)
197 if (ind
[IN_HP
]) M
[d
] = M
[d
] & ~FLAG
; /* clr/set sign */
198 else M
[d
] = M
[d
] | FLAG
;
199 for (i
= 0; i
< l
; i
++) { /* copy src */
200 M
[d
] = (M
[d
] & FLAG
) | (M
[s
] & DIGIT
); /* preserve flags */
207 /* Compare floating point mantissa */
209 int32
fp_comp_mant (uint32 d
, uint32 s
, uint32 l
)
213 d
= ADDR_S (d
, l
- 1); /* start of mantissa */
214 s
= ADDR_S (s
, l
- 1);
215 for (i
= 0; i
< l
; i
++) { /* compare dst:src */
216 dd
= M
[d
] & DIGIT
; /* get dst digit */
217 sd
= M
[s
] & DIGIT
; /* get src digit */
218 if (dd
> sd
) return 1; /* >? done */
219 if (dd
< sd
) return -1; /* <? done */
220 PP (d
); /* =? continue */
223 return 0; /* done, equal */
226 /* Floating point add */
228 t_stat
fp_add (uint32 d
, uint32 s
, t_bool sub
)
233 uint8 sav_src
[FP_LMAX
];
236 r
= fp_unpack_two (d
, s
, &dfp
, &sfp
); /* unpack operands */
237 if (r
!= SCPE_OK
) return r
; /* error? */
238 dif
= dfp
.exp
- sfp
.exp
; /* exp difference */
240 if (sfp
.zero
|| (dif
>= ((int32
) dfp
.lnt
))) { /* src = 0, or too small? */
241 if (dfp
.zero
) return fp_zero (&dfp
); /* res = dst, zero? */
242 ind
[IN_EZ
] = 0; /* res nz, set EZ, HP */
243 ind
[IN_HP
] = (dfp
.sign
== 0);
246 if (dfp
.zero
|| (dif
<= -((int32
) dfp
.lnt
))) { /* dst = 0, or too small? */
247 if (sfp
.zero
) return fp_zero (&dfp
); /* res = src, zero? */
248 r
= xmt_field (d
, s
, 3); /* copy src to dst */
249 ind
[IN_EZ
] = 0; /* res nz, set EZ, HP */
250 ind
[IN_HP
] = (dfp
.sign
== 0);
254 if (dif
> 0) { /* dst exp > src exp? */
255 sad
= sfp
.addr
; /* save src in save area */
256 for (i
= 0; i
< sfp
.lnt
; i
++) {
260 fp_rsh (&sfp
, dif
); /* denormalize src */
262 else if (dif
< 0) { /* dst exp < src exp? */
263 dfp
.exp
= sfp
.exp
; /* res exp = src exp */
264 fp_rsh (&dfp
, -dif
); /* denormalize dst */
266 r
= add_field (dfp
.addr
, sfp
.addr
, sub
, TRUE
, 0, &sta
); /* add mant, set EZ, HP */
267 if (dif
> 0) { /* src denormalized? */
268 sad
= sfp
.addr
; /* restore src from */
269 for (i
= 0; i
< sfp
.lnt
; i
++) { /* save area */
274 if (r
!= SCPE_OK
) return r
; /* add error? */
276 hi
= ADDR_S (dfp
.addr
, dfp
.lnt
- 1); /* addr of hi digit */
277 if (sta
== ADD_CARRY
) { /* carry out? */
278 fp_rsh (&dfp
, 1); /* shift mantissa */
279 M
[hi
] = FLAG
+ 1; /* high order 1 */
280 dfp
.exp
= dfp
.exp
+ 1;
281 ind
[IN_EZ
] = 0; /* not zero */
282 ind
[IN_HP
] = (dfp
.sign
== 0); /* set HP */
284 else if (ind
[IN_EZ
]) return fp_zero (&dfp
); /* result zero? */
286 while ((M
[hi
] & DIGIT
) == 0) { /* until normalized */
287 fp_lsh_1 (&dfp
); /* left shift */
288 dfp
.exp
= dfp
.exp
- 1; /* decr exponent */
292 return fp_pack (&dfp
); /* pack and exit */
295 /* Floating point multiply */
297 t_stat
fp_mul (uint32 d
, uint32 s
)
303 r
= fp_unpack_two (d
, s
, &dfp
, &sfp
); /* unpack operands */
304 if (r
!= SCPE_OK
) return r
; /* error? */
305 if (sfp
.zero
|| dfp
.zero
) return fp_zero (&dfp
); /* either zero? */
307 r
= mul_field (dfp
.addr
, sfp
.addr
); /* mul, set EZ, HP */
308 if (r
!= SCPE_OK
) return r
;
309 if (M
[ADDR_S (PROD_AREA_END
, 2 * dfp
.lnt
)] & DIGIT
) { /* hi prod dig set? */
310 pad
= ADDR_S (PROD_AREA_END
- 1, dfp
.lnt
); /* no normalization */
311 dfp
.exp
= dfp
.exp
+ sfp
.exp
; /* res exp = sum */
314 pad
= ADDR_S (PROD_AREA_END
, dfp
.lnt
); /* 'normalize' 1 */
315 dfp
.exp
= dfp
.exp
+ sfp
.exp
- 1; /* res exp = sum - 1 */
317 fp_copy_mant (dfp
.addr
, pad
, dfp
.lnt
); /* copy prod to mant */
319 return fp_pack (&dfp
); /* pack and exit */
322 /* Floating point divide */
324 t_stat
fp_div (uint32 d
, uint32 s
)
327 uint32 i
, pad
, a100ml
, a99ml
;
331 r
= fp_unpack_two (d
, s
, &dfp
, &sfp
); /* unpack operands */
332 if (r
!= SCPE_OK
) return r
; /* error? */
333 if (sfp
.zero
) { /* divide by zero? */
334 ind
[IN_OVF
] = 1; /* dead jim */
337 if (dfp
.zero
) return fp_zero (&dfp
); /* divide into zero? */
339 for (i
= 0; i
< PROD_AREA_LEN
; i
++) /* clear prod area */
340 M
[PROD_AREA
+ i
] = 0;
341 a100ml
= ADDR_S (PROD_AREA_END
, dfp
.lnt
); /* 100 - lnt */
342 a99ml
= ADDR_S (PROD_AREA_END
- 1, dfp
.lnt
); /* 99 - lnt */
343 if (fp_comp_mant (dfp
.addr
, sfp
.addr
, dfp
.lnt
) >= 0) { /* |Mdst| >= |Msrc|? */
345 dfp
.exp
= dfp
.exp
- sfp
.exp
+ 1; /* res exp = diff + 1 */
349 dfp
.exp
= dfp
.exp
- sfp
.exp
; /* res exp = diff */
351 r
= xmt_divd (pad
, dfp
.addr
); /* xmt dividend */
352 if (r
!= SCPE_OK
) return r
; /* error? */
353 r
= div_field (a100ml
, sfp
.addr
, &ez
); /* divide fractions */
354 if (r
!= SCPE_OK
) return r
; /* error? */
355 if (ez
) return fp_zero (&dfp
); /* result zero? */
357 ind
[IN_HP
] = ((dfp
.sign
^ sfp
.sign
) == 0); /* set res sign */
358 ind
[IN_EZ
] = 0; /* not zero */
359 fp_copy_mant (dfp
.addr
, a99ml
, dfp
.lnt
); /* copy result */
361 return fp_pack (&dfp
);
364 /* Floating shift right */
366 t_stat
fp_fsr (uint32 d
, uint32 s
)
371 if (d
== s
) return SCPE_OK
; /* no move? */
374 M
[d
] = (M
[d
] & FLAG
) | (M
[s
] & DIGIT
); /* move 1st wo flag */
376 MM (d
); /* decr ptrs */
378 t
= M
[d
] = M
[s
] & (FLAG
| DIGIT
); /* copy others */
379 if (cnt
++ > MEMSIZE
) return STOP_FWRAP
; /* (stop runaway) */
380 } while ((t
& FLAG
) == 0); /* until src flag */
384 MM (d
); /* decr pointer */
385 t
= M
[d
]; /* save old val */
386 M
[d
] = 0; /* zero field */
387 if (cnt
++ > MEMSIZE
) return STOP_FWRAP
; /* (stop runaway) */
388 } while ((t
& FLAG
) == 0); /* until dst flag */
392 /* Floating shift left - note that dst is addr of high order digit */
394 t_stat
fp_fsl (uint32 d
, uint32 s
)
400 if (d
== s
) return SCPE_OK
;
401 sign
= M
[s
] & FLAG
; /* get src sign */
402 r
= fp_scan_mant (s
, &lnt
, NULL
); /* get src length */
403 if (r
!= SCPE_OK
) return r
; /* error? */
404 s
= ADDR_S (s
, lnt
- 1); /* hi order src */
405 M
[d
] = M
[s
] & (FLAG
| DIGIT
); /* move 1st w flag */
406 M
[s
] = M
[s
] & ~FLAG
; /* clr flag from src */
407 for (i
= 1; i
< lnt
; i
++) { /* move src to dst */
408 PP (d
); /* incr ptrs */
410 M
[d
] = M
[s
] & DIGIT
; /* move just digit */
412 PP (d
); /* incr pointer */
413 while ((M
[d
] & FLAG
) == 0) { /* until flag */
414 M
[d
] = 0; /* clear field */
417 if (sign
) M
[d
] = FLAG
; /* -? zero under sign */