--- gforth/float.fs 2010/12/31 18:09:02 1.58 +++ gforth/float.fs 2012/12/31 15:25:18 1.68 @@ -1,6 +1,6 @@ \ High level floating point 14jan94py -\ Copyright (C) 1995,1997,2003,2004,2005,2006,2007,2009,2010 Free Software Foundation, Inc. +\ Copyright (C) 1995,1997,2003,2004,2005,2006,2007,2009,2010,2011,2012 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -88,7 +88,7 @@ DOES> ( -- r ) \G @code{F.} @code{FE.} and @code{FS.} to @i{u}. to precision ; -: scratch ( r -- addr len ) +: scratch ( -- addr len ) pad precision - precision ; : zeros ( n -- ) 0 max 0 ?DO '0 emit LOOP ; @@ -128,19 +128,51 @@ DOES> ( -- r ) scratch over c@ emit '. emit 1 /string type 'E emit . ; +[IFDEF] fp-char : sfnumber ( c-addr u -- r true | false ) - 2dup [CHAR] e scan ( c-addr u c-addr2 u2 ) - dup 0= - IF - 2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 ) - THEN - nip - IF - >float - ELSE - 2drop false - THEN ; + fp-char @ >float1 ; +Create si-prefixes ," PTGMk munpf" +si-prefixes count bl scan drop Constant zero-exp + +: prefix-number ( c-addr u -- r true | false ) + si-prefixes count bounds DO + 2dup I c@ scan nip dup 0<> IF + 1 = IF 1- fp-char @ ELSE I c@ THEN + >float1 + dup IF 1000 s>f zero-exp I - s>f f** f* THEN + UNLOOP EXIT THEN drop + LOOP + sfnumber ; +[ELSE] +: sfnumber ( c-addr u -- r true | false ) + >float ; +: prefix-number sfnumber ; +[THEN] + +[ifdef] recognizer: + [IFDEF] 2lit, + : flit, postpone Fliteral ; + :noname ['] noop ; + :noname ['] flit, ; + [ELSE] + ' noop + :noname postpone Fliteral ; + [THEN] + dup + recognizer: r:fnumber + + : fnum-recognizer ( addr u -- float int-table | addr u r:fail ) + 2dup prefix-number + IF + 2drop r:fnumber EXIT + THEN + r:fail ; + +' fnum-recognizer +forth-recognizer get-recognizers +1+ forth-recognizer set-recognizers +[else] [ifundef] compiler-notfound1 defer compiler-notfound1 ' no.extensions IS compiler-notfound1 @@ -170,6 +202,7 @@ IS compiler-notfound1 defers interpreter-notfound1 ENDIF ; IS interpreter-notfound1 +[then] : fvariable ( "name" -- ) \ float f-variable Create 0.0E0 f, ;