| \ High level floating point 14jan94py |
\ 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. |
\ This file is part of Gforth. |
| |
|
| \G enough space to align it. |
\G enough space to align it. |
| here dup dfaligned swap ?DO bl c, LOOP ; |
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 +}. |
\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 +}. |
\G @code{1 dfloats +}. |
| |
1 dfloats , |
| |
|
| : f, ( f -- ) \ gforth |
: f, ( f -- ) \ gforth |
| \G Reserve data space for one floating-point number and store |
\G Reserve data space for one floating-point number and store |
| scratch over c@ emit '. emit 1 /string type |
scratch over c@ emit '. emit 1 /string type |
| 'E emit . ; |
'E emit . ; |
| |
|
| require debugs.fs |
|
| |
|
| : sfnumber ( c-addr u -- r true | false ) |
: sfnumber ( c-addr u -- r true | false ) |
| 2dup [CHAR] e scan ( c-addr u c-addr2 u2 ) |
2dup [CHAR] e scan ( c-addr u c-addr2 u2 ) |
| dup 0= |
dup 0= |
| 2drop false |
2drop false |
| THEN ; |
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 |
2dup sfnumber |
| IF |
IF |
| 2drop POSTPONE FLiteral |
2drop [comp'] FLiteral |
| ELSE |
ELSE |
| defers compiler-notfound |
defers compiler-notfound1 |
| ENDIF ; |
ENDIF ; |
| IS compiler-notfound |
IS compiler-notfound1 |
| |
|
| :noname ( c-addr u -- r ) |
:noname ( c-addr u -- ... xt ) |
| 2dup sfnumber |
2dup sfnumber |
| IF |
IF |
| 2drop |
2drop ['] noop |
| ELSE |
ELSE |
| defers interpreter-notfound |
defers interpreter-notfound1 |
| ENDIF ; |
ENDIF ; |
| IS interpreter-notfound |
IS interpreter-notfound1 |
| |
|
| : fvariable ( "name" -- ) \ float f-variable |
: fvariable ( "name" -- ) \ float f-variable |
| Create 0.0E0 f, ; |
Create 0.0E0 f, ; |
| \G @code{f~abs}; r3=0: bitwise comparison; r3<0: @code{fnegate f~rel}. |
\G @code{f~abs}; r3=0: bitwise comparison; r3<0: @code{fnegate f~rel}. |
| fdup f0= |
fdup f0= |
| IF \ bitwise comparison |
IF \ bitwise comparison |
| fp@ float+ 1 floats over float+ -text 0= |
fp@ float+ 1 floats over float+ over str= |
| fdrop fdrop fdrop |
fdrop fdrop fdrop |
| EXIT |
EXIT |
| THEN |
THEN |
| fnegate f~rel |
fnegate f~rel |
| THEN ; |
THEN ; |
| |
|
| : f.s ( -- ) \ gforth f-dot-s |
\ proposals from Krishna Myeni in <cjsp2d$47l$1@ngspool-d02.news.aol.com> |
| \G Display the number of items on the floating-point stack, |
\ not sure if they are a good idea |
| \G followed by a list of the items; TOS is the right-most item. |
|
| ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 |
: FTRUNC ( r1 -- r2 ) |
| ?DO dup i - 1- floats fp@ + f@ f. LOOP drop ; |
\ 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- ; |
