Commit e4122347 authored by pazsan's avatar pazsan

Added stack comments to complex.fs

parent 3f992e73
......@@ -869,7 +869,7 @@ gforth.elc: gforth.el
#Documentation
doc/doc.fd: doc/makedoc.fs $(GFORTH_FI_SRC) code.fs objects.fs oof.fs moofglos.fs
$(FORTHK) -e "s\" doc/doc.fd\"" doc/makedoc.fs except.fs startup.fs code.fs objects.fs oof.fs moofglos.fs regexp.fs -e bye
$(FORTHK) -e "s\" doc/doc.fd\"" doc/makedoc.fs except.fs startup.fs code.fs objects.fs oof.fs moofglos.fs regexp.fs fft.fs -e bye
doc/crossdoc.fd: $(KERN_SRC) kernel/version.fs $(FORTH_GEN0)
$(FORTHK) -e 's" mach32l.fs"' kernel/main.fs -e bye
......
......@@ -20,109 +20,112 @@
\ *** Complex arithmetic *** 23sep91py
: complex' 2* floats ;
: complex+ float+ float+ ;
: complex' ( n -- offset ) 2* floats ;
: complex+ ( zaddr -- zaddr' ) float+ float+ ;
\ simple operations 02mar05py
: fl> f@local0 lp+ ;
: fl> ( -- r ) f@local0 lp+ ;
: zdup fover fover ;
: zdrop fdrop fdrop ;
: zover 3 fpick 3 fpick ;
: z>r f>l f>l ;
: zr> fl> fl> ;
: zswap frot f>l frot fl> ;
: zpick 2* 1+ >r r@ fpick r> fpick ;
: zdup ( z -- z z ) fover fover ;
: zdrop ( z -- ) fdrop fdrop ;
: zover ( z1 z2 -- z1 z2 z1 ) 3 fpick 3 fpick ;
: z>r ( z -- r:z) f>l f>l ;
: zr> ( r:z -- z ) fl> fl> ;
: zswap ( z1 z2 -- z2 z1 ) frot f>l frot fl> ;
: zpick ( z1 .. zn n -- z1 .. zn z1 ) 2* 1+ >r r@ fpick r> fpick ;
\ : zpin 2* 1+ >r r@ fpin r> fpin ;
: zdepth fdepth 2/ ;
: zrot z>r zswap zr> zswap ;
: z-rot zswap z>r zswap zr> ;
: z@ dup >r f@ r> float+ f@ ;
: z! dup >r float+ f! r> f! ;
: zdepth ( -- u ) fdepth 2/ ;
: zrot ( z1 z2 z3 -- z2 z3 z1 ) z>r zswap zr> zswap ;
: z-rot ( z1 z2 z3 -- z3 z1 z2 ) zswap z>r zswap zr> ;
: z@ ( zaddr -- z ) dup >r f@ r> float+ f@ ;
: z! ( z zaddr -- ) dup >r float+ f! r> f! ;
\ simple operations 02mar05py
: z+ frot f+ f>l f+ fl> ;
: z- fnegate frot f+ f>l f- fl> ;
: zr- frot f- f>l fswap f- fl> ;
: x+ frot f+ fswap ;
: x- fnegate x+ ;
: z* fdup 4 fpick f* f>l fover 3 fpick f* f>l
: z+ ( z1 z2 -- z1+z2 ) frot f+ f>l f+ fl> ;
: z- ( z1 z2 -- z1-z2 ) fnegate frot f+ f>l f- fl> ;
: zr- ( z1 z2 -- z2-z1 ) frot f- f>l fswap f- fl> ;
: x+ ( z r -- z+r ) frot f+ fswap ;
: x- ( z r -- z-r ) fnegate x+ ;
: z* ( z1 z2 -- z1*z2 )
fdup 4 fpick f* f>l fover 3 fpick f* f>l
f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;
: zscale ftuck f* f>l f* fl> ;
: zscale ( z r -- z*r ) ftuck f* f>l f* fl> ;
\ simple operations 02mar05py
: znegate fnegate fswap fnegate fswap ;
: zconj fnegate ;
: z*i fnegate fswap ;
: z/i fswap fnegate ;
: zsqabs fdup f* fswap fdup f* f+ ;
: 1/z zconj zdup zsqabs 1/f zscale ;
: z/ 1/z z* ;
: |z| zsqabs fsqrt ;
: zabs |z| 0e ;
: z2/ f2/ f>l f2/ fl> ;
: z2* f2* f>l f2* fl> ;
: znegate ( z -- -z ) fnegate fswap fnegate fswap ;
: zconj ( rr ri -- rr -ri ) fnegate ;
: z*i ( z -- z*i ) fnegate fswap ;
: z/i ( z -- z/i ) fswap fnegate ;
: zsqabs ( z -- |z|² ) fdup f* fswap fdup f* f+ ;
: 1/z ( z -- 1/z ) zconj zdup zsqabs 1/f zscale ;
: z/ ( z1 z2 -- z1/z2 ) 1/z z* ;
: |z| ( z -- r ) zsqabs fsqrt ;
: zabs ( z -- |z| ) |z| 0e ;
: z2/ ( z -- z/2 ) f2/ f>l f2/ fl> ;
: z2* ( z -- z*2 ) f2* f>l f2* fl> ;
: >polar ( z -- r theta ) zdup |z| fswap frot fatan2 ;
: polar> ( r theta -- z ) fsincos frot zscale fswap ;
\ zexp zln 02mar05py
: zexp fsincos fswap frot fexp zscale ;
: pln zdup fswap fatan2 frot frot |z| fln fswap ;
: zln >polar fswap fln fswap ;
: zexp ( z -- exp[z] ) fsincos fswap frot fexp zscale ;
: pln ( z -- pln[z] ) zdup fswap fatan2 frot frot |z| fln fswap ;
: zln ( z -- ln[z] ) >polar fswap fln fswap ;
: z0= f0= >r f0= r> and ;
: zsqrt zdup z0= 0= IF
: z0= ( z -- flag ) f0= >r f0= r> and ;
: zsqrt ( z -- sqrt[z] ) zdup z0= 0= IF
fdup f0= IF fdrop fsqrt 0e EXIT THEN
zln z2/ zexp THEN ;
: z** zswap zln z* zexp ;
: z** ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;
\ Test: Fibonacci-Zahlen
1e 5e fsqrt f+ f2/ fconstant g 1e g f- fconstant -h
: zfib zdup z>r g 0e zswap z**
: zfib ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**
zr> zswap z>r -h 0e zswap z** znegate zr> z+
[ g -h f- 1/f ] FLiteral zscale ;
\ complexe Operationen 02mar05py
: zsinh zexp zdup 1/z z- z2/ ;
: zcosh zexp zdup 1/z z+ z2/ ;
: ztanh z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;
: zsinh ( z -- sinh[z] ) zexp zdup 1/z z- z2/ ;
: zcosh ( z -- cosh[z] ) zexp zdup 1/z z+ z2/ ;
: ztanh ( z -- tanh[z] ) z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;
: zsin z*i zsinh z/i ;
: zcos z*i zcosh ;
: ztan z*i ztanh z/i ;
: zsin ( z -- sin[z] ) z*i zsinh z/i ;
: zcos ( z -- cos[z] ) z*i zcosh ;
: ztan ( z -- tan[z] ) z*i ztanh z/i ;
: Real fdrop ;
: Imag fnip ;
: Real ( z -- r ) fdrop ;
: Imag ( z -- i ) fnip ;
: Re Real 0e ;
: Im Imag 0e ;
: Re ( z -- zr ) Real 0e ;
: Im ( z -- zi ) Imag 0e ;
\ complexe Operationen 02mar05py
: zasinh zdup 1e f+ zover 1e f- z* zsqrt z+ pln ;
: zacosh zdup 1e x- z2/ zsqrt zswap 1e x+ z2/ zsqrt z+
: zasinh ( z -- asinh[z] ) zdup 1e f+ zover 1e f- z* zsqrt z+ pln ;
: zacosh ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt zswap 1e x+ z2/ zsqrt z+
pln z2* ;
: zatanh zdup 1e x+ zln zswap 1e x- znegate pln z- z2/ ;
: zacoth znegate zdup 1e x- pln zswap 1e x+ pln z- z2/ ;
: zatanh ( z -- atanh[z] ) zdup 1e x+ zln zswap 1e x- znegate pln z- z2/ ;
: zacoth ( z -- acoth[z] ) znegate zdup 1e x- pln zswap 1e x+ pln z- z2/ ;
pi f2/ FConstant pi/2
: zasin ( f: z -- -iln[iz+sqrt[1-z^~2]] ) z*i zasinh z/i ;
: zacos ( f: z -- pi/2-asin[z] ) pi/2 0e zswap zasin z- ;
: zatan ( f: z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;
: zacot ( f: z -- [ln[[z+i]/[z-i]]/2i ) z*i zacoth z/i ;
: zasin ( z -- -iln[iz+sqrt[1-z^~2]] ) z*i zasinh z/i ;
: zacos ( z -- pi/2-asin[z] ) pi/2 0e zswap zasin z- ;
: zatan ( z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;
: zacot ( z -- [ln[[z+i]/[z-i]]/2i ) z*i zacoth z/i ;
\ Ausgabe 24sep05py
Defer fc. ' f. IS fc.
: z. zdup z0= IF zdrop ." 0 " exit THEN
: z. ( z -- )
zdup z0= IF zdrop ." 0 " exit THEN
fdup f0= IF fdrop fc. exit THEN fswap
fdup f0= IF fdrop
ELSE fc.
fdup f0> IF ." +" THEN THEN
fc. ." i " ;
: z.s zdepth 0 ?DO i zpick zswap z>r z. zr> LOOP ;
: z.s ( z1 .. zn -- z1 .. zn )
zdepth 0 ?DO i zpick zswap z>r z. zr> LOOP ;
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