I needed a high-level >FLOAT implementation. Looking around,
existing examples were found to be bulky. Few were fully
compliant with the Forth-94 spec.
So the challenge was to make a compliant >FLOAT ... and keep
code to a minimum. Below is one such attempt. Numeric
conversion is kept basic. Speed could be improved using tables
instead of calculating powers of 10 etc.
There is an equate STRICT. When set to FALSE it will compile
a shorter, somewhat less compliant, version.
I've included a syntax checker for >FLOAT. Those who already
have >FLOAT may wish to extract the checker and see how well
theirs performs.
The code is version 0.0 because it's only had limited testing.
Should anyone find bugs/mistakes, or see how it could be
shortened, post them.
I note Forth-94 requires floats processed by the text interpreter
to have a digit before a decimal point i.e. 0.9E is legal, but .9E
isn't. This rule seems unnecessary, adding complication and code.
It also contradicts what the FVG standard previously allowed.
--
\ FINPUT.F version 0.0 2008-05-02
\
\ A minimum yet compliant Forth-94 implementation of
\ >FLOAT. Works with separate or common stack float
\ models.
\
\ Also provided are routines which condition the
\ text for forth input.
\
\ Assumptions:
\ 2's complement arithmetic
\ 1 char = 1 addr unit
\
\ This code is PUBLIC DOMAIN. Use at your own risk.
( EMPTY ) FORTH DEFINITIONS DECIMAL
CR .( Loading FINPUT ... )
TRUE CONSTANT STRICT \ FALSE = short version
\ ### MODIFY THESE AS REQUIRED ###
HEX
: UPCHAR ( c -- C ) \ make char uppercase
DUP [CHAR] a [CHAR] z 1+ WITHIN IF 20 XOR THEN ;
DECIMAL
\ Implement this to allow 'E' or 'e' on forth input
: CAPS-SEARCH SEARCH ; \ case-insensitive SEARCH
\ ### END ###
STRICT [IF] .( strict ) [ELSE] .( short ) [THEN]
..( version ) CR
HERE
VARIABLE exp \ exponent
VARIABLE dpf \ decimal point
FVARIABLE tmp
10 0 D>F FCONSTANT ften \ 10.E0
: getc ( a u -- a' u' c )
1 /STRING OVER 1- C@[EMAIL PROTECTED]
;
\ get sign
: gets ( a u -- a' u' n|0 )
DUP IF
getc DUP [CHAR] - = IF EXIT THEN
[CHAR] + <> /STRING
THEN 0 ;
: getdigs ( a u -- a' u' )
BEGIN DUP WHILE
getc [CHAR] 0 - DUP 9 U> IF
DROP -1 /STRING EXIT
THEN
0 D>F tmp F@[EMAIL PROTECTED]
ften F* F+ tmp F!
dpf @[EMAIL PROTECTED]
exp +!
REPEAT ;
: getmant ( a u -- a' u' flag )
[ STRICT ] [IF] TUCK [THEN]
getdigs DUP IF
OVER C@[EMAIL PROTECTED]
[CHAR] . = IF
-1 dpf ! 1 /STRING getdigs
THEN
THEN
[ STRICT ] [IF] ROT OVER - dpf @[EMAIL PROTECTED]
+ [THEN] ;
: getexp ( a u -- a' u' )
DUP IF
OVER C@[EMAIL PROTECTED]
UPCHAR DUP [CHAR] E =
SWAP [CHAR] D = OR 1 AND /STRING
THEN
gets >R 0 0 2SWAP >NUMBER 2SWAP
R> IF DNEGATE THEN exp @[EMAIL PROTECTED]
M+
D>S BEGIN ?DUP WHILE DUP 0<
IF 1+ [ 1 0 D>F ften F/ ] FLITERAL
ELSE 1- ften THEN tmp F@[EMAIL PROTECTED]
F* tmp F! REPEAT
;
STRICT [IF]
\ ANS function
: >FLOAT ( c-addr u -- r true | false )
[ 0 0 D>F ] FLITERAL tmp F! 0 exp ! 0 dpf !
2DUP -TRAILING NIP 0<> AND DUP IF
gets >R getmant IF
getexp DUP WHILE
THEN 2DROP R> DROP 0 EXIT
THEN ELSE 0 >R
THEN 2DROP tmp F@[EMAIL PROTECTED]
R> IF FNEGATE THEN TRUE ;
[ELSE]
\ ANS function
: >FLOAT ( a u -- r true | false )
[ 0 0 D>F ] FLITERAL tmp F! 0 exp ! 0 dpf !
-TRAILING
gets >R getmant
getexp IF R> 2DROP 0 EXIT THEN
DROP tmp F@[EMAIL PROTECTED]
R> IF FNEGATE THEN TRUE ;
[THEN]
HERE SWAP - CR . .( bytes )
\ Forth float input. Floating-point numbers can be
\ entered via F# .
: fnumber ( c-addr u -- [r] flag )
DUP 1 > IF ( at least 2 chars )
OVER DUP C@[EMAIL PROTECTED]
[CHAR] . < - ( skip sign)
C@[EMAIL PROTECTED]
[CHAR] . > >R ( 1st char can't be .)
2DUP S" E" CAPS-SEARCH >R 2DROP
2R> AND BASE @[EMAIL PROTECTED]
10 = AND 0= WHILE
THEN 2DROP 0 ELSE >FLOAT THEN
DUP >R STATE @[EMAIL PROTECTED]
AND IF POSTPONE FLITERAL THEN R> ;
: F# ( <number> )
BL WORD COUNT fnumber 0= ABORT" bad float" ; IMMEDIATE
\ discard heads
0 [IF]
EXCISE sgn getexp
EXCISE fnumber fnumber
[THEN]
1 [IF]
: CHK ( addr len flag )
>R CR [CHAR] " EMIT 2DUP TYPE [CHAR] " EMIT
8 OVER - SPACES >FLOAT DUP >R IF FDROP THEN R>
." --> " DUP IF ." TRUE " ELSE ." FALSE" THEN
R> - IF ." *fail* " ELSE ." pass " THEN ;
: TEST ( -- )
CR ." Checking >FLOAT syntax ..."
S" ." FALSE CHK
S" E" FALSE CHK
S" .E" FALSE CHK
S" .E-" FALSE CHK
S" +" FALSE CHK
S" -" FALSE CHK
S" 9" FALSE CHK
S" 9 " FALSE CHK
S" " TRUE CHK
S" " TRUE CHK
S" 1+1" TRUE CHK
S" 1-1" TRUE CHK
S" 9" TRUE CHK
S" 9." TRUE CHK
S" .9" TRUE CHK
S" 9E" TRUE CHK
S" 9e+" TRUE CHK
S" 9d-" TRUE CHK
;
TEST
[THEN]
\ end
