\ float-ext 99.3.13 5:33 pm NAB
needs core-ext
: -frot ( F: r1 r2 r3 -- r3 r1 r2 )
frot frot ;
: F~ ( F: r1 r2 r3 -- ) ( -- flag )
fdup f0= if fdrop f- f0= exit then
0e fover f< if
-frot f- fabs fswap
else
fnegate -frot fover
fabs fover fabs f+ -frot
f- fabs -frot f*
then f< ;
: zeroes ( n -- )
0 ?do [char] 0 hold loop ;
variable fdigits
8 constant flen
: (point) [char] . hold ;
: #trailing0 ( c-addr u -- u1 )
over + 1- 0 rot rot do
i c@ [char] 0 = if 1+
else leave then
-1 +loop ;
24 value places
: set-places to places ;
: (f.) ( F: r -- ) ( -- c-addr u )
0 fdigits ! <# fpdissect
2swap swap >r dup 1 < if
places flen - 0 max dup fdigits !
zeroes
>r flen dup fdigits +! 0 do # loop
r> negate dup fdigits +! zeroes
(point) [char] 0 hold
else dup >r
flen - places max dup fdigits !
zeroes
flen r@ - 0 max dup fdigits +!
0 ?do # loop (point)
r> flen - 0 max zeroes #s
then r> sign #>
fdigits @ places - 0 max - ;
: F. ( F: r --)
(f.) 2dup #trailing0 - type space ;