\ include lib/ansfloat.4th
[UNDEFINED] F. [IF]
[UNDEFINED] represent [IF] include lib/represnt.4th [THEN]
[UNDEFINED] within [IF] include lib/range.4th [THEN]
\ FPOUT.F version 3.4
\ A Forth floating point output words package
\ Main words:
\ Compact Formatted String
\ ------- --------- ------
\ FS. FS.R (FS.) Scientific
\ FE. FE.R (FE.) Engineering
\ F. F.R (F.) Fixed-point
\ G. G.R (G.) General
\ FDP ( -- a-addr )
\ A variable controlling decimal point display. If zero
\ then trailing decimal points are not shown. If non-zero
\ (default state) the decimal point is always displayed.
\ FECHAR ( -- a-addr )
\ A variable containing the output character used to
\ indicate the exponent. Default is 'E'.
\ FEDIGITS ( -- a-addr )
\ A variable containing the minimum number of digits
\ output for the exponent. Must be 2 or more. Default
\ is 2. Does not affect compact modes.
\ Notes:
\ Display words that specify the number of places after
\ the decimal point may use the value -1 to force compact
\ mode. Compact mode displays all significant digits
\ with redundant zeros and signs removed. FS. FE. F. G.
\ are displayed in compact mode.
\ The character string returned by (FS.) (FE.) (F.) (G.)
\ resides in the pictured-numeric output area.
\ An ambiguous condition exists if: BASE is not decimal;
\ character string exceeds pictured-numeric output area;
\ PRECISION is set greater than MAX-FLOAT-DIGITS.
\ For use with separate or common stack floating point
\ Forth models.
\ This code is PUBLIC DOMAIN. Use at your own risk.
\ *****************************************************
\ This version of FPOUT requires REPRESENT conform to
\ the specification proposed here:
\ ftp://ftp.taygeta.com/pub/Forth/Applications/ANS/
\ Represent_21.txt (2008-01-23)
\ If your Forth does not have a compliant REPRESENT
\ then use FPOUT v2.2 instead.
\ *****************************************************
\ History:
\ v3.1 13-Nov-06 es Demo for REPRESENT proposal.
\ v3.2 05-Jun-07 es Changed default to trailing
\ decimal point on.
\ v3.3 19-Nov-07 es Add FECHAR FEDIGITS. Fix zero
\ sign in (F.) F.R
\ v3.4 23-Jan-08 es Updated to REPRESENT spec 2.1
\ Stuff changed for 4tH:
\ S>D replaced in (f2) and (f4)
\ <# #> etc replaced with doubles version
\ (f9) reworked to eliminate '94 WHILE
\ NEGATE added for ANS style flag in (f3) and (G.)
\ Compensate Fig-style SIGN
\ Loading FPOUT v3.4 23-Jan-08
[DECIMAL]
\ Compile application
2 array FDP \ CREATE FDP 2 CELLS ALLOT
VARIABLE FECHAR
VARIABLE FEDIGITS
\ ****************** USER OPTIONS *******************
1 FDP ! \ trailing decimal point control
2 FEDIGITS ! \ minimum exponent digits
CHAR E FECHAR ! \ output character for exponent
\ *****************************************************
maxdigits CHARS string fbuf
0 VALUE ex# \ exponent
0 VALUE sn# \ sign
0 VALUE ef# \ exponent factor 1=FS. 3=FE.
0 VALUE pl# \ +n places right of decimal point
\ -1 compact display
\ get exponent, sign, flag2
: (f1) ( F: r -- r ) ( -- exp sign flag2 )
FDUP fbuf PRECISION REPRESENT ;
\ apply exponent factor
: (f2) ( exp -- offset exp2 )
DUP ABS U>D ROT 0< IF DNEGATE THEN ef# FM/MOD ef# * ;
\ float to ascii
: (f3) ( F: r -- ) ( places -- c-addr u flag )
TO pl# (f1) NIP negate AND ( exp & flag2 )
pl# 0< IF
DROP PRECISION
ELSE
ef# 0> IF 1- (f2) DROP 1+ THEN pl# +
THEN PRECISION MIN fbuf SWAP REPRESENT >R
TO sn# TO ex# fbuf maxdigits -TRAILING R> <d# ;
\ insert exponent
: (f4) ( exp -- )
DUP DUP ABS U>D pl# 0< 0= DUP >R IF FEDIGITS @
1 DO D# LOOP THEN D#S DSIGN 2DROP 0< 0=
R> AND IF [CHAR] + DHOLD THEN FECHAR @ DHOLD ;
\ insert digit and update flag
: (f5) ( char -- )
DHOLD 1 FDP CELL+ ! ;
\ insert string
: (f6) ( c-addr u -- )
0 MAX BEGIN DUP WHILE 1- 2DUP CHARS + C@ (f5)
REPEAT 2DROP ;
\ insert '0's
: (f7) ( n -- )
0 MAX 0 ?DO [CHAR] 0 (f5) LOOP ;
\ insert sign
: (f8) ( -- )
sn# IF [CHAR] - DHOLD THEN 0. D#> ;
\ trim trailing '0's
: (f9) ( c-addr u1 -- c-addr u2 )
pl# 0< IF
BEGIN DUP 0= IF EXIT THEN
1- 2DUP CHARS +
C@ [CHAR] 0 - UNTIL 1+
THEN ;
: (fa) ( n -- n n|pl# )
pl# 0< IF DUP ELSE pl# THEN ;
\ insert fraction string n places right of dec. point
: (fb) ( c-addr u n -- )
0 FDP CELL+ !
>R (f9) R@ +
(fa) OVER - (f7) \ trailing 0's
(fa) MIN R@ - (f6) \ fraction
R> (fa) MIN (f7) \ leading 0's
FDP 2@ OR IF
[CHAR] . DHOLD
THEN ;
\ split string into integer/fraction parts at n and insert
: (fc) ( c-addr u n -- )
>R 2DUP R@ MIN 2SWAP R> /STRING 0 (fb) (f6) ;
\ exponent form
: (fd) ( F: r -- ) ( n factor -- c-addr u )
TO ef# (f3) IF ex# 1- (f2) (f4) 1+ (fc) (f8) THEN ;
\ display c-addr u right-justified in field width u2
: (fe) ( c-addr u u2 -- )
OVER - SPACES TYPE ;
\ These are the main words
\ Convert real number r to a string c-addr u in scientific
\ notation with n places right of the decimal point.
: (FS.) ( F: r -- ) ( n -- c-addr u )
1 (fd) ;
\ Display real number r in scientific notation right-
\ justified in a field width u with n places right of the
\ decimal point.
: FS.R ( F: r -- ) ( n u -- )
>R (FS.) R> (fe) ;
\ Display real number r in scientific notation followed by
\ a space.
: FS. ( F: r -- )
-1 0 FS.R SPACE ;
\ Convert real number r to a string c-addr u in engineering
\ notation with n places right of the decimal point.
: (FE.) ( F: r -- ) ( n -- c-addr u )
3 (fd) ;
\ Display real number r in engineering notation right-
\ justified in a field width u with n places right of the
\ decimal point.
: FE.R ( F: r -- ) ( n u -- )
>R (FE.) R> (fe) ;
\ Display real number r in engineering notation followed
\ by a space.
: FE. ( F: r -- )
-1 0 FE.R SPACE ;
\ Convert real number r to string c-addr u in fixed-point
\ notation with n places right of the decimal point.
: (F.) ( F: r -- ) ( n -- c-addr u )
0 TO ef# (f3) IF
ex# DUP maxdigits > IF
fbuf 0 ( dummy ) 0 (fb)
maxdigits - (f7) (f6)
ELSE
DUP 0> IF
(fc)
ELSE
ABS (fb) 1 (f7)
THEN
THEN (f8)
THEN ;
\ Display real number r in fixed-point notation right-
\ justified in a field width u with n places right of the
\ decimal point.
: F.R ( F: r -- ) ( n u -- )
>R (F.) R> (fe) ;
\ Display real number r in fixed-point notation followed
\ by a space.
: F. ( F: r -- )
-1 0 F.R SPACE ;
\ Convert real number r to string c-addr u with n places
\ right of the decimal point. Fixed-point is used if the
\ exponent is in the range -4 to 5 otherwise use scientific
\ notation.
: (G.) ( F: r -- ) ( n -- c-addr u )
>R (f1) NIP negate AND -3 7 WITHIN
R> SWAP IF (F.) ELSE (FS.) THEN ;
\ Display real number r right-justified in a field width u
\ with n places right of the decimal point. Fixed-point
\ is used if the exponent is in the range -4 to 5 otherwise
\ use scientific notation.
: G.R ( F: r -- ) ( n u -- )
>R (G.) R> (fe) ;
\ Display real number r followed by a space. Fixed-point
\ is used if the exponent is in the range -4 to 5 otherwise
\ use scientific notation.
: G. ( F: r -- )
-1 0 G.R SPACE ;
\ Decimal point always displayed. Use 0 FDP !
\ to disable trailing decimal point.
[DEFINED] 4tH# [IF]
hide (f1)
hide (f2)
hide (f3)
hide (f4)
hide (f5)
hide (f6)
hide (f7)
hide (f8)
hide (f9)
hide (fa)
hide (fb)
hide (fc)
hide (fd)
hide (fe)
hide ex#
hide sn#
hide ef#
hide pl#
hide fbuf
[THEN]
[THEN]
\ ****************** DEMONSTRATION ******************
false [IF]
CR .( Loading demo words... ) CR
CR .( TEST1 formatted, n decimal places )
CR .( TEST2 compact & right-justified )
CR .( TEST3 display FS. )
CR .( TEST4 display F. )
CR .( TEST5 display G. )
CR .( TEST6 display 8087 non-numbers ) CR
CR .( 'n PLACES' sets decimal places for TEST1. )
CR .( SET-PRECISION sets maximum significant )
CR .( digits displayable. )
CR CR
20 FLOAT [*] ARRAY f-array
: init ( r n -- ) >R S>FLOAT R> FLOATS f-array + F! ;
fclear
S" 1.23456E-16" 0 init
S" 1.23456E-11" 1 init
S" 1.23456E-7" 2 init
S" 1.23456E-6" 3 init
S" 1.23456E-5" 4 init
S" 1.23456E-4" 5 init
S" 1.23456E-3" 6 init
S" 1.23456E-2" 7 init
S" 1.23456E-1" 8 init
S" 0.E0" 9 init
S" 1.23456E+0" 10 init
S" 1.23456E+1" 11 init
S" 1.23456E+2" 12 init
S" 1.23456E+3" 13 init
S" 1.23456E+4" 14 init
S" 1.23456E+5" 15 init
S" 1.23456E+6" 16 init
S" 1.23456E+7" 17 init
S" 1.23456E+11" 18 init
S" 1.23456E+16" 19 init
: do-it ( xt -- )
( #numbers) 20 0 DO
f-array ( FALIGNED) I FLOATS +
OVER >R F@ CR R> EXECUTE
LOOP DROP ;
( 2VARIABLE) 2 ARRAY (dw)
: d.w ( -- dec.places width ) (dw) 2@ ;
: PLACES ( places -- ) d.w SWAP DROP (dw) 2! ;
: PWIDTH ( width -- ) d.w DROP SWAP (dw) 2! ;
5 PLACES 19 PWIDTH
: (t1) ( r -- )
FDUP d.w FS.R FDUP d.w F.R FDUP d.w G.R d.w FE.R ;
: TEST1 ( -- )
CR ." TEST1 right-justified, formatted ("
d.w DROP 0 .R ." decimal places)" CR
['] (t1) do-it CR ;
: (t2) ( r -- )
FDUP -1 d.w NIP FS.R FDUP -1 d.w NIP F.R
FDUP -1 d.w NIP G.R -1 d.w NIP FE.R ;
: TEST2 ( -- )
CR ." TEST2 right-justified, compact" CR
['] (t2) do-it CR ;
: TEST3 ( -- )
CR ." TEST3 FS."
CR ['] FS. do-it CR ;
: TEST4 ( -- )
CR ." TEST4 F."
CR ['] F. do-it CR ;
: TEST5 ( -- )
CR ." TEST5 G."
CR ['] G. do-it CR ;
: TEST6 ( -- )
PRECISION >R 1 SET-PRECISION
CR ." TEST6 8087 non-numbers PRECISION = 1" CR
CR 1 S>F 0 S>F F/ FDUP G.
CR FNEGATE G.
CR 0 S>F 0 S>F F/ FDUP G.
CR FNEGATE G.
CR
R> SET-PRECISION ;
: anykey ( -- )
cr ." Press ENTER" refill drop
;
: TEST0
CR ." TEST0 Show REPRESENT bug" CR
S" 9.9e" 2DUP CR TYPE ." 0 0 f.r "
S>FLOAT 0 0 F.R ." {should display 10. }" CR ;
fclear
6 set-precision
test0 anykey
test1 anykey
test2 anykey
test3 anykey
test4 anykey
test5 anykey
[THEN]
|
