--- gforth/float.fs 2004/12/08 11:05:08 1.44 +++ gforth/float.fs 2007/12/31 17:34:58 1.52 @@ -1,6 +1,6 @@ \ High level floating point 14jan94py -\ Copyright (C) 1995,1997,2003 Free Software Foundation, Inc. +\ Copyright (C) 1995,1997,2003,2004,2005,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -51,12 +51,14 @@ \G enough space to align it. here dup dfaligned swap ?DO bl c, LOOP ; -1 sfloats (Field) sfloat+ , ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus +(Field) sfloat+ ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus \G @code{1 sfloats +}. + 1 sfloats , -1 dfloats (Field) dfloat+ , ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus +(Field) dfloat+ ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus \G @code{1 dfloats +}. - + 1 dfloats , + : f, ( f -- ) \ gforth \G Reserve data space for one floating-point number and store \G @i{f} in the space. @@ -127,8 +129,6 @@ DOES> ( -- r ) scratch over c@ emit '. emit 1 /string type 'E emit . ; -require debugs.fs - : sfnumber ( c-addr u -- r true | false ) 2dup [CHAR] e scan ( c-addr u c-addr2 u2 ) dup 0= @@ -142,23 +142,35 @@ require debugs.fs 2drop false THEN ; -:noname ( c-addr u -- ) +[ifundef] compiler-notfound1 +defer compiler-notfound1 +' no.extensions IS compiler-notfound1 + +:noname compiler-notfound1 execute ; is compiler-notfound + +defer interpreter-notfound1 +' no.extensions IS interpreter-notfound1 + +:noname interpreter-notfound1 execute ; is interpreter-notfound +[then] + +:noname ( c-addr u -- ... xt ) 2dup sfnumber IF - 2drop POSTPONE FLiteral + 2drop [comp'] FLiteral ELSE - defers compiler-notfound + defers compiler-notfound1 ENDIF ; -IS compiler-notfound +IS compiler-notfound1 -:noname ( c-addr u -- r ) +:noname ( c-addr u -- ... xt ) 2dup sfnumber IF - 2drop + 2drop ['] noop ELSE - defers interpreter-notfound + defers interpreter-notfound1 ENDIF ; -IS interpreter-notfound +IS interpreter-notfound1 : fvariable ( "name" -- ) \ float f-variable Create 0.0E0 f, ; @@ -232,5 +244,4 @@ set-current : FMOD ( r1 r2 -- r ) \ remainder of r1/r2 - \ !! should be implemented properly FOVER FOVER F/ ftrunc F* F- ;