float.fb

\\           *** Floating Point Bindings ***           02may95py                                                                 Unlike for the ST, I provide a native floating point binding   for the 387 and compatible, because it's likely for a FP user   to have a coprocessor. If not, (s)he can use emu387 from        DJ Delorie.                                                      This binding uses the 8 items depth stack of the 80387, so     be carefully not to exceed this stack depth. This prohibits     recursive algorithms without using a second stack for results,  but speeds things up very much.                                  Notice, that ASCII output of FP numbers will not work with a   full stack, it needs 2 items free over the TOS!                                                                                                                                                                                                                                                                                 \ Flieákommaarithmetik Loadscreen double pres.         09jul00py                                                                Module Float                                                    $A Constant Fcell               -$A Constant -Fcell             : Float+ Fcell + ; macro  0 :#+ T&P                             Code Floats  AX AX add  AX AX *4 I) AX lea  Next end-code  macro                                                                  1 capacity 4 - +thru                                          [IFDEF] environment                                                     environment definitions                                         true to floating                                                true to floating-ext                                            !$7.FFFFFFFFFFFFFFF8'FFF f2*                                    fconstant max-float                                     [THEN]                                                          Module;                                                         \ floating error handling status code                  17aug93py                                                                Variable fpstat       fpstat off      \ errorcode                                                                               | -&42 Constant FPdiv0                                          | -&43 Constant FPoverflow                                      | -&44 Constant FPstackfull                                     | -&45 Constant FPstackempty                                    | -&46 Constant FPwrongarg                                                                                                      ' align Alias falign            ' aligned Alias faligned        ' align Alias sfalign           ' aligned Alias sfaligned       ' align Alias dfalign           ' aligned Alias dfaligned       ' cells Alias sfloats           ' cell+   Alias sfloat+         : dfloats 2* cells ; macro      : dfloat+ cell+ cell+ ; macro                                                                   \ floating error handler                               23mar09pyhere negate 3 and allot Label :f0 $073F w, $033F w, $0F3F w,    Code FClearStack   finit   :f0 2+ A#) fldcw                          Next end-code              FClearStack                     Code FClex  fnclex  Next end-code macro                         ' FClearStack Alias fpu-init                                    : truncate  $0F3F :f0 4+ w! ; \ default                         : nearest   $033F :f0 4+ w! ;                                   : down      $073F :f0 4+ w! ;                                   : up        $0B3F :f0 4+ w! ;                                   | : -fak ( flag -- ) IF  FPwrongarg throw  THEN  ;              Label  fexp#    $40 c, -$2C c,  $01 c, -$14 c,                                  $10 c, -$2B c,  $08 c, -$2B c,                                  $04 c, -$2A c,  $02 c, -$2E c,                                  $20 c, -$29 c,  $00 c, -$01 c,                  What's 'catch Alias old-catch                                   \ floating point exception handling                    02may95py                                                                Label fp-recover                                                      pusha  dumped A# DI mov  SP SI mov                              $B # CX mov  rep movs  popa  3 cells # SP add                   'UP A#) UP mov  AX fstsw  fnclex                                SP RP cmp  u> IF  :S R:  THEN                                   user' s0 UP D) SI cmp  u>  IF  user' s0 UP D) SI mov  THEN      user' s^ UP D) SI cmp  u<= IF  user' s0 UP D) SI mov  THEN      fexp# A# CX mov                                                 BEGIN  .w CX ) DX mov  DL AL test 0=  WHILE                            2 # CX add  DL DL test  0= UNTIL  THEN                   -$2C # DH cmp                                                   0= IF  $47 # AH and  $41 # AH cmp                                      0= IF  -$2D # DH mov  THEN  THEN                         DH AX movsx  A:: ' throw rel) jmp  end-code               \ Stack operations                                     02may95py                                                                Code Fdepth ( -- n )  AX push  fxam  ( fwait )  AX fstsw             $FD # AH and  $41 # AH cmp  0= IF  AX AX xor                    ELSE   $B # AX shr  7 # AX and  7 # AX xor  AX inc  THEN        Next end-code                                              Label taskpause   :R  pushf  BX push  DI push  AX push  SI push       fxam  ( fwait )  AX fstsw  $FD # AH and  $41 # AH cmp           0= IF  0 # push                                                 ELSE   $B # AX shr  7 # AX and  7 # AX xor   AX DX mov                 BEGIN  $C # SP sub  .fx SP ) fstp  ( fwait)                            AX dec  0< UNTIL                                         DX inc  DX push  THEN  CX call                           CX pop  ?DO  .fx SP ) fld  $C # SP add  LOOP  THEN        \      -$6C # SP add SP ) fsave CX call SP ) frstor $6C # SP add      SI pop  AX pop  DI pop  BX pop  popf  ret  end-code       \ Fnegate Fabs F0= F0< F0>                             27feb99py                                                                Code D>F ( d -- f )  DX pop  AX push  DX push                        .fq SP ) fld  8 # SP add  AX pop                                Next end-code  macro  :dx :ax T&P                          Code S>F ( n -- f )  AX push  .fd SP ) fld  AX pop  AX pop           Next end-code  macro  :ax :ax T&P                          Code Fnegate  ( f -- -f )   fchs   Next end-code  macro         Code Fabs     ( f -- |f| )  fabs   Next end-code  macro                                                                         Code F2*      ( f -- f*2 )  0 ST fadd  Next end-code macro                                                                      | Create .5   $3F000000 ,                                       Code F2/      ( f -- f/2 )  .fs .5 A#) fmul                          Next end-code macro                                                                                                        \ Fnegate Fabs F0= F0< F0>                             25oct93py                                                                Code F0=  AX push  ftst  ( fwait )  AX fstsw                              0 ST fstp  sahf  AL 0<> setIF                                   1 # AX and  AX dec  Next end-code macro :ax :f T&P    Code F0<  AX push  ftst  ( fwait )  AX fstsw                              0 ST fstp  sahf  AL u>= setIF                                   1 # AX and  AX dec  Next end-code macro :ax :f T&P    Code F0>  AX push  ftst  ( fwait )  AX fstsw                              0 ST fstp  sahf  AL u<= setIF                                   1 # AX and  AX dec  Next end-code macro :ax :f T&P                                                                    : F0>=  F0< 0= ; macro                                          : F0<=  F0> 0= ; macro                                          : F0<>  F0= 0= ; macro                                                                                                          \ Fdrop Fdup Fswap Fover F>r Fr@ Fr> Frot F-rot        12jun00pyCode Fdrop ( f -- )     0 ST fstp  Next end-code macro          Code Fdup  ( f -- f f ) 0 ST fld   Next end-code macro          Code Fswap  ( f1 f2 -- f2 f1 )  1 ST fxch  Next end-code macro  Code Fover  ( f1 f2 -- f1 f2 f1 ) 1 ST fld  Next end-code macro Code Fover2 ( f3 -- f3 f1 ) 2 ST fld  Next end-code macro       Code Fover3 ( f3 -- f3 f1 ) 3 ST fld  Next end-code macro       : Funder  ( f1 f2 -- f2 f1 f2 )  fswap fover ; macro            Code F>r ( f -- ) $C # RP sub .fx RP ) fstp \ fwait                  Next end-code macro                                        Code Fr@ ( f -- ) .fx RP ) fld  Next end-code macro             Code Fr> ( f -- ) .fx RP ) fld $C # RP add  Next end-code macro Code Frot  ( f1 f2 f3 -- f2 f3 f1 )  1 ST fxch  2 ST fxch            Next end-code macro                                        Code F-rot ( f1 f2 f3 -- f3 f1 f2 )  2 ST fxch  1 ST fxch            Next end-code macro                                        \ Fpick Fpin Fnip                                      04oct99py                                                                Code Fpick  ( n -- fn )  7 # AX and  AL AH xchg  $C0D9 # AX add      .w AX here 8+ A#) mov  AHEAD  THEN  0 ST fld  AX pop            Next end-code                                              Code Fpin  ( f n -- )                                                AX inc  7 # AX and  AL AH xchg  $D8DD # AX add                  .w AX here 8+ A#) mov  AHEAD  THEN  1 ST fstp  AX pop           Next end-code                                              Code Fnip ( f1 f2 -- f2 )  1 ST fstp  Next end-code macro       | Code 22fpick ( f1 f2 f3 -- f1 f2 f3 f1 f2 )                          1 ST fld  3 ST fld  Next end-code macro                                                                                  Code Flit1  AHEAD  Fcell allot  THEN  Next end-code macro       Code Flit2  .fx 0 A#) fld  Next end-code  macro                                                                                 \ F@ F! Fvariable Fconstant                            04oct99pyCode F@ ( addr -- f )                                                .fx AX ) fld   AX pop  Next end-code macro  0 :ax T&P      Code F! ( f addr -- )  .fx AX ) fstp  ( fwait)  AX pop               Next end-code macro  0 :ax T&P                             : F, ( f -- ) here Fcell allot f! ;                             : Fvariable  Create Fcell allot ;                               : Fconstant  Create F,  Does> F@ ;                              \ Code Flit ( addr -- f )  R:  DX pop  .fx DX ) fld             \      Fcell # DX add  DX jmp  Next end-code                    \ : Fliteral  state @ 0= ?EXIT                                  \   compile Flit  f,  ; immediate restrict                      : Fliteral  state @ 0= ?EXIT                                      compile Flit1 here Fcell - 2- dup f!                            compile Flit2 here 6 - ! ;                 immediate restrict                                                                 \ f>d f>s F* F/ F+ f-                                  12jun00pyCode ff>d  ( f -- d )  AX push  :f0 A#) fldcw                        8 # SP sub  .fq SP ) fstp  :f0 2+ A#) fldcw                     DX pop  AX pop  DX push  Next end-code \ macro :ax :dx T&P Code ff>s  ( f -- n )  AX push  :f0 A#) fldcw                        .fd SP ) fstp ( fclex )  :f0 2+ A#) fldcw                       AX SP ) xchg  Next end-code \ macro  :ax 0 T&P                                                                             Code f>d  ( f -- d )  AX push  :f0 4+ A#) fldcw                      8 # SP sub  .fq SP ) fstp  :f0 2+ A#) fldcw                     DX pop  AX pop  DX push  Next end-code \ macro :ax :dx T&P Code f>s  ( f -- n )  AX push  :f0 4+ A#) fldcw                      .fd SP ) fstp ( fclex )  :f0 2+ A#) fldcw                       AX SP ) xchg  Next end-code \ macro  :ax 0 T&P                                                                                                                                             \ f>fd f>fs fd>f fs>f                                  28may00py                                                                Code f*   ( f1 f2 -- f )  1 STP fmul   Next end-code  macro     Code f/   ( f1 f2 -- f )  1 STP fdivr  Next end-code  macro     Code F+   ( f1 f2 -- f )  1 STP fadd   Next end-code  macro     Code F-   ( f1 f2 -- f )  1 STP fsubr  Next end-code  macro                                                                     Code f>fd ( f -- fd ) AX push  8 # SP sub  .fl SP ) fstp             AX pop  Next end-code macro :ax :ax T&P                    Code f>fs ( f -- fs ) AX push  4 # SP sub  .fs SP ) fstp             AX pop  Next end-code macro :ax :ax T&P                                                                                    Code fd>f ( fd -- f ) AX push  .fl SP ) fld  8 # SP add              AX pop  Next end-code macro :ax :ax T&P                    Code fs>f ( fs -- f ) AX push  .fs SP ) fld  4 # SP add              AX pop  Next end-code macro :ax :ax T&P                    \ fm* fm/ fm*/                                         20apr09pyCode !0  ( -- 0 )  fldz Next end-code  macro                    Code !1  ( -- 1 )  fld1 Next end-code  macro                    Code 1/f ( f -- 1/f )  fld1  1 STP fdiv  Next end-code  macro   Code Fm* ( f u32b -- f*u32b )  AX push  .fd SP ) fmul  ( fwait)      AX pop  AX pop  Next end-code  macro :ax :ax T&P           Code Fm/ ( f u32b -- f/u32b )  AX push  SP ) fdiv  ( fwait)          AX pop  AX pop  Next end-code  macro :ax :ax T&P           Code Fm*/ ( f u32b1 u32b2  -- f*u32b1/u32b2 )                        SP ) fmul  ( fwait)  AX SP ) mov  SP ) fdiv  ( fwait)           AX pop  AX pop                                                  Next end-code  macro 0 :ax T&P                             | Create 2fs  !0 f, !0 f,                                       : Fequal ( f1 f2 -- f1-f2=0 )  2fs f!  2fs float+ f!              2fs 1 floats 2fs float+ over str= ;                                                                                           \ floor frac frnd                                      20apr09pyCode floor ( f -- fs )  :f0 A#) fldcw                                frndint  :f0 2+ A#) fldcw  Next end-code macro             : frac ( f -- f )  fdup floor f- ;                              Code Fsign ( f -- -1:0< ; 0:0= ; 1:0> )                              AX push  ftst  ( fwait)  AX fstsw  0 ST fstp  sahf              AL 0<> setIF  u< IF  AL neg  THEN  AL AX movsx                  Next end-code                                              Code Fcomp ( f1 f2 -- -1:0< ; 0:0= ; 1:0> )                          AX push  1 STP fcomp  ( fwait )  AX fstsw  0 ST fstp  sahf      AL 0<> setIF  u> IF  AL neg  THEN  AL AX movsx                  Next end-code                                              Code F= ( f1 f2 -- flag )  AX push  fcompp                           ( fwait )  AX fstsw  sahf  AL 0<> setIF                         1 # AX and  AX dec  Next end-code macro :ax :f T&P                                                                         \ Fsign Fcomp F> F< Fmin Fmax F=                       04feb01pyCode F< ( f1 f2 -- flag )  AX push  fcompp                           ( fwait )  AX fstsw  sahf  AL u<= setIF                         1 # AX and  AX dec  Next end-code macro :ax :f T&P         Code F> ( f1 f2 -- flag )  AX push  fcompp                           ( fwait )  AX fstsw  sahf  AL u>= setIF                         1 # AX and  AX dec  Next end-code macro :ax :f T&P         : F<= ( f1 f2 -- f1<f2 )  F> 0= ; macro                         : F>= ( f1 f2 -- f1>f2 )  F< 0= ; macro                         : F<> ( f1 f2 -- f2<>f2 ) F= 0= ; macro                         Code Fmax  AX push  1 ST fcom  AX fstsw  sahf  u<=  IF               0 ST fstp  ELSE   1 ST fstp  THEN   AX pop                      Next end-code macro :ax :ax T&P                            Code Fmin  AX push  1 ST fcom  AX fstsw  sahf  u>=  IF               0 ST fstp  ELSE   1 ST fstp  THEN   AX pop                      Next end-code macro :ax :ax T&P                            \ Tabellen                                             23dec02py| : !!  1 max >r !1 r> 1+ 2 ?DO  i fm*  LOOP ;                  | : tab: here dup >r                                                | : swap compile ALiteral swap compile Literal                  compile ; hmacro r> dp ! ;                                  &07     tab: teta'  !1  &156 fm/ f,  &691 s>f &360360 s>f f/ f,                 !1 &1188 fm/ f, !1 &1680 fm/ f, !1 &1260 fm/ f,                 !1  &360 fm/ f, !1   &12 fm/ f,                 \\                                                              &07 dup tab: sin'  1 swap 2* 1- [DO]  [I] !! 1/f f, -2 [+LOOP]  &10 dup tab: cos'  0 swap 1- 2* [DO]  [I] !! 1/f f, -2 [+LOOP]  &16 dup tab: exp'  2- [FOR]  [I] 1+ !! 1/f f, [NEXT]  !0 f,     &06 dup tab: ln'   1 swap 2* 1- [DO]  !1 [I] fm/ f, -2 [+LOOP]  &24 dup tab: atan' 1 swap 2* 1- [DO]  !1 [I] fm/ f, -2 [+LOOP]  &28 dup tab: asin' 3 swap 2* 1- [DO]  !1 [I] 1                      [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f, \ sf@ df@ sf! df!                                      07mar09pyCode sf@  ( addr -- f )                                              .fs  AX ) fld   AX pop  Next end-code macro  0 :ax T&P     Code df@  ( addr -- f )                                              .fl  AX ) fld   AX pop  Next end-code macro  0 :ax T&P     Code sf!  ( f addr -- )  .fs  AX ) fstp  ( fwait)  AX pop            Next end-code macro  0 :ax T&P                             Code df!  ( f addr -- )  .fl  AX ) fstp  ( fwait)  AX pop            Next end-code macro  0 :ax T&P                             : sf,  here sf! 1 sfloats allot ;                               : df,  here df! 1 dfloats allot ;                               Variable fseed   timer@ fseed !                                 | $10450405 Constant rnd#                                       | : rnd  fseed @ rnd# * 1+ dup fseed ! ;                        : Frnd ( -- ramdom )  $3fff >r rnd $80000000 or >r rnd            >r fr> !1 f- ;                                                \ sf@+ df@+ sf!+ df!+                                  17oct99py                                                                Code sf@+  ( addr -- f )  .fs  AX ) fld   1 sfloats AX D) AX lea     Next end-code macro                                        Code df@+  ( addr -- f )  .fl  AX ) fld   1 dfloats AX D) AX lea     Next end-code macro                                        Code sf!+  ( f addr -- )  .fs  AX ) fstp  1 sfloats AX D) AX lea     Next end-code macro                                        Code df!+  ( f addr -- )  .fl  AX ) fstp  1 dfloats AX D) AX lea     Next end-code macro                                                                                                                                                                                                                                                                                                                                                                                                                                        \ horner fln fsqrt fexp fexpm1 flnp1                   23dec02py                                                                : horner ( f addr n -- f ) !0                                     Floats bounds DO  fover f* I f@ f+  fcell +LOOP  fnip ;                                                                       Code fsqrt ( f -- sqrt[f] )   fsqrt  Next end-code macro                                                                        Code fscale ( f1 f2 -- f )  1 ST fxch  fscale  1 ST fstp             Next end-code macro                                                                                                        Code fxtract ( f -- f n )  fxtract  AX push  AX push  1 ST fxch      .fd SP ) fstp  ( fwait)  AX pop  Next end-code                                                                             Code pi   fldpi   Next end-code  macro                          Code ln2  fldln2  Next end-code  macro                                                                                          \ f~ f>s round ceiling fmod                            03sep09py                                                                : f~ ( f1 f2 f3 -- flag )  fdup f0= IF  fdrop fequal EXIT  THEN   fdup f0>   IF  f>r f- fabs fr>                                           ELSE  fnegate f>r fover fabs fover fabs f+ f>r                        f- fabs fr> fr> f*  THEN  f< ;                                                                                 Code fround ( f -- round[f] )  frndint Next end-code            : ceiling  ( f -- ceiling[f] ) fnegate floor fnegate ;          Code ftrunc ( f -- fs )  :f0 4+ A#) fldcw                            frndint  :f0 2+ A#) fldcw  Next end-code macro                                                                             : fmod ( f1 f2 -- f1modf2 ) funder f/ frac f* ;                                                                                                                                                                                                                 \ horner fln                                           04may20py                                                                Code fln ( f -- ln[f] )   fldln2  1 ST fxch  fyl2x  ( fwait)         Next end-code  macro                                       Code flog ( f -- ln[f] )   fldlg2  1 ST fxch  fyl2x  ( fwait)        Next end-code  macro                                       Code flb ( f -- ln[f] )   fld1    1 ST fxch  fyl2x  ( fwait)         Next end-code  macro                                       Code flogb ( fx fb -- logb[x] )  fld1  1 ST fxch  fyl2x ( fwait)     fld1  1 STP fdiv  1 ST fxch  fyl2x  Next end-code          | Code (lnp1 ( f -- ln[f+1] )                                          fldln2  1 ST fxch  fyl2xp1  Next end-code  macro         : flnp1  ( f -- ln[f+1] ) fdup f0= ?EXIT                          fdup [ 2 s>f fsqrt f2/ !1 f- ] FLiteral f>                      IF  fdup [ 2 s>f fsqrt !1 f- ] FLiteral f<                          IF  (lnp1 EXIT  THEN  THEN  !1 f+ fln ;                   \ fexp                                                 14jul98py                                                                Code fexp  ( f1 -- f2 )  fldl2e  1 STP  fmul                         0 ST fld  frndint  1 <ST fsubr  1 ST fxch  f2xm1                fld1  1 STP fadd  fscale  1 ST fstp  Next end-code macro                                                                   Code fexpm1  ( f1 -- f2 )  AX push  fldl2e  1 STP  fmul              0 ST fld  frndint  1 <ST fsubr  1 ST fxch  f2xm1                fincstp  ftst  ( fwait )  fdecstp  AX fstsw                     sahf  0= IF  AX pop  1 ST fstp  Next  THEN                      fld1  1 STP fadd  fscale  1 ST fstp                             fld1  1 STP fsubr  AX pop  Next end-code                                                                                                                                                                                                                                                                                   \ fatan fasin                                          15dec02py                                                                [IFDEF] ownatan                                                     $25 $26 thru   | : fpatan  f/ fatan ;                       [ELSE]                                                              Code fatan   fld1  fpatan  Next end-code  macro                 Code fasin   0 ST fld  0 ST fmul  fld1  1 STP fsub  fsqrt                    fpatan  Next end-code                              Code fatan2  fpatan  Next end-code macro                    [THEN]                                                                                                                                                                                                                                                                                                                                                                                                                                                          \ fsin fcos fsincos                                    18apr93py                                                                Code fsin  ( f -- sin[f] )  fsin  Next end-code  macro          Code fcos  ( f -- cos[f] )  fcos  Next end-code  macro                                                                          Code fsincos  ( f -- sin[f] cos[f] )                                 fsincos  Next end-code  macro                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              \ fm^ f^  fine^  grad>rad rad>grad r,phi>xy            25may09py                                                                Code f**2 ( fx -- fx**2 )  0 ST fmul  Next end-code macro       : fm** ( f n -- f**n )  dup >r abs >r !1 fswap                    BEGIN  r@ 1 and  IF  funder f* fswap  THEN                             r> 2/ dup  WHILE  >r  f**2  REPEAT                       drop fdrop r> 0< IF  1/f  THEN ;                              : f**  ( fx fy -- fx**y ) ( fdup frac f0=                         IF  f>s fm**  ELSE ) fswap fln f* fexp ( THEN ) ;             : falog ( f -- 10^f )  [ &10 s>f fln ] FLiteral f* fexp ;       : grad>rad ( fgrad -- frad ) [ pi &180 fm/    ] Fliteral f* ;   : rad>grad ( frad -- fgrad ) [ &180 s>f pi f/ ] Fliteral f* ;                                                                   Code r,phi>xy ( r phi -- x y )                                       fsincos  2 ST fmul  2 ST fxch  1 STP fmul                       Next end-code macro                                        \ Fakult„t und Stirlingsche N„herung                   18apr93py                                                                | : teta ( exp n -- exp+teta[n] )                                   1/f fdup f**2 fnegate teta' horner f* f+ ;                                                                                  : stirling ( f -- f! )                                            fdup [ !1 f2/ ] FLiteral f+ fover fln f* fover f-               [ pi f2* fln f2/ ] FLiteral f+ fswap teta fexp ;                                                                              : fak ( f -- f! )  fdup fround fabs funder f= invert -fak         fdup [ &200 s>f ] Fliteral f>                                   IF stirling ELSE ff>s !! THEN ;                                                                                                                                                                                                                                                                                               \ Trigonometrische Funktionen                          15dec02py: fsec    ( f -- sec[f] )       fsin 1/f ;      macro           : fcosec  ( f -- sec[f] )       fcos 1/f ;      macro           Code ftan ( f -- tan[f] ) fptan 0 ST fstp  Next end-code macro  : fcot    ( f -- cot[f] )       fsincos fswap f/ ;  macro       : facos   ( f -- arccos[f] )                                              fasin  fnegate [ pi f2/ ] FLiteral f+ ;               : facot   ( f -- arccot[f] )    fdup f0=                                  IF fdrop [ pi f2/ ] FLiteral EXIT THEN                          1/f fatan fdup f0< IF  pi f+  THEN ;                  [IFUNDEF] fatan2                                                : fatan2  ( sin cos -- angle )                                            fover f0= IF  fdup f0<  ELSE  fover f0<  THEN  >r               fdup f0=  IF  fdrop fdrop pi f2/  ELSE  fpatan                  fdup f0<  IF  pi f+  THEN  THEN                                 r>  IF pi f-  THEN ;                  [THEN]          \ Hyperbel- und Areafunktionen                         17apr09py                                                                : fsinh    fexpm1 fdup fdup !1 f+ f/ f+ f2/ ;                   : fcosh    fexp fdup 1/f f+ f2/ ;                               : fsech    fsinh 1/f ;                                          : fcosech  fcosh 1/f ;                                          : ftanh    f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ f/ ;           : fcoth    f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ fswap f/ ;                                                                     : fatanh   fdup f0< >r fabs !1 fover f- f/  f2* flnp1 f2/                  r> IF  fnegate  THEN ;                               : facoth   fdup f0< >r fabs !1       f- 1/f f2* flnp1 f2/                  r> IF  fnegate  THEN ;                               : fasinh   fdup fdup f* !1 f+ fsqrt f+ fln ;                    : facosh   fdup fdup f* !1 f- fsqrt f+ fln ;                                                                                    \ Statistikfunktionen                                  28may00py: frandom ( n -- 0/n-1) frnd f* floor ;                                                                                         : fchoose ( n k -- k_choose_n )  fdup frac f0<> -fak              fdup f0<= IF  fnip f0= IF  !1  ELSE  !0  THEN  EXIT  THEN       fover frac f0<>                                                 IF  ff>s >r fdup r> 1+ 2 ?DO  !1 f- funder f* i fm/ fswap LOOP      fdrop EXIT  THEN                                            fover fover f< IF  fdrop fdrop !0 EXIT  THEN  fdup fak f>r      fover [ &400 s>f ] FLiteral f>                                  IF    fover fak f-rot f- fak f/                                 ELSE  ff>s >r ff>s 1+ dup r> - >r >r                                  !1 r> r> ?DO  i fm*  LOOP  THEN  fr> f/ fround ;                                                                        : bernoulli ( n k p -- b[n,k,p] ) fdup f>r fover f** f-rot        fover fover f- !1 fr> f- fswap f** f-rot fchoose f* f* ;      \ Zahlen ausgeben                                      20apr09py                                                                : fextract ( f -- dmant nexp sign )                               fdup f0= IF  0. 0 !0 fequal 0=  EXIT THEN  \ zero is trivial    fdup fxtract f0< >r 1+ fabs       \ |f| exp+1  r: sign          ln2 base @ s>f fln f/             \ |f| fln(2)/fln(base) exp+1  fdup fm* ff>s >r                  \ .. r: sign exponent[base]   [ &64 s>f ] Fliteral f* ff>s 1-   \ representable digits        r> over >r dup >r - base @ s>f fm** f* \ fmant r: sg rd exb     !1 f+ f2/ ff>d 2dup d+  base @    \ d(round(f)) base base       BEGIN  dup r@ abs 4/ 2/ <  WHILE  base @ * r> 1+ >r  REPEAT     dup >r ud/mod                     \ mod dquot r: sg rd exb      rot r> 2/ > IF  1. d+  THEN       \ round adjusted number       r> r> - 1+ r> ;                   \ dmant exb-rd+1 sign       : esign  base @ &10 = IF  sign 'e hold                            ELSE  0< IF '- ELSE '+ THEN hold  THEN ;                      \ represent                                            07aug10py: fadjust ( dmant nexp n -- dmant' nexp' ) swap >r                1. rot 0 ?DO  2dup base @ 0 d* 2over 2over d< IF  2swap  THEN                 2drop  LOOP  2swap 0 >r                           BEGIN  2over 2over d<  WHILE  base @ ud/mod rot                        dup 0= over base @ 2/ = or r> 0<> and - r> 1+ >r >r      REPEAT  r> base @ 2/ 3 pick 1 and IF  >=  ELSE  >  THEN         IF  1. d+  THEN  2swap 2drop r> ;                             : represent ( f addr u -- n flag1 flag2 )  2>r                    fextract r@ swap >r fadjust r>                                  2r> 2swap >r >r 2swap <<# #s #> r> over + >r                    2swap 2over 2over rot min move rot /string '0 fill drop         r> r> true #>> ;                                              | User (precision                                               : precision      (precision @ ;                                 : set-precision  (precision ! ;                                 \ Zahlen ausgeben                                      07aug10py| : fscratch ( -- addr u ) pad precision - $20 - cell-              precision ;                                                 | : fscratch' ( -- addr u )   fscratch '0 -skip ;               | : f$ ( f -- n sign )  fscratch represent drop ;               \needs 3* | : 3* ( n -- n*3 )  dup 2* + ;   hmacro              | : zeros ( n -- )  0 ?DO  '0 hold  LOOP ;                      | : .fexp ( n -- ) extend under dabs                                <<# #s 2drop esign ;                                        | : finish ( sign -- addr u ) sign 0. #> #>> ;                  | : .$# ( addr u -- )  dup 0= IF  2drop  EXIT  THEN                 bounds swap 1- DO I c@ hold -1 +LOOP ;                      | : 0.f ( sign -- addr u ) s" 0." .$# finish ;                  | : .. ( addr n -- ) dup IF .$# '. hold ELSE 2drop THEN ;       | : $#.f ( addr u sign -- addr u ) >r .$# r> finish ;           | : $0.f ( addr u sign -- addr u ) >r .$# r> 0.f ;              \ Zahlen ausgeben                                      07aug10py                                                                : fs$ ( f -- addr u ) f$ >r .fexp fscratch r> $0.f ;            : fe$  ( f -- addr u )  f$ >r                                     1- 3 /mod 3* .fexp 1+ >r                                        fscratch over r@ 2swap r> /string                               .$# '. hold .$# r> finish ;                                   : fx$  ( f -- addr u )  fdup f0= IF  fdrop s" 0"  EXIT  THEN      f$ >r >r  fscratch'                                             r@ 1- -3 u>  IF  <<# .$# r> negate zeros r> 0.f  EXIT THEN      dup r@ u>=                                                          IF  <<# over r@ 2swap r> /string .. r> $#.f  EXIT THEN      r@ precision 3 + u<=                                                IF  <<# r> over - zeros r> $#.f     EXIT  THEN              r> 1- .fexp 2dup 1 /string .. drop c@ hold r> finish ;                                                                        \ Zahlen ausgeben                                      07aug10py                                                                : ff$  ( f -- addr u )  f$ >r >r fscratch'                        r@ abs $40 > IF  r> .fexp r> $0.f  EXIT THEN                    r@ 0> IF  <<# 2dup r@ min 2swap  r@ over - 0 max r> swap >r               /string .$# '. hold r> zeros .$#                                r> finish EXIT  THEN                                  <<# .$# r> negate zeros r> 0.f ;                                                                                              : fs. ( f -- ) fs$ type space ;                                 : fx. ( f -- ) fx$ type space ;                                 : fe. ( f -- ) fe$ type space ;                                 : ff. ( f -- ) ff$ type space ;                                                                                                 ' ff. alias f.                                                  ' ff$ alias f$                                                  \ fdump f.s fe.s                                       07aug10py| : .flit ( IP -- IP' )  drop dup f@ '! emit  fx. float+ ;      Tools  ' Flit1 ' .flit bind-see  Float                          : fdump ( -- )  base @ fdepth 0                                   ?DO  hex  cr i fpick pad Fcell - f!  pad Fcell - 2@ swap             pad Fcell 8 - - w@ 0 <<# 3 FOR # NEXT #> type #>>               <<# 7 FOR  # # bl hold  NEXT  #> type #>>                       dup base ! 2 spaces i fpick fx. stop? ?LEAVE  LOOP         drop ;                                                        : f.s  fdepth 0 ?DO     i fpick fswap f>r fx. fr>  LOOP ;       : fe.s fdepth 0 ?DO  cr i fpick fswap f>r fe. fr>  LOOP ;       \\                                                              : f.all ( f -- ) fdup floor fx. curleft frac                      fdup f0= 0= IF ." ." THEN                                       BEGIN  fdup f0= 0= WHILE  base @ fm* fdup ff>s 0 u.r                   frac   REPEAT  fdrop ;                                 \ fdpl fsign? fbase? exp#                              31aug07py| Variable fdpl  fdpl on                                        | : fsign? ( addr count -- addr count sign )  over c@               Ascii - case?  IF  1 /string true  EXIT  THEN                   Ascii + case?  IF  1 /string false EXIT  THEN  drop 0 ;     here  $10 c, %10 c, &10 c,                                      | : fbase? ( addr count -- addr count )                             over c@  Ascii $ - dup 3 u<                                     IF [ rot ] ALiteral + c@ base ! 1 /string EXIT THEN drop ;  | : >esign ( addr u -- addr' u' )                                   2dup bounds ?DO  s" dDeE'+-" base @ &10 > 4 and /string             I c@ scan nip                                                   IF  2drop I I' over - unloop  EXIT  THEN                    LOOP  + 0 ;                                                 | : exp# ( addr count -- exp t / f ) fsign? >r 0. 2swap >number     >r 2drop r> IF drop 0 EXIT THEN r> IF negate THEN true ;    \ >float                                               31aug07py: >float ( addr count -- f t / f )  base push                     bl skip -trailing  fsign? >r  fbase?  Ascii 0 skip              2dup 2dup >esign nip - bounds fdpl on  >r >r !0 r> r>           ?DO  i c@ digit?                                                     IF    ?dup  0=  IF  base @ fm*  ELSE  >r                              fdup  f0= 0= IF    base @ fm* r> s>f f+                                      ELSE  fdrop r> s>f  THEN THEN                ELSE  i c@ $FD and ', = 0= fdpl @ i' 1+ i - = or                      IF  fdrop 2drop UNLOOP rdrop false EXIT  THEN                   i' i - fdpl !  THEN                                  LOOP  r> IF  fnegate  THEN  f>r                                 >esign over c@ '- <> negate /string                             dup 0= IF nip ELSE exp# 0= IF fr> fdrop false EXIT THEN THEN    >r base @ s>f r> fdpl @ 1- 0 max -                              dup >r abs fm** r> fr> 0< IF fswap f/ ELSE f* THEN true ;     \ fnumber                                              19aug07py| What's notfound alias oldnotfound                             \ [IFDEF] ANS                                                          : f# ( addr -- f ) >r r@ count over c@ '! =                       IF  1 /string  THEN >float                                      IF  rdrop state @                                               IF  compile Fliteral  THEN  EXIT THEN r> oldnotfound ; \ [ELSE] : f# ( addr -- f )  dup 1+ c@ '! =                     \          IF  >r r@ count 1 /string >float                     \            IF rdrop state @ IF compile Fliteral THEN EXIT THEN\             r>  THEN  oldnotfound ;                           ( [THEN]) ' f# IS notfound                                                                                                                                                                                                                                                                                                      \ export: bye:                                         14mar10py: f-catch  Fclex  fdepth >r defers 'catch                         r@ 8 0 within IF  rdrop  FClearStack  EXIT  THEN                r> fdepth - dup 0<                                              IF    negate 0 ?DO  fdrop  LOOP                                 ELSE         0 ?DO  !0     LOOP  THEN ;                       bye:    lasterr @ 0> ?EXIT   FClearStack                                [ except' $10 cells + dup @ ] ALiteral ALiteral !               [ ' multitask 4+ dup @ ]  ALiteral ALiteral ! multitask         ['] old-catch IS 'catch  ['] oldnotfound IS notfound ;  : f-init ['] f-catch IS 'catch ['] f# IS notfound ;             also environment                                                cold:   fp-recover except' $10 cells + ! FClearStack ;          export: drop taskpause [ ' multitask 4+ ] ALiteral ! multitask          true to floating true to floating-ext                           &18 set-precision f-init                                \ export list                                          14mar10pyexport float fcell -fcell float+ floats fpstat falign faligned    sfalign sfaligned dfalign dfaligned sfloats sfloat+ dfloats     dfloat+ fclearstack fclex truncate nearest down up              fdepth d>f s>f fnegate fabs f2* f2/ f0= f0< f0> f0>= f0<= f0<>  fdrop fdup fswap fover fover2 fover3 funder f>r fr@ fr> frot    f-rot fpick fpin fnip f@ f! f, fvariable fconstant fliteral     ff>d ff>s f>d f>s f* f/ f+ f- f>fd f>fs fd>f fs>f !0 !1         1/f fm* fm/ fm*/ fequal floor frac fsign fcomp f= f< f>         f<= f>= f<> fmax fmin sf@ df@ sf! df! sf, df, fseed frnd        sf@+ df@+ sf!+ df!+ horner fsqrt fscale fxtract pi ln2 f~       fround ceiling ftrunc fmod fln flog flb flogb flnp1 fexp        fexpm1 fatan fasin fatan2 fsin fcos fsincos f**2 fm** f**       falog grad>rad rad>grad r,phi>xy stirling fak fsec fcosec       ftanh fcoth fatanh facoth fasinh facosh frandom fchoose         bernoulli represent precision set-precision                                                                                     fs$ f$ fx$ ff$ fs. fx. fe. ff. f. f$ fdump f.s fe.s >float      f# f-catch f-init ; toss                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      \ (arctan (arcsin                                      20apr93py                                                                &24 dup tab: atan' 1 swap 2* 1- [DO]  !1 [I] fm/ f, -2 [+LOOP]  &28 dup tab: asin' 3 swap 2* 1- [DO]  !1 [I] 1                      [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f,                                                                 | : (arctan ( f -- arctan[f] )   fdup f0= ?EXIT                     fdup fdup f* fnegate atan' horner f* ;                      | : (arcsin ( f -- arcsin[f] )   fdup f0= ?EXIT                     fdup fdup f* asin' horner f* ;                                                                                              \\                                                              Both fasin and fatan are very inaccurate with emu387; so I      replace them by my original versions (which is quite accurate)                                                                                                                                  \ arctan arcsin                                        20apr93py                                                                : fatan ( f -- arctan[f] ) fdup f0< >r fabs                       fdup !1 f> dup >r  IF  !1 fswap f/  THEN                        fdup [ !1 f2* fsqrt !1 f- ] Fliteral f>                         IF    !1 fover f- fswap !1 f+ f/ (arctan                              fnegate [ pi f2/ f2/ ] Fliteral f+                        ELSE  (arctan  THEN                                             r>  IF  fnegate [ pi f2/ ] Fliteral f+  THEN                    r>  IF  fnegate  THEN ;                                       : fasin ( f -- arcsin[f] ) fdup f0< >r fabs                       fdup !1 f> IF  FPwrongarg throw  THEN                           fdup [ !1 f2/ ] Fliteral f>                                     IF    !1 fover fdup f* f- fsqrt fswap f/                              fatan  fnegate [ pi f2/ ] Fliteral f+                     ELSE  (arcsin  THEN  r>  IF  fnegate  THEN ;