--- gforth/float.fs 1995/01/19 17:48:01 1.11 +++ gforth/float.fs 1995/10/16 18:33:08 1.17 @@ -1,45 +1,55 @@ \ 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] +\ 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 ; -: f, ( f -- ) here 1 floats allot f! ; +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 -\ !! have create produce faligned pfas -: fconstant ( r -- ) - falign here f, Create A, - DOES> @ f@ ; +: f, ( f -- ) here 1 floats allot f! ; -: fvariable - falign here 0. d>f f, AConstant ; +: fconstant ( r -- ) \ float + Create f, +DOES> ( -- r ) + f@ ; : fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ; -: FLit ( -- r ) r> faligned dup f@ float+ >r ; -: FLiteral ( r -- ) postpone FLit falign f, ; immediate +: FLit ( -- r ) r> dup f@ float+ >r ; +: FLiteral ( r -- ) + BEGIN here cell+ dup faligned <> WHILE postpone noop REPEAT + postpone FLit f, ; immediate -&16 Value precision +&15 Value precision : set-precision to precision ; : scratch ( r -- addr len ) @@ -70,43 +80,67 @@ 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 -1e0 fasin 2e0 f* fconstant pi - -: f2* 2e0 f* ; -: f2/ 2e0 f/ ; -: 1/f 1e0 fswap f/ ; +: 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 ) [ 10e0 fln ] FLiteral f* fexp ; +\ : falog ( f -- 10^f ) [ 10.0e0 fln ] FLiteral f* fexp ; -\ : fsinh fexpm1 fdup fdup 1e0 f+ f/ f+ f2/ ; +\ : fsinh fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ; \ : fcosh fexp fdup 1/f f+ f2/ ; -\ : ftanh f2* fexpm1 fdup 2e0 f+ f/ ; +\ : ftanh f2* fexpm1 fdup 2.0e0 f+ f/ ; -\ : fatanh fdup f0< >r fabs 1e0 fover f- f/ f2* flnp1 f2/ +\ : fatanh fdup f0< >r fabs 1.0e0 fover f- f/ f2* flnp1 f2/ \ r> IF fnegate THEN ; -\ : facosh fdup fdup f* 1e0 f- fsqrt f+ fln ; -\ : fasinh fdup fdup f* 1e0 f+ fsqrt f/ fatanh ; +\ : 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 ;