GForth's F.RDP modified to use the REPRESENT from DX-Forth and VFX.

\ GForth's F.RDP modified to use the REPRESENT from DX-Forth and VFX.
\
\ No attempt was made to make it pretty - just the basic patches to
\ remove code that was no longer needed and any additions necessary
\ to make the GForth's test run.
\
\ dxf 2026-09-29

true \ enable/disable patch

dup constant ***ADD***
0=  constant ***REMOVE***

***ADD*** [IF]

MAX-PRECISION CONSTANT mc#  \ min buffer size for DXF/VFX REPRESENT

\ Define Gforth words we don't necessarily have...

: endif  postpone then ; immediate
: \G  postpone \ ; immediate

: 2tuck  2swap 2over ;
: >=  < 0= ;
: u>=  u< 0= ;
: bounds over + swap ;

variable holdptr
variable holdend

create holdbuf 100 chars allot

here constant holdbuf-end

: hold    ( char -- ) \ core
    -1 chars holdptr +!
    holdptr @ dup holdbuf u< -17 and throw
    c! ;

: <# ( -- ) \ core	less-number-sign
    holdbuf-end dup holdptr ! holdend ! ;  <#

: #> ( xd -- addr u )
    2drop holdptr @ holdend @ over - ;

: <<# ( -- )
    holdend @ holdptr @ - hold
    holdptr @ holdend ! ;

: #>> ( -- )
    holdend @ dup holdbuf-end u>= -11 and throw
    count chars bounds holdptr ! holdend ! ;

: sign ( n -- )  0< IF  [char] - hold  THEN ;

: # ( ud1 -- ud2 )
\    base @ ud/mod
\    rot 9 over <  IF [ char A char 9 - 1- ] Literal +  THEN
\    [char] 0 + hold ;
    base @ >r 0 r@ um/mod r> swap >r um/mod r>
    rot 9 over < if 7 + then [char] 0 + hold ;

: #s ( ud -- 0 0 )  BEGIN # 2dup or 0= UNTIL ;

: f2* ( r1 -- r2 )  2.0e0 f* ;

[THEN]

\ f.rdp

: push-right ( c-addr u1 u2 cfill -- )
    \ move string at c-addr u1 right by u2 chars (without exceeding
    \ the original bound); fill the gap with cfill
    >r over min dup >r rot dup >r ( u1 u2 c-addr R: cfill u2 c-addr )
    dup 2swap /string cmove>
    r> r> r> fill ;

\ Gforth's version used locals.  For debugging, this was easier.

fvariable rf
0 value c-addr    0 value ur        0 value nd       0 value up
0 value um1       0 value nexp      0 value fsign    0 value befored
0 value beforez   0 value beforep   0 value explen   0 value mantlen

***ADD*** [IF]  0 value fixpt  [THEN]

: f>buf-rdp-try ( f: rf c-addr ur nd up um1 -- um2 )
    to um1  to up  to nd  to ur  to c-addr  rf f!
    \ um1 is the mantissa length to try, um2 is the actual mantissa length
    c-addr ur um1 /string [char] 0 fill
    rf f@ c-addr um1 represent if  to fsign  to nexp
	nd nexp + up >= up 0= or
	ur nd - 1- dup to beforep  fsign + nexp 0 max >= and
[ ***ADD*** ] [IF]  dup to fixpt  [THEN] if
	    \ fixed-point notation
	    c-addr ur beforep nexp - dup to befored  [char] 0 push-right
[ ***REMOVE*** ] [IF]
            befored 1+ ur >= if \ <=1 digit left, will be pushed out by '.'
                rf f@ fabs f2* 0.1e nd s>d d>f f** f> if \ round last digit
                    [char] 1 c-addr befored + 1- c!
                endif
            endif
[THEN]
	    c-addr beforep 1- befored min dup to beforez  0 max bl fill
	    fsign if
		[char] - c-addr beforez 1- 0 max + c!
	    endif
	    c-addr ur beforep /string 1 [char] . push-right
	    nexp nd +
	else \ exponential notation
	    c-addr ur 1 /string 1 [char] . push-right
	    fsign if
		c-addr ur 1 [char] - push-right
	    endif
	    nexp 1- s>d tuck dabs <<# #s rot sign [char] E hold #>  to explen
	    ur explen - 1- fsign +  to mantlen
	    mantlen 0< if \ exponent too large
		drop c-addr ur [char] * fill
	    else
		c-addr ur + 0 explen negate /string move
	    endif
	    #>> mantlen
	endif
    else \ inf or nan
        \ don't rely on REPRESENT result
        2drop
[ ***REMOVE*** ] [IF]
        rf f@ f0< if s" -Inf" else rf f@ f0>= if s" Inf" else s" NaN" endif endif
        c-addr ur rot umin dup >r move c-addr ur r> /string blank
[THEN]
        ur
    endif
[ ***ADD*** ] [IF]  fixpt 0= if  [THEN]
    1 max
[ ***ADD*** ] [IF]  then  [THEN]
    ur min ;

: f>buf-rdp ( rf c-addr +nr +nd +np -- ) \ gforth
\G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
\G rules and the meanings of @i{nr nd np} are the same as for
\G @code{f.rdp}.
    \ first, get the mantissa length, then convert for real.  The
    \ mantissa length is wrong in a few cases because of different
    \ rounding; In most cases this does not matter, because the
    \ mantissa is shorter than expected and the final digits are 0;
    \ but in a few cases the mantissa gets longer.  Then it is
    \ conceivable that you will see a result that is rounded too much.
    \ However, I have not been able to construct an example where this
    \ leads to an unexpected result.
    swap 0 max swap 0 max
    fdup 2over 2over 2 pick f>buf-rdp-try f>buf-rdp-try drop ;

: f>str-rdp ( rf +nr +nd +np -- c-addr nr ) \ gforth
\G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
\G rules and the meanings of @i{nr +nd np} are the same as for
\G @code{f.rdp}.  The result in in the pictured numeric output buffer
\G and will be destroyed by anything destroying that buffer.
    rot holdptr @ 1-
[ ***ADD*** ] [IF]  over mc# max chars -  [THEN]
    0 rot negate /string ( rf +nd np c-addr nr )
    over holdbuf u< -17 and throw
    2tuck 2>r f>buf-rdp 2r> ;

: f.rdp ( rf +nr +nd +np -- ) \ gforth
\G Print float @i{rf} formatted.  The total width of the output is
\G @i{nr}.  For fixed-point notation, the number of digits after the
\G decimal point is @i{+nd} and the minimum number of significant
\G digits is @i{np}.  @code{Set-precision} has no effect on
\G @code{f.rdp}.  Fixed-point notation is used if the number of
\G siginicant digits would be at least @i{np} and if the number of
\G digits before the decimal point would fit.  If fixed-point notation
\G is not used, exponential notation is used, and if that does not
\G fit, asterisks are printed.  We recommend using @i{nr}>=7 to avoid
\G the risk of numbers not fitting at all.  We recommend
\G @i{nr}>=@i{np}+5 to avoid cases where @code{f.rdp} switches to
\G exponential notation because fixed-point notation would have too
\G few significant digits, yet exponential notation offers fewer
\G significant digits.  We recommend @i{nr}>=@i{nd}+2, if you want to
\G have fixed-point notation for some numbers; the smaller the value
\G of @i{np}, the more cases are shown in fixed-point notation (cases
\G where few or no significant digits remain in fixed-point notation).
\G We recommend @i{np}>@i{nr}, if you want to have exponential
\G notation for all numbers.
    f>str-rdp type ;

1 [if]
: testx ( rf ur nd up -- )
    [char] | emit f.rdp ;

: test ( -- )
    -0.123456789123456789e-20
    40 0 ?do
	cr
	fdup 7 3 1 testx
	fdup 7 3 4 testx
	fdup 7 3 0 testx
	fdup 7 7 1 testx
	fdup 7 5 1 testx
	fdup 7 0 2 testx
	fdup 5 2 1 testx
	fdup 4 2 1 testx
	fdup 18 8 5 testx
	[char] | emit
	10e f*
    loop fdrop ;
[then]

1 [IF]

: (foo) ( r -- )
    cr 8 spaces
    fdup
    12 5 13 f.rdp
    10 spaces
    fdup
    8 5 0 f.rdp
    8 spaces
    7 0 0 f.rdp
;

: foo
  -1.23457e-8 (foo)
  -1.23457e (foo)
  0.9e (foo)
  0.4e (foo)
  0e 0e f/ (foo)
  -0e 0e f/ (foo)
  1e 0e f/ (foo)
  -1e 0e f/ (foo)
;

[THEN]

0 [IF]  \ test results

|-1.E-21|-1.E-21|  0.000|-1.E-21|-1.E-21|-1.E-21|*****|****|-1.23456789123E-21|
|-1.E-20|-1.E-20|  0.000|-1.E-20|-1.E-20|-1.E-20|*****|****|-1.23456789123E-20|
|-1.E-19|-1.E-19|  0.000|-1.E-19|-1.E-19|-1.E-19|*****|****|-1.23456789123E-19|
|-1.E-18|-1.E-18|  0.000|-1.E-18|-1.E-18|-1.E-18|*****|****|-1.23456789123E-18|
|-1.E-17|-1.E-17|  0.000|-1.E-17|-1.E-17|-1.E-17|*****|****|-1.23456789123E-17|
|-1.E-16|-1.E-16|  0.000|-1.E-16|-1.E-16|-1.E-16|*****|****|-1.23456789123E-16|
|-1.E-15|-1.E-15|  0.000|-1.E-15|-1.E-15|-1.E-15|*****|****|-1.23456789123E-15|
|-1.E-14|-1.E-14|  0.000|-1.E-14|-1.E-14|-1.E-14|*****|****|-1.23456789123E-14|
|-1.E-13|-1.E-13|  0.000|-1.E-13|-1.E-13|-1.E-13|*****|****|-1.23456789123E-13|
|-1.E-12|-1.E-12|  0.000|-1.E-12|-1.E-12|-1.E-12|*****|****|-1.23456789123E-12|
|-1.E-11|-1.E-11|  0.000|-1.E-11|-1.E-11|-1.E-11|*****|****|-1.23456789123E-11|
|-1.E-10|-1.E-10|  0.000|-1.E-10|-1.E-10|-1.E-10|*****|****|-1.23456789123E-10|
|-1.2E-9|-1.2E-9|  0.000|-1.2E-9|-1.2E-9|-1.2E-9|-1E-9|****|-1.234567891235E-9|
|-1.2E-8|-1.2E-8|  0.000|-1.2E-8|-1.2E-8|-1.2E-8|-1E-8|****|-1.234567891235E-8|
|-1.2E-7|-1.2E-7|  0.000|-1.2E-7|-1.2E-7|-1.2E-7|-1E-7|****|-1.234567891235E-7|
|-1.2E-6|-1.2E-6|  0.000|-1.2E-6|-1.2E-6|-1.2E-6|-1E-6|****|-1.234567891235E-6|
|-1.2E-5|-1.2E-5|  0.000|-1.2E-5|-.00001|-1.2E-5|-1E-5|****|-1.234567891235E-5|
|-1.2E-4|-1.2E-4|  0.000|-1.2E-4|-.00012|-1.2E-4|-1E-4|****|       -0.00012346|
| -0.001|-1.2E-3| -0.001|-1.2E-3|-.00123|-1.2E-3|-1E-3|****|       -0.00123457|
| -0.012|-1.2E-2| -0.012|-1.2E-2|-.01235|-1.2E-2|-0.01|-.01|       -0.01234568|
| -0.123|-1.2E-1| -0.123|-1.2E-1|-.12346|-1.2E-1|-0.12|-.12|       -0.12345679|
| -1.235| -1.235| -1.235|-1.23E0|-1.23E0|-1.23E0|-1.23|-1E0|       -1.23456789|
|-12.346|-12.346|-12.346|-1.23E1|-1.23E1|   -12.|-1.E1|-1E1|      -12.34567891|
|-1.23E2|-1.23E2|-1.23E2|-1.23E2|-1.23E2|  -123.|-1.E2|-1E2|     -123.45678912|
|-1.23E3|-1.23E3|-1.23E3|-1.23E3|-1.23E3| -1235.|-1.E3|-1E3|    -1234.56789123|
|-1.23E4|-1.23E4|-1.23E4|-1.23E4|-1.23E4|-12346.|-1.E4|-1E4|   -12345.67891235|
|-1.23E5|-1.23E5|-1.23E5|-1.23E5|-1.23E5|-1.23E5|-1.E5|-1E5|  -123456.78912346|
|-1.23E6|-1.23E6|-1.23E6|-1.23E6|-1.23E6|-1.23E6|-1.E6|-1E6| -1234567.89123457|
|-1.23E7|-1.23E7|-1.23E7|-1.23E7|-1.23E7|-1.23E7|-1.E7|-1E7|-12345678.91234570|
|-1.23E8|-1.23E8|-1.23E8|-1.23E8|-1.23E8|-1.23E8|-1.E8|-1E8|-1.2345678912346E8|
|-1.23E9|-1.23E9|-1.23E9|-1.23E9|-1.23E9|-1.23E9|-1.E9|-1E9|-1.2345678912346E9|
|-1.2E10|-1.2E10|-1.2E10|-1.2E10|-1.2E10|-1.2E10|-1E10|****|-1.234567891235E10|
|-1.2E11|-1.2E11|-1.2E11|-1.2E11|-1.2E11|-1.2E11|-1E11|****|-1.234567891235E11|
|-1.2E12|-1.2E12|-1.2E12|-1.2E12|-1.2E12|-1.2E12|-1E12|****|-1.234567891235E12|
|-1.2E13|-1.2E13|-1.2E13|-1.2E13|-1.2E13|-1.2E13|-1E13|****|-1.234567891235E13|
|-1.2E14|-1.2E14|-1.2E14|-1.2E14|-1.2E14|-1.2E14|-1E14|****|-1.234567891235E14|
|-1.2E15|-1.2E15|-1.2E15|-1.2E15|-1.2E15|-1.2E15|-1E15|****|-1.234567891235E15|
|-1.2E16|-1.2E16|-1.2E16|-1.2E16|-1.2E16|-1.2E16|-1E16|****|-1.234567891235E16|
|-1.2E17|-1.2E17|-1.2E17|-1.2E17|-1.2E17|-1.2E17|-1E17|****|-1.234567891235E17|
|-1.2E18|-1.2E18|-1.2E18|-1.2E18|-1.2E18|-1.2E18|-1E18|****|-1.234567891235E18| ok


        -1.234570E-8           0.00000             0.
        -1.2345700E0          -1.23457            -1.
        9.0000000E-1           0.90000             1.
        4.0000000E-1           0.40000             0.
        -NAN                  -NAN            -NAN
        -NAN                  -NAN            -NAN
        +INF                  +INF            +INF
        -INF                  -INF            -INF    ok

[THEN]