\ FINPUT.F  version 0.1  2009-05-07
\
\ A minimum yet compliant Forth-94 implementation of
\ >FLOAT. Works with separate or common stack float
\ models.
\
\ F# demonstrates the conditioning required to be
\ applied to >FLOAT to achieve compliance for forth
\ text input.
\
\ The code is intended as a model only. No particular
\ effort has been made to optimize for speed or
\ accuracy.
\
\ Assumptions:
\   2's complement arithmetic
\   1 char = 1 addr unit
\   -ROT    ( : -ROT  ROT ROT ; )
\   <>      ( : <>  - 0<> ; )
\
\ This code is PUBLIC DOMAIN.  Use at your own risk.
\
\ History:
\
\ 0.1  Replaced .1E F* with 10E F/ for better accuracy.
\      Added conditional to allow leading decimal point
\      on forth text input.
\

( EMPTY ) FORTH DEFINITIONS DECIMAL

CR .( Loading FINPUT v0.1  2009-05-07 ... )

1 CONSTANT STRICT  \ 0 = compiles shorter but less
                   \ strict code

\ *****  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 F10.0  \ 10.E0

: getc ( a u -- a' u' c )
  1 /STRING  OVER 1- C@ ;

\ 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@  F10.0 F*  F+  tmp F!
    dpf @  exp +!
  REPEAT ;

: getmant ( a u -- a' u' flag )
  [ STRICT ] [IF] TUCK [THEN]
  getdigs  DUP IF
    OVER C@ [CHAR] . = IF
      -1 dpf !  1 /STRING  getdigs
    THEN
  THEN
  [ STRICT ] [IF] ROT OVER - dpf @ + [THEN] ;

: getexp ( a u -- a' u' )
  DUP IF
    OVER C@ UPCHAR  DUP [CHAR] E =
    SWAP [CHAR] D = OR  1 AND /STRING
  THEN
  gets >R  0 0 2SWAP >NUMBER 2SWAP D>S
  R> IF NEGATE THEN  exp @ +
  BEGIN  ?DUP WHILE  DUP 0<
    IF    1+  tmp F@  F10.0  F/
    ELSE  1-  tmp F@  F10.0  F*  THEN  tmp F!
  REPEAT ;

STRICT [IF]

\ Forth-94 function (strict)
: >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@  R> IF FNEGATE THEN  TRUE ;

[ELSE]

\ Forth-94 function (non-strict)
: >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@  R> IF FNEGATE THEN  TRUE ;

[THEN]

HERE SWAP - CR . .( bytes )

\ Forth float input. Floating-point numbers can be
\ entered via F# .

1 [IF] ( standard behaviour )

: fnumber ( c-addr u -- [r] flag )
  DUP 1 > IF ( at least 2 chars )
    OVER  DUP C@ [CHAR] . < -  ( skip sign)
    C@ [CHAR] . >  >R          ( 1st char can't be .)
    2DUP  S" E" CAPS-SEARCH >R  2DROP
    2R> AND  BASE @ 10 = AND  0= WHILE
  THEN  2DROP 0  ELSE  >FLOAT  THEN
  DUP >R  STATE @ AND IF  POSTPONE FLITERAL  THEN R> ;

[ELSE] ( allow leading decimal point )

: fnumber ( c-addr u -- [r] flag )
  2DUP  S" E" CAPS-SEARCH -ROT  2DROP
  BASE @ 10 = AND IF  >FLOAT  ELSE  2DROP 0  THEN
  DUP >R  STATE @ AND IF  POSTPONE FLITERAL  THEN R> ;

[THEN]

: F# ( <number> )
  BL WORD COUNT fnumber 0= ABORT" bad float" ; IMMEDIATE

1 [IF]

\ Test Forth-94 compliance for >FLOAT

: 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 Forth-94 compliance ..." CR
  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