\ fpout 05.2.27 NAB
\ Original by Ed
\  (tksw@NOSPAMtelstra.com)

needs core-ext
needs tools-ext
needs string

: REPRESENT
( c-addr u -- n flag1 flag2 )  ( F: r -- )
  2dup  [char] 0  fill
  precision >r  dup set-precision
  fpdissect  r> set-precision
  2dup or 0= >r  2swap  r>  if  1+ then
  swap >r >r  <# #s #>
  rot min  >r swap r>  move
  r> ( exp )  r> -1 = ( sign )  true ;

DECIMAL

module fpout

defer fpout-fdup
defer fpout-represent

CREATE FBUF  \ REPRESENT buffer
20 CHARS ALLOT \ set this to your maximum PRECISION

0 VALUE BS# \ buffer size
0 VALUE EX#  \ exponent
0 VALUE SN#  \ sign
\ exponent factor  1=FS. 3=FE.
0 VALUE EF#
\ +n  places right of decimal point
0 VALUE PL#
\ -1  compact display

: (F0)  ( exp -- offset exp' )
  S>D EF# FM/MOD EF# * ;

: (F1)  ( F: r -- ) ( places -- c-addr u flag )
  TO PL#  PRECISION TO BS#
  fpout-FDUP FBUF BS#
  fpout-REPRESENT NIP AND ( exp=0 on err )
  PL# 0< IF  DROP PRECISION  ELSE  EF# 0> IF
  1- (F0) DROP 1+  THEN  PL# +  THEN  DUP >R ( size )
  PRECISION MIN 1 MAX TO BS#  FBUF BS# fpout-REPRESENT  DUP
  R> 0= AND ( no err & size=0 ) FBUF C@ [CHAR] 4 > AND
  IF ( round ) [CHAR] 1 FBUF C!  ROT 1+ ROT ROT  THEN
  >R  TO SN#  1- TO EX#  FBUF BS# -TRAILING  R> <# ;

: (F2)  ( exp -- )
  PL# 0< >R  DUP ABS S>D  R@ 0= IF # ( # ) THEN
  #S 2DROP  DUP SIGN  0< R> OR 0= IF [CHAR] + HOLD THEN
  [CHAR] E HOLD ;

: (F3)  ( c-addr u -- )
  0 MAX  BEGIN  DUP  WHILE  1- 2DUP CHARS + C@ HOLD
  REPEAT 2DROP ;

: (F4)  ( n -- )
  0 MAX 0 ?DO [CHAR] 0 HOLD LOOP ;

: (F5)  ( -- )
  SN# SIGN  0 0 #> ;

: (F6)  ( c-addr u1 -- c-addr u2 )
  PL# 0< IF
    BEGIN  DUP WHILE  1- 2DUP CHARS +
    C@ [CHAR] 0 -  UNTIL  1+  THEN
  THEN ;

: (F7)  ( n -- n n | n pl# )
   PL# 0< IF  DUP  ELSE  PL#  THEN ;

: (F8)  ( c-addr u n -- )
  >R (F6)  R@ +
  (F7) OVER - (F4)     \ trailing 0's
  (F7) MIN  R@ - (F3)  \ fraction
  R> (F7) MIN (F4)     \ leading 0's
  [CHAR] . HOLD ;

: (F9)  ( c-addr u n -- )
  >R 2DUP R@ MIN 2SWAP R> /STRING  0 (F8) (F3) ;

: (FA)  ( F: r -- ) ( n factor -- c-addr u )
  TO EF# (F1) IF  EX# (F0) (F2) 1+ (F9) (F5)  THEN ;

: (FB)  ( c-addr u u2 -- )
  OVER - SPACES TYPE ;

public:

: output-is-f
  ['] fdup is fpout-fdup
  ['] represent is fpout-represent ;

output-is-f

: (FS.)  ( F: r -- ) ( n -- c-addr u )
  1 (FA) ;

: FS.R  ( F: r -- ) ( n u -- )
  >R (FS.) R> (FB) ;

: FS.  ( F: r -- )
  -1 0 FS.R SPACE ;

: (FE.)  ( F: r -- ) ( n -- c-addr u )
  3 (FA) ;

: FE.R   ( F: r -- ) ( n u -- )
  >R (FE.) R> (FB) ;

: FE.  ( F: r -- )
  -1 0 FE.R SPACE ;

: (F.)  ( F: r -- ) ( n -- c-addr u )
  0 TO EF#  (F1) IF
    EX# 1+ DUP PRECISION > IF
       FBUF 0 ( dummy ) 0 (F8)
       PRECISION - (F4) (F3)
    ELSE
      DUP 0> IF
        (F9)
      ELSE
        ABS (F8) 1 (F4)
      THEN
    THEN (F5)
  THEN ;

: F.R   ( F: r -- ) ( n u -- )
  >R (F.) R> (FB) ;

: F.  ( F: r -- )
  -1 0 F.R SPACE ;

: (G.)  ( F: r -- ) ( n -- c-addr u )
  >R FDUP -1 (F1) DROP 2DROP  R>  EX# -4 6 WITHIN
  IF  (F.)  ELSE  (FS.)  THEN ;

: G.R   ( F: r -- ) ( n u -- )
  >R (G.) R> (FB) ;

: G.  ( F: r -- )
  -1 0 G.R SPACE ;

end-module
