\ FINPUT.F  version 0.2  2011-01-31
\
\ A minimum yet compliant implementation of Forth-94 >FLOAT.
\ Works with separate or common stack float model. No
\ particular effort has been made to optimize for speed or
\ conversion accuracy.
\
\ The requirements for Forth-94 floating-point text input
\ can be met by the application of tests prior to passing
\ the input to >FLOAT.  See 'fnumber' for details.
\
\ Implementation dependencies:
\   2's complement arithmetic
\   1 char = 1 address unit
\
\ 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.
\
\ 0.2  Simplified case-insensitive character tests.
\

FORTH DEFINITIONS DECIMAL

CR .( Loading FINPUT v0.2  2011-01-31 ... )

HERE

1 \ Change to 0 to compile shorter less strict code

DUP [IF] .( strict ) [ELSE] .( short ) [THEN]
.( version ) CR

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 ;

DUP [IF] ( strict )

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

[ELSE]

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

[THEN]

: getexp ( a u -- a' u' )
  DUP IF
    OVER C@  33 OR  [CHAR] e = ( 'D' 'E' 'd' 'e')
    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 ;

[IF] ( strict )

\ 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 text float input. Floating-point numbers may be
\ entered using F#.

1 [IF] ( Scan for 'E' or 'e')
: escan ( c-addr u1 -- u2 )
  BEGIN  DUP  WHILE  OVER C@  32 OR  [CHAR] e -
  WHILE  1 /STRING  REPEAT  THEN  NIP ;

[ELSE] ( Forth-94 specifies 'E')
: escan ( c-addr u -- fl )  S" E" SEARCH >R 2DROP R> ;

[THEN]

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 must be a digit)
    2DUP escan R> 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 escan  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] ( load and run test )

\ 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