Revision 2014-05-31
\ FGOUT.F version 1.0
\
\ Output floating-point numbers in FORTRAN 'G' format
\
\ Main words:
\
\ (FG.) ( r n -- c-addr u )
\
\ Convert real number r to a string c-addr u with n digits
\ of precision. Fixed-point notation is used if the
\ exponent is in the range -1 to n otherwise use scientific
\ notation.
\
\ FG.R ( r n u -- )
\
\ Display real number r right-aligned in a field width u
\ with n digits of precision. Fixed-point notation is used
\ if the exponent is in the range -1 to n otherwise use
\ scientific notation.
\
\ Notes:
\
\ Output is of the form produced by FORTRAN edit descriptor
\ 1PGw.d
\
\ Two implementation strategies are provided. The default
\ method uses REPRESENT to build the output from scratch.
\ Alternatively if your system has (FS.) or equivalent
\ then string manipulation can be used to transform its
\ output into the required form.
\
\ For use with separate or common stack floating-point
\ Forth models. Uses the pictured numeric output buffer.
\
\ This code is PUBLIC DOMAIN. Use at your own risk.
\
FORTH DEFINITIONS DECIMAL
\ Tools
\ Display string c-addr u right-justified in a field of
\ width characters
: S.R ( c-addr u width -- )
OVER - SPACES TYPE ;
\ *******************************************************
\ Choose an implementation method 1=default, 0=alternate
\ *******************************************************
1 [IF] CR .( Compiling REPRESENT version )
\ This implementation is expected to function correctly with
\ most implementations of REPRESENT. Should yours be found
\ wanting, a basic REPRESENT implementation is available at
\ the DX-Forth website.
\ HOLD for strings
: SHOLD ( c-addr u -- )
BEGIN DUP WHILE 1- 2DUP CHARS + C@ HOLD REPEAT 2DROP ;
[UNDEFINED] MAX-PRECISION [IF]
S" MAX-FLOAT-DIGITS" ENVIRONMENT? 0= [IF]
CR .( MAX-FLOAT-DIGITS not found substituting: )
CR .( MAX-PRECISION = ) 15 DUP .
[THEN] CONSTANT MAX-PRECISION
[THEN]
S" REPRESENT-CHARS" ENVIRONMENT? 0= [IF]
MAX-PRECISION
[THEN] CONSTANT maxchars
CREATE buf maxchars CHARS ALLOT
: (mant) ( u prec -- )
OVER buf -ROT /STRING SHOLD
[CHAR] . HOLD buf SWAP SHOLD ;
\ Convert real number r to string c-addr u with n digits of
\ precision. Fixed-point notation is used if the exponent is
\ in the range -1 to n otherwise use scientific notation.
: (FG.) ( r n -- c-addr u )
MAX-PRECISION MIN 1 MAX >R
buf R@ REPRESENT <# IF
SWAP DUP 0 R@ 1+ WITHIN IF
S" " SHOLD R@ (mant) 0 0
ELSE
1- DUP ABS 0 # #S ROT
0< IF [CHAR] - ELSE [CHAR] + THEN HOLD
[CHAR] E HOLD 1 R@ (mant)
THEN ROT SIGN
ELSE
( S" " SHOLD ) buf maxchars -TRAILING SHOLD
THEN #> R> DROP ;
[ELSE] CR .( Compiling string manipulation version )
\ This implementation assumes the existence of a function:
\
\ (FS.) ( r n -- c-addr u )
\
\ Convert real number r to string c-addr u in scientific
\ notation with n places right of the decimal point.
\
\ whose output is in the form:
\
\ [-]x.xxxxxE+/-yy
\
\ The exponent character must be 'E' followed by a sign '+'
\ or '-'. If the number of mantissa/exponent digits is fixed
\ then the output will be aligned. If a decimal point is not
\ present then r is assumed to be non-finite and the string
\ is passed unchanged.
\ Split string at char
: SPLIT ( a u char -- a2 u2 a u-u2 )
>R 2DUP R> SCAN 2SWAP 2 PICK - ;
variable dpos
2variable estr
\ Convert real number r to string c-addr u with n digits of
\ precision. Fixed-point notation is used if the exponent is
\ in the range -1 to n otherwise use scientific notation.
: (FG.) ( r n -- c-addr u )
\ FDP @ FECHAR C@ 2>R 1 FDP ! [CHAR] E FECHAR C!
1 MAX 1- (FS.)
2DUP [CHAR] . SPLIT 2DROP DUP IF ( not NAN/INF)
[CHAR] E SPLIT >R dpos ! 2DUP estr 2! 1 /STRING
OVER C@ [CHAR] - = >R 1 /STRING
0 0 2SWAP >NUMBER 2DROP R> IF DNEGATE THEN D>S
DUP -1 R@ WITHIN IF
DUP >R dpos @ DUP R@ 0< IF 1- ELSE 1+ THEN SWAP
R@ ABS CHARS MOVE [CHAR] . dpos @ R> CHARS + C!
estr 2@ ( 1 /STRING ) BLANK
THEN R>
THEN 2DROP
\ 2R> FECHAR C! FDP !
;
[THEN]
\ Display real number r right-justified in a field width u
\ with n digits of precision. Fixed-point notation is used
\ if the exponent is in the range -1 to n otherwise use
\ scientific notation.
: FG.R ( r n u -- )
>R (FG.) R> S.R ;
\ Test the function
0 [IF]
3.14159265358979324E FCONSTANT pi
pi FNEGATE FCONSTANT -pi
VARIABLE prec 3 prec !
VARIABLE wid 15 wid !
: d.w ( -- prec width ) prec @ wid @ ;
: test ( -- )
CR d.w ." Width=" . ." Prec=" .
CR -pi 1E6 F* d.w FG.R
CR pi 1E5 F* d.w FG.R
CR -pi 1E4 F* d.w FG.R
CR pi 1E3 F* d.w FG.R
CR -pi 1E2 F* d.w FG.R
CR pi 1E1 F* d.w FG.R
CR -pi 1E0 F* d.w FG.R
CR 0.0E d.w FG.R
CR pi 1E-1 F* d.w FG.R
CR -pi 1E-2 F* d.w FG.R
\ CR 1.E 0.E F/ d.w FG.R ( +Infinity on 80x87)
\ CR 0.E 0.E F/ d.w FG.R ( -NaN on 80x87)
;
3 prec ! 15 wid ! test
6 prec ! 15 wid ! test
[THEN]
\ end
Width=15 Prec=3
-3.14E+06
3.14E+05
-3.14E+04
3.14E+03
-314.
31.4
-3.14
0.00
.314
-3.14E-02
+INF
-NAN
Width=15 Prec=6
-3.14159E+06
314159.
-31415.9
3141.59
-314.159
31.4159
-3.14159
0.00000
.314159
-3.14159E-02
+INF
-NAN
Top Home Forth
Page updated: 31 May 2014