Verified Commit db094432 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Fix flnp1

parent 0e6cb9f1
\\ *** 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! \ Fliekommaarithmetik 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 29mar95py 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] ) fldl2e 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 \ Fakultt und Stirlingsche Nherung 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 ;
\ No newline at end of file
\\ *** 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! \ Fliekommaarithmetik 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 \ Fakultt und Stirlingsche Nherung 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 ;
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment