version 1.17, 1995/10/16 18:33:08
|
version 1.22, 1997/07/06 16:00:11
|
Line 1
|
Line 1
|
\ High level floating point 14jan94py |
\ High level floating point 14jan94py |
|
|
|
\ Copyright (C) 1995 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 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ 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. |
|
|
\ 1 cells 4 = [IF] |
\ 1 cells 4 = [IF] |
\ ' cells Alias sfloats |
\ ' cells Alias sfloats |
\ ' cell+ Alias sfloat+ |
\ ' cell+ Alias sfloat+ |
Line 37 dofield: lastxt code-address! \ change t
|
Line 55 dofield: lastxt code-address! \ change t
|
|
|
: f, ( f -- ) here 1 floats allot f! ; |
: f, ( f -- ) here 1 floats allot f! ; |
|
|
: fconstant ( r -- ) \ float |
: fconstant ( r "name" -- ) \ float |
Create f, |
Create f, |
DOES> ( -- r ) |
DOES> ( -- r ) |
f@ ; |
f@ ; |
|
|
: fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ; |
: fdepth ( -- n ) fp0 @ fp@ - [ 1 floats ] Literal / ; |
|
|
: FLit ( -- r ) r> dup f@ float+ >r ; |
: FLit ( -- r ) r> dup f@ float+ >r ; |
: FLiteral ( r -- ) |
: FLiteral ( r -- ) |
Line 80 DOES> ( -- r )
|
Line 98 DOES> ( -- r )
|
scratch over c@ emit '. emit 1 /string type |
scratch over c@ emit '. emit 1 /string type |
'E emit . ; |
'E emit . ; |
|
|
require debugging.fs |
require debugs.fs |
|
|
: sfnumber ( c-addr u -- r / ) |
: sfnumber ( c-addr u -- r true | false ) |
2dup [CHAR] e scan |
2dup [CHAR] e scan ( c-addr u c-addr2 u2 ) |
dup 0= |
dup 0= |
IF |
IF |
2drop 2dup [CHAR] E scan |
2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 ) |
THEN |
THEN |
nip |
nip |
IF |
IF |
2dup >float |
>float |
IF |
ELSE |
2drop state @ |
2drop false |
IF |
THEN ; |
POSTPONE FLiteral |
|
THEN |
|
EXIT |
|
THEN |
|
THEN |
|
defers notfound ; |
|
|
|
' sfnumber IS notfound |
:noname ( c-addr u -- ) |
|
2dup sfnumber |
|
IF |
|
2drop POSTPONE FLiteral |
|
ELSE |
|
defers compiler-notfound |
|
ENDIF ; |
|
IS compiler-notfound |
|
|
|
:noname ( c-addr u -- r ) |
|
2dup sfnumber |
|
IF |
|
2drop |
|
ELSE |
|
defers interpreter-notfound |
|
ENDIF ; |
|
IS interpreter-notfound |
|
|
: fvariable ( -- ) |
: fvariable ( "name" -- ) \ float |
Create 0.0E0 f, ; |
Create 0.0E0 f, ; |
\ does> ( -- f-addr ) |
\ does> ( -- f-addr ) |
|
|