Plan 9 from Bell Labs’s /usr/web/sources/contrib/fgb/root/sys/src/cmd/4th/lib/fpout.4th

Copyright © 2021 Plan 9 Foundation.
Distributed under the MIT License.
Download the Plan 9 distribution.


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

Bell Labs OSI certified Powered by Plan 9

(Return to Plan 9 Home Page)

Copyright © 2021 Plan 9 Foundation. All Rights Reserved.
Comments to [email protected].