I754.PET

In order to learn IEEE754 standard for Binary Floating-Point Arithmetic I
write this I754.PET. Then I add part of PETCALC.PET calculator. And
compiled with PET4TH to become I754.COM .

I754.PET:
-    has all constants for testing functions
-    has recomended functions like nextafter, logb, scalb

Hopefully this program can help you write floating-point routine.

I754.GLO is included in this file. I hope this can replace a text which I
have not written. The I754.PET source code is not included.

IEEE754 is being updated. And this program will also be updated from time
to time. Your comments would be appreciated.

Regards,
Petrus - PET4TH,
<petrusp@attglobal.net>
i754.pet
    ieee754 double extended
t!  ( x1 x2 x3 x4 x5 a-addr -- )
    store ten bytes at a-addr, little endian
t@  ( addr -- x1 x2 x3 x4 x5 )
    fetch ten bytes from a-addr, little endian
tdup  ( t -- t t )
    duplicate t, 80 bit integer
tdrop  ( t -- )
    drop t, 80 bit integer
t1+  ( t -- t+1 )
    increment t, 80 bit integer
t1-  ( t -- t-1 )
    decrement t, 80 bit integer
t<  ( t1 t2 -- flag )
    compare t, 80 bit integer, return true if t1 < t2
t=  ( t1 t2 -- flag )
    compare t, 80 bit integer, return true if equal
t>fb  ( r -- ) ( F: -- r )
    float bcd tos from integer tos
fm.  ( -- ) ( F: r -- )
    fs. math variant, +0.00000 00000 00000 00 E+0000
ftag  ( -- n )
    return tag, lsb for tos, npxenv temporary in stack
isempty  ( -- flag )
    return true if tos is empty, use npxenv temporary in stack
f2t  ( t1 -- t2 )
    float integer to integer for ordering float, unnormal not supported
t2f  ( t1 -- t2 )
    integer to float integer, back from f2t
copysign  ( F: r1 r2 -- r3 )
    return r1 with the sign of r2
scalb  ( F: r1 r2 -- r3 )
    return r1*2^r2 where r2 is integer (fscale)
logb  ( F: r1 -- r2 )
    return exponent (fxtract)
nextafter  ( F: r1 r2 -- r3 )
    return next representable r1 toward r2
finite  ( -- flag ) ( F: r -- )
    return true if -infy<r<+infy
isnan  ( -- flag ) ( F: r -- )
    return true if r is nan
unordered  ( -- flag ) ( F: r1 r2 -- )
    return true if r1 nan or n2 nan or both are nan
mask for class
    signm unsum qnanm snanm infym finnm subnm zerom
class  ( -- n ) ( F: r -- )
    return flag sign unsu qnan snan infy finn subn zero
fn.4  ( n5 -- )
    part of fn. to display sign
fn.3  ( n5 -- )
    part of fn. to display exponent
fn.2  ( n1 n2 n3 n4 -- )
    part of fn. to display fraction
fn.  ( F: r -- )
    display binary floating-point in hex
.class  ( F: r -- )
    display class using integer counter part
t.fraw  ( t -- )
    dump ten bytes integer in hex like .fraw
.fraw  ( F: r -- )
    dump floating point tos
f+qnanh  ( F: -- r )
    fconstant quiet nan         +1.FFFFFFFFFFFFFFFE +4000 
f+qnanl  ( F: -- r )
    fconstant quiet nan         +1.8000000000000000 +4000 
f+snanh  ( F: -- r )
    fconstant signalling nan    +1.7FFFFFFFFFFFFFFE +4000 
f+snanl  ( F: -- r )
    fconstant signalling nan    +1.0000000000000002 +4000 
+00+    ( F: -- r )
    fconstant +infinity         +1.0000000000000000 +4000 
f+finnh  ( F: -- r )
    fconstant finite nonzero    +1.FFFFFFFFFFFFFFFE +3FFF 
f+finnl  ( F: -- r )
    fconstant finite nonzero    +1.0000000000000000 -3FFE 
f+subnh  ( F: -- r )
    fconstant subnormal nonzero +0.FFFFFFFFFFFFFFFE -3FFF 
f+subnl  ( F: -- r )
    fconstant subnormal nonzero +0.0000000000000002 -3FFF 
f-subnl  ( F: -- r )
    fconstant subnormal nonzero -0.0000000000000002 -3FFF 
f-subnh  ( F: -- r )
    fconstant subnormal nonzero -0.FFFFFFFFFFFFFFFE -3FFF 
f-finnl  ( F: -- r )
    fconstant finite nonzero    -1.0000000000000000 -3FFE 
f-finnh  ( F: -- r )
    fconstant finite nonzero    -1.FFFFFFFFFFFFFFFE +3FFF 
-00-    ( F: -- r )
    fconstant +infinity         -1.0000000000000000 +4000 
f-snanl  ( F: -- r )
    fconstant signalling nan    -1.0000000000000002 +4000 
f-snanh  ( F: -- r )
    fconstant signalling nan    -1.7FFFFFFFFFFFFFFE +4000 
f-qnanl  ( F: -- r )
    fconstant quiet nan         -1.8000000000000000 +4000 
f-qnanh  ( F: -- r )
    fconstant quiet nan         -1.FFFFFFFFFFFFFFFE +4000 
.fc  ( F: r -- r )
    display fclass using ftos (tag)
tbcd>f  ( n1 n2 n3 n4 n5 -- ) ( F: -- r )
    convert bcd to float
fb+finnh  ( F: -- r )
    fconstant finite nonzero 99 99 99 99 99 99 99 99 99 - 00
fb+finnl ( F: -- r )
    fconstant finite nonzero 01 00 00 00 00 00 00 00 00 - 00
fb-finnl ( F: -- r )
    fconstant finite nonzero 01 00 00 00 00 00 00 00 00 - 80
fb-finnh  ( F: -- r )
    fconstant finite nonzero 99 99 99 99 99 99 99 99 99 - 80
eps  ( F: -- r )
    return calculated eps
ulp1  ( F: -- r )
    return calculated ulp1
beta  ( F: -- r )
    return calculated beta
testvector
    variable testvector
(test)
    display important fconstants, boundaries
testfn.  ( F: r -- )
    display fconstants class and binary in hex
testfm.  ( F: r -- )
    display fconstants class (using ftos, fxam) fm.
testf.  ( F: r -- )
    display fconstants class (using ftos, fxam) fm.
tprev
    tvariable for testf2t
testf2t  ( F: r -- )
    convert fconstants to integer and back
crwait
    cr and pause, use scrrow variable
f+sigh
    big significand
f+sigl
    small significand
testi754
    test floating-point arithmetic
ufs  ( n "<chars>ccc<char>" -- )
hidecursor
    hide cursor
showcursor
    show cursor
vms55
    double variable, keep time in 55ms unit
starttimer  ( -- )
    start counting
ms55go  ( ms55 -- flag )
    is ms55 milliseconds elapsed
fpickaddr  ( n -- addr )
    return npxst address of selected stack
fpicktag  ( n -- tag )
    return tag of selected tag of npxst
regm
    fvariable for memory
cmdline
    svariable 80, command line
stacklift
    variable, true for stack lift on first digit
epos
    variable, e position
menu
    variable, current menu
debugmode
    variable, true for debug
dispmode
    variable, display mode, 0 f.r 1 f. 2 fs. 3 fe. 4 fm.
decplace
    variable, # of decimal place
rpn_disp  ( F: r -- )
    display in selected mode
rpn_atdisp  ( x y -- ) ( F: r -- )
    cursor, blank and display in selected mode
n.  ( n -- )
    display 4 bits in one hex digit
b12.  ( n -- )
    display 12 bits in 3 hex digits
.npxst
    display calculator state and tos, line 16,17,18
rpn_ud
    backup, update and display npxst
rpn_m
    display memory
rpn_xraw
    display x raw from cmdline - input from keyboard, and in fm.
rpn_xreg
    display x reg, use f.r, and in fm.
clrscreen
    clear screen and display screen form
rpn_tos
    optionally display top of stack in debug mode, line 16,17,18
panelbs
    backspace processing
panelcr2
    use before recalling a number
panelcr
    enter processing, termination of digit entry
panelao
    use after an operation
fshell
    forth shell, one liner
paneleexp
    menu e: enter exponent
inkey  ( c-addr1 u1 c-addr2 u2 -- char )
    menu prompt line 22 and 23 display status, get char
panelchs
    menu h: change sign
panelinv
    menu i: inv or 1/x
panelrnd  ( F: r1 -- r2 )
    round according to decimal place
panelmain
    main menu
panelm@f
    fixed point, set # of decimal point
panelm@
    preference menu
panelma
    arithmetic menu
panelmc
    constant menu
panelmf
    functions menu
panelmk
    ieee754 constant menu
panelml
    ieee754 negative constant menu
panelmm+
    menu m+: add to memory
panelmm-
    menu ms: substract from memory
panelmmr
    menu mr: recall from memory
panelmms
    menu ms: store to memory
panelmmx
    menu mx: exchange m x
panelmm
    memory menu
panelms
    stack menu
panel
    display panel and accept command
main
    main word
