File:
[gforth] /
gforth /
float.fs
Revision
1.17:
download - view:
text,
annotated -
select for diffs
Mon Oct 16 18:33:08 1995 UTC (28 years, 6 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines
\ High level floating point 14jan94py
\ 1 cells 4 = [IF]
\ ' cells Alias sfloats
\ ' cell+ Alias sfloat+
\ ' align Alias sfalign
\ ' aligned Alias sfaligned
\ [ELSE]
\ : sfloats 2* 2* ;
\ : sfloat+ 4 + ;
\ : sfaligned ( addr -- addr' ) 3 + -4 and ;
\ : sfalign ( -- ) here dup sfaligned swap ?DO bl c, LOOP ;
\ [THEN]
\ 1 floats 8 = [IF]
\ ' floats Alias dfloats
\ ' float+ Alias dfloat+
\ ' falign Alias dfalign
\ ' faligned Alias dfaligned
\ [ELSE]
\ : dfloats 2* 2* 2* ;
\ : dfloat+ 8 + ;
\ : dfaligned ( addr -- addr' ) 7 + -8 and ;
\ : dfalign ( -- ) here dup dfaligned swap ?DO bl c, LOOP ;
\ [THEN]
: sfalign ( -- ) \ float-ext s-f-align
here dup sfaligned swap ?DO bl c, LOOP ;
: dfalign ( -- ) \ float-ext d-f-align
here dup dfaligned swap ?DO bl c, LOOP ;
1 sfloats constant sfloat+ ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus
dofield: lastxt code-address! \ change the constant into a field
1 dfloats constant dfloat+ ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus
dofield: lastxt code-address! \ change the constant into a field
: f, ( f -- ) here 1 floats allot f! ;
: fconstant ( r -- ) \ float
Create f,
DOES> ( -- r )
f@ ;
: fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ;
: FLit ( -- r ) r> dup f@ float+ >r ;
: FLiteral ( r -- )
BEGIN here cell+ dup faligned <> WHILE postpone noop REPEAT
postpone FLit f, ; immediate
&15 Value precision
: set-precision to precision ;
: scratch ( r -- addr len )
pad precision - precision ;
: zeros ( n -- ) 0 max 0 ?DO '0 emit LOOP ;
: -zeros ( addr u -- addr' u' )
BEGIN dup WHILE 1- 2dup + c@ '0 <> UNTIL 1+ THEN ;
: f$ ( f -- n ) scratch represent 0=
IF 2drop scratch 3 min type rdrop EXIT THEN
IF '- emit THEN ;
: f. ( r -- ) f$ dup >r 0<
IF '0 emit
ELSE scratch r@ min type r@ precision - zeros THEN
'. emit r@ negate zeros
scratch r> 0 max /string 0 max -zeros type space ;
\ I'm afraid this does not really implement ansi semantics wrt precision.
\ Shouldn't precision indicate the number of places shown after the point?
: fe. ( r -- ) f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
scratch r@ min type '. emit scratch r> /string type
'E emit r> . ;
: fs. ( r -- ) f$ 1-
scratch over c@ emit '. emit 1 /string type
'E emit . ;
require debugging.fs
: sfnumber ( c-addr u -- r / )
2dup [CHAR] e scan
dup 0=
IF
2drop 2dup [CHAR] E scan
THEN
nip
IF
2dup >float
IF
2drop state @
IF
POSTPONE FLiteral
THEN
EXIT
THEN
THEN
defers notfound ;
' sfnumber IS notfound
: fvariable ( -- )
Create 0.0E0 f, ;
\ does> ( -- f-addr )
1.0e0 fasin 2.0e0 f* fconstant pi
: f2* 2.0e0 f* ;
: f2/ 0.5e0 f* ;
: 1/f 1.0e0 fswap f/ ;
\ We now have primitives for these, so we need not define them
\ : falog ( f -- 10^f ) [ 10.0e0 fln ] FLiteral f* fexp ;
\ : fsinh fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ;
\ : fcosh fexp fdup 1/f f+ f2/ ;
\ : ftanh f2* fexpm1 fdup 2.0e0 f+ f/ ;
\ : fatanh fdup f0< >r fabs 1.0e0 fover f- f/ f2* flnp1 f2/
\ r> IF fnegate THEN ;
\ : facosh fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
\ : fasinh fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
\ !! factor out parts
: f~ ( f1 f2 f3 -- flag ) \ float-ext
fdup f0=
IF
fdrop f= EXIT
THEN
fdup f0>
IF
frot frot f- fabs fswap
ELSE
fnegate frot frot fover fabs fover fabs f+ frot frot
f- fabs frot frot f*
THEN
f< ;
: f.s ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0
?DO dup i - 1- floats fp@ + f@ f. LOOP drop ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>