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