--- gforth/float.fs 1995/08/27 19:56:29 1.15 +++ gforth/float.fs 1995/10/07 17:38:12 1.16 @@ -26,9 +26,10 @@ : f, ( f -- ) here 1 floats allot f! ; -: fconstant ( r -- ) +: fconstant ( r -- ) \ float Create f, - DOES> f@ ; +DOES> ( -- r ) + f@ ; : fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ; @@ -68,16 +69,26 @@ scratch over c@ emit '. emit 1 /string type 'E emit . ; +require debugging.fs + : sfnumber ( c-addr u -- r / ) - 2dup >float + 2dup [CHAR] e scan + dup 0= + IF + 2drop 2dup [CHAR] E scan + THEN + nip IF - 2drop state @ + 2dup >float IF - postpone FLiteral + 2drop state @ + IF + POSTPONE FLiteral + THEN + EXIT THEN - ELSE - defers notfound - THEN ; + THEN + defers notfound ; ' sfnumber IS notfound @@ -105,10 +116,20 @@ \ : facosh fdup fdup f* 1.0e0 f- fsqrt f+ fln ; \ : fasinh fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ; -: f~ ( f1 f2 f3 -- flag ) 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< ; +\ !! 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 ;