 gforth/float.fs 1999/12/03 18:24:22 1.29
+++ gforth/float.fs 2007/12/31 18:40:24 1.53
@@ 1,12 +1,12 @@
\ High level floating point 14jan94py
\ Copyright (C) 1995,1997 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1997,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
+\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
@@ 15,8 +15,7 @@
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+\ along with this program. If not, see http://www.gnu.org/licenses/.
\ 1 cells 4 = [IF]
\ ' cells Alias sfloats
@@ 51,16 +50,14 @@
\G enough space to align it.
here dup dfaligned swap ?DO bl c, LOOP ;
1 sfloats constant sfloat+ ( sfaddr1  sfaddr2 ) \ floatext sfloatplus
\G Increment @i{sfaddr1} by the number of address units corresponding to the size of
\G a singleprecision IEEE floatingpoint number, to give @i{sfaddr2}.""
dofield: lastxt codeaddress! \ change the constant into a field

1 dfloats constant dfloat+ ( dfaddr1  dfaddr2 ) \ floatext dfloatplus
\G Increment @i{dfaddr1} by the number of address units corresponding to the size of
\G a doubleprecision IEEE floatingpoint number, to give @i{dfaddr2}.""
dofield: lastxt codeaddress! \ change the constant into a field

+(Field) sfloat+ ( sfaddr1  sfaddr2 ) \ floatext sfloatplus
+\G @code{1 sfloats +}.
+ 1 sfloats ,
+
+(Field) dfloat+ ( dfaddr1  dfaddr2 ) \ floatext dfloatplus
+\G @code{1 dfloats +}.
+ 1 dfloats ,
+
: f, ( f  ) \ gforth
\G Reserve data space for one floatingpoint number and store
\G @i{f} in the space.
@@ 76,12 +73,12 @@ DOES> (  r )
\G floatingpoint stack.
fp0 @ fp@  [ 1 floats ] Literal / ;
: FLit (  r ) r> dup f@ float+ >r ;
: FLiteral ( compilation r  ; runtime  r ) \ float fliteral
\G Compile appropriate code such that, at runtime, @i{r} is placed
\G on the (floatingpoint) stack. Interpretation semantics are undefined.
 BEGIN here cell+ dup faligned <> WHILE postpone noop REPEAT
 postpone FLit f, ; immediate
+ BEGIN here cell+ cell+ dup faligned <> WHILE postpone noop REPEAT
+ postpone ahead here >r f, postpone then
+ r> postpone literal postpone f@ ; immediate
&15 Value precision (  u ) \ floatext
\G @i{u} is the number of significant digits currently used by
@@ 104,9 +101,9 @@ DOES> (  r )
IF ' emit THEN ;
: f. ( r  ) \ floatext fdot
\G Display (the floatingpoint number) @i{r} using fixedpoint notation,
+\G Display (the floatingpoint number) @i{r} without exponent,
\G followed by a space.
 f$ dup >r 0<
+ f$ dup >r 0<=
IF '0 emit
ELSE scratch r@ min type r@ precision  zeros THEN
'. emit r@ negate zeros
@@ 114,20 +111,23 @@ DOES> (  r )
\ I'm afraid this does not really implement ansi semantics wrt precision.
\ Shouldn't precision indicate the number of places shown after the point?
+\ Why do you think so? ANS Forth appears ambiguous on this point. anton.
+
: fe. ( r  ) \ floatext fedot
\G Display @i{r} using engineering notation, followed by a space.
+\G Display @i{r} using engineering notation (with exponent dividable
+\G by 3), followed by a space.
f$ 1 s>d 3 fm/mod 3 * >r 1+ >r
 scratch r@ min type '. emit scratch r> /string type
+ scratch r@ tuck min tuck  >r type r> zeros
+ '. emit scratch r> /string type
'E emit r> . ;
: fs. ( r  ) \ floatext fsdot
\G Display @i{r} using scientific notation, followed by a space.
+\G Display @i{r} using scientific notation (with exponent), followed
+\G by a space.
f$ 1
scratch over c@ emit '. emit 1 /string type
'E emit . ;
require debugs.fs

: sfnumber ( caddr u  r true  false )
2dup [CHAR] e scan ( caddr u caddr2 u2 )
dup 0=
@@ 141,23 +141,35 @@ require debugs.fs
2drop false
THEN ;
:noname ( caddr u  )
+[ifundef] compilernotfound1
+defer compilernotfound1
+' no.extensions IS compilernotfound1
+
+:noname compilernotfound1 execute ; is compilernotfound
+
+defer interpreternotfound1
+' no.extensions IS interpreternotfound1
+
+:noname interpreternotfound1 execute ; is interpreternotfound
+[then]
+
+:noname ( caddr u  ... xt )
2dup sfnumber
IF
 2drop POSTPONE FLiteral
+ 2drop [comp'] FLiteral
ELSE
 defers compilernotfound
+ defers compilernotfound1
ENDIF ;
IS compilernotfound
+IS compilernotfound1
:noname ( caddr u  r )
+:noname ( caddr u  ... xt )
2dup sfnumber
IF
 2drop
+ 2drop ['] noop
ELSE
 defers interpreternotfound
+ defers interpreternotfound1
ENDIF ;
IS interpreternotfound
+IS interpreternotfound1
: fvariable ( "name"  ) \ float fvariable
Create 0.0E0 f, ;
@@ 179,6 +191,9 @@ IS interpreternotfound
\G Divide 1.0e0 by @i{r1}.
1.0e0 fswap f/ ;
+getcurrent environmentwordlist setcurrent
+1.7976931348623157e308 FConstant maxfloat
+setcurrent
\ We now have primitives for these, so we need not define them
@@ 203,12 +218,12 @@ IS interpreternotfound
f fabs frot frot f* f< ;
: f~ ( r1 r2 r3  flag ) \ floatext fproximate
 \G ANS Forth medley: r3>0: @code{f~abs}; r3=0: r1=r2; r3<0: @code{fnegate f~abs}.
+ \G ANS Forth medley for comparing r1 and r2 for equality: r3>0:
+ \G @code{f~abs}; r3=0: bitwise comparison; r3<0: @code{fnegate f~rel}.
fdup f0=
 IF
 fdrop f= \ !! this does not work, because 0=0 with f= on LinuxIntel
 \ the standard says they should compare unequal
 \ the comparison should be done with COMPARE
+ IF \ bitwise comparison
+ fp@ float+ 1 floats over float+ over str=
+ fdrop fdrop fdrop
EXIT
THEN
fdup f0>
@@ 218,8 +233,14 @@ IS interpreternotfound
fnegate f~rel
THEN ;
: f.s (  ) \ gforth fdots
 \G Display the number of items on the floatingpoint stack,
 \G followed by a list of the items; TOS is the rightmost item.
 ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth.s @ min dup 0
 ?DO dup i  1 floats fp@ + f@ f. LOOP drop ;
+\ proposals from Krishna Myeni in
+\ not sure if they are a good idea
+
+: FTRUNC ( r1  r2 )
+ \ round towards 0
+ \ !! should be implemented properly
+ F>D D>F ;
+
+: FMOD ( r1 r2  r )
+ \ remainder of r1/r2
+ FOVER FOVER F/ ftrunc F* F ;