Menu
▾
▴
[Win32forth-cvs] win32forth/src FLOAT.F,1.28,1.29
|
From: George H. <geo...@us...> - 2006-02-01 11:45:15
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv969/win32forth/src Modified Files: FLOAT.F Log Message: gah: More Dexing (still work in progress) Index: FLOAT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v retrieving revision 1.28 retrieving revision 1.29 diff -C2 -d -r1.28 -r1.29 *** FLOAT.F 30 Jan 2006 13:58:10 -0000 1.28 --- FLOAT.F 1 Feb 2006 11:44:48 -0000 1.29 *************** *** 150,154 **** ! \ FEXAM results: \ Class C3 C2 C0 \ Unsupported 0 0 0 --- 150,154 ---- ! \ FXAM results: \ Class C3 C2 C0 \ Unsupported 0 0 0 *************** *** 394,398 **** : FVALUE ( compiling -<name>- -- FS: r -- ; run-time FS: -- r ) \ W32F Floating extra \ *G Define a floating point value initialised from the FP stack. ! create here B/FLOAT allot f! ;code fld fsize 4 [eax] --- 394,398 ---- : FVALUE ( compiling -<name>- -- FS: r -- ; run-time FS: -- r ) \ W32F Floating extra \ *G Define a floating point value initialised from the FP stack. ! create f, ;code fld fsize 4 [eax] *************** *** 433,437 **** \ ** Place r on the floating-point stack. ! create here f! B/FLOAT allot ;code fld fsize 4 [eax] --- 433,437 ---- \ ** Place r on the floating-point stack. ! create f, ;code fld fsize 4 [eax] *************** *** 601,604 **** --- 601,611 ---- float; + + code f0.0 ( FS: -- r ) \ W32F Floating extra + \ *G Push plus zero on to the FP stack. + fldz + FPU> + float; + code f1.0 ( fs: -- r ) \ W32F Floating extra \ *G Push the value 1.0 on to the FP stack. *************** *** 633,641 **** B/FLOAT 10 = nostack [IF] stack-check - \ TODO replace f1.0 fvariable with fconstant - fvariable af0 - 0 af0 ! 0 af0 cell+ ! 0 af0 2 cells+ w! - - : f0.0 af0 f@ ; f0.0 fconstant finf \ infinity --- 640,643 ---- *************** *** 684,691 **** [ELSE] ( 8 byte mode ) stack-check - f1.0 fconstant f0.0 ( FS: -- r ) \ W32F Floating extra - \ *G Push plus zero. - ' f0.0 >body 0 over ! 0 swap cell+ ! - f0.0 fconstant finf ( FS: -- r ) \ W32F Floating extra \ *G Push plus infinity. --- 686,689 ---- *************** *** 769,773 **** macro: (fround) fstack-check_1 - >FPU set-rounding-mode --- 767,770 ---- *************** *** 775,779 **** FPU> restore-rounding-mode - endm --- 772,775 ---- *************** *** 822,826 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Integer to float coversion code D>F ( d -- ) ( F: -- r ) \ ANSI Floating --- 818,822 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Integer to float conversion code D>F ( d -- ) ( F: -- r ) \ ANSI Floating *************** *** 843,847 **** \ ** to fit in a double number then \n -9223372036854775808 is returned. fstack-check_1 - >FPU push ebx --- 839,842 ---- *************** *** 853,872 **** pop ebx xchg ebx, 0 [esp] - float; ! code ZF>D ( -- d ) ( fs: r -- ) \ ? out of range errors ? fstack-check_1 - >FPU sub esp, # 8 fistp qword 0 [esp] xchg ebx, 4 [esp] - float; ! : s>f s>d d>f ; ! : f>s f>d drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 848,868 ---- pop ebx xchg ebx, 0 [esp] float; ! code ZF>D ( -- d ) ( fs: r -- ) \ W32F Floating extra fstack-check_1 >FPU sub esp, # 8 fistp qword 0 [esp] xchg ebx, 4 [esp] float; ! : s>f ( n -- ) ( fs: -- r ) \ W32F Floating extra ! \ *G Convert the single number n to floating point number r. ! s>d d>f ; ! : f>s ( -- n ) ( fs: r -- ) \ W32F Floating extra ! \ *G Convert the floating point number r to single number n. ! f>d drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 874,879 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! code FS>DS ( -- d ) ( f: r -- ) \ move floating point number bits to ! \ data stack as a 64-bit float fstack-check_1 >fpu --- 870,876 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! code FS>DS ( -- d ) ( f: r -- ) \ W32F Floating extra ! \ *G Move floating point number bits to the data stack as a 64-bit float. ! \ ** This function is for passing floats to DLLs. fstack-check_1 >fpu *************** *** 886,891 **** \ from Jos v.d. Ven ! \ Push the top of the float stack onto the data stack as a 32-bit float ! code SFS>DS ( -- float ) ( fs: r -- ) \ 10 b/float fstack-check_1 >fpu --- 883,890 ---- \ from Jos v.d. Ven ! ! code SFS>DS ( -- float ) ( fs: r -- ) \ W32F Floating extra ! \ *G Push the top of the float stack onto the data stack as a 32-bit float. ! \ ** This function is for passing floats to DLLs. fstack-check_1 >fpu *************** *** 917,937 **** in-application ! code fcomppx ( -- flags ) ( fs: r1 r2 -- ) fstack-check_2 - 2>FPU fcompp (fcomp) - float; ! code ftstp ( -- flags ) ( fs: r1 -- ) fstack-check_1 - >FPU ftst (fcomp) fstp st \ pop - float; --- 916,932 ---- in-application ! code fcomppx ( -- flags ) ( fs: r1 r2 -- ) \ for comparing 2 FP values fstack-check_2 2>FPU fcompp (fcomp) float; ! code ftstp ( -- flags ) ( fs: r1 -- ) \ for comparison with 0.0e0 fstack-check_1 >FPU ftst (fcomp) fstp st \ pop float; *************** *** 940,966 **** \ *N Comparison operators ! : F0= ( -- f ) ( fs: r -- ) ftstp FCOMP_EQUAL = ; ! : F0< ( -- f ) ( fs: r -- ) ftstp FCOMP_LESS = ; ! : f0> ( -- f ) ( fs: r -- ) ftstp 0= ; ! : f= ( -- f ) ( fs: r1 r2 -- ) fcomppx FCOMP_EQUAL = ; ! : F< ( -- f ) ( fs: r1 r2 -- ) fcomppx FCOMP_LESS = ; ! : f> ( -- f ) ( fs: r1 r2 -- ) fcomppx 0= ; ! : f<= ( -- f ) ( fs: r1 r2 -- ) f> not ; ! : f>= ( -- f ) ( fs: r1 r2 -- ) f< not ; ! : FMAX ( fs: r1 r2 -- r3 ) f2dup f< IF fswap THEN fdrop ; ! : FMIN ( fs: r1 r2 -- r3 ) f2dup f> IF fswap THEN fdrop ; --- 935,975 ---- \ *N Comparison operators ! : F0= ( -- f ) ( fs: r -- ) \ ANSI Floating ! \ *G Return true if r equals ±0e0. Returns false for NAN. ftstp FCOMP_EQUAL = ; ! : F0< ( -- f ) ( fs: r -- ) \ ANSI Floating ! \ *G Return true if r is less than ±0e0. Returns false for NAN. ftstp FCOMP_LESS = ; ! : f0> ( -- f ) ( fs: r -- ) \ W32F Floating extra ! \ *G Return true if r is greater than ±0e0. Returns false for NAN. ftstp 0= ; ! : f= ( -- f ) ( fs: r1 r2 -- ) \ W32F Floating extra ! \ *G Return true if r1 equals r2. Returns false if either number is a NAN. fcomppx FCOMP_EQUAL = ; ! : F< ( -- f ) ( fs: r1 r2 -- ) \ ANSI Floating ! \ *G Return true if r1 is less than r2. Returns false if either number is a NAN. fcomppx FCOMP_LESS = ; ! : f> ( -- f ) ( fs: r1 r2 -- ) \ W32F Floating extra ! \ *G Return true if r1 is greater than r2. Returns false if either number is a NAN. fcomppx 0= ; ! : f<= ( -- f ) ( fs: r1 r2 -- ) \ W32F Floating extra ! \ *G Return true if r1 is less than or equal to r2. Returns true if either number ! \ ** is a NAN. f> not ; ! : f>= ( -- f ) ( fs: r1 r2 -- ) \ W32F Floating extra ! \ *G Return true if r1 is greater than or equal to r2. Returns true if either number ! \ ** is a NAN. f< not ; ! : FMAX ( fs: r1 r2 -- r3 ) \ ANSI Floating ! \ *G Return r3 the maximum of r1 and r2. If r1 is a NAN then so is r3. If r2 is a NAN ! \ ** then r3=r1. f2dup f< IF fswap THEN fdrop ; ! : FMIN ( fs: r1 r2 -- r3 ) \ ANSI Floating ! \ *G Return r3 the minimum of r1 and r2. If r1 is a NAN then so is r3. If r2 is a NAN ! \ ** then r3=r1. f2dup f> IF fswap THEN fdrop ; *************** *** 969,973 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Maths operators code F+ ( fs: r1 r2 -- r3 ) \ ANSI Floating --- 978,982 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Arithmetic operators code F+ ( fs: r1 r2 -- r3 ) \ ANSI Floating *************** *** 1012,1016 **** float; ! code f2/ ( fs: r1 -- r2 ) fstack-check_1 fld1 --- 1021,1026 ---- float; ! code f2/ ( fs: r1 -- r2 ) \ W32F Floating extra ! \ *G Multiply by 2. fstack-check_1 fld1 *************** *** 1022,1026 **** float; ! code f2* ( fs: r1 -- r2 ) \ ? overflow error fstack-check_1 fld1 --- 1032,1037 ---- float; ! code f2* ( fs: r1 -- r2 ) \ W32F Floating extra ! \ *G Divide by 2. fstack-check_1 fld1 *************** *** 1046,1113 **** float; ! code FLN ( fs: r1 -- r2 ) ! fstack-check_1 ! fldln2 ! >FPU ! fabs \ ? error if arg < 0 ! fyl2x ! FPU> ! float; ! code FACOSH ( fs: r1 -- r2 ) \ ? error for x < 1 fstack-check_1 - fldln2 - >FPU - fabs - fld st(0) - fmul st(0), st(0) fld1 ! fsubp st(1), st(0) ! fabs ! fsqrt ! faddp st(1), st(0) ! fyl2x ! FPU> ! float; ! ! code FASINH ( fs: r1 -- r2 ) \ Note: well defined for r1 < 0 ! fstack-check_1 ! ! fldln2 ! >FPU ! fld st(0) fmul st(0), st(0) ! fld1 ! faddp st(1), st(0) ! fsqrt ! faddp st(1), st(0) ! fyl2x ! FPU> ! float; ! internal code (fsin) ( f: r1 -- r2 ) fstack-check_1 - >FPU fsin FPU> - float; code (fcos) ( f: r1 -- r2 ) fstack-check_1 - >FPU fcos FPU> - float; code (fsincos) ( f: r1 -- r2 r3 ) fstack-check_1 - >FPU fsincos --- 1057,1105 ---- float; ! internal ! code f**+n ( f: r1 -- r2 ; n -- ) fstack-check_1 fld1 ! or tos, tos ! je short L$5 ! >fpu ! fxch st(1) ! L$1: shr tos, # 1 ! jnc short L$2 ! fmul st(0), st(1) ! L$2: jz short L$3 ! fxch st(1) fmul st(0), st(0) ! fxch st(1) ! jmp short L$1 ! L$3: fxch st(1) ! fstp st(0) ! L$5: fpu> ! pop tos float; ! : f**n ( F: r1 -- r2 ; n -- ) \ Floating number raised to integer power. ! DUP 0< ! IF ABS F**+N F1.0 FSWAP F/ ! ELSE F**+N ! THEN ; code (fsin) ( f: r1 -- r2 ) fstack-check_1 >FPU fsin FPU> float; code (fcos) ( f: r1 -- r2 ) fstack-check_1 >FPU fcos FPU> float; code (fsincos) ( f: r1 -- r2 r3 ) fstack-check_1 >FPU fsincos *************** *** 1115,1123 **** FPU> FPU> - float; - \ January 13th, 1998 - 9:33 tjz for RLS - \ corrected branch destination for L$3 code frem2pi ( f: r1 -- r2 ) fstack-check_1 --- 1107,1112 ---- *************** *** 1140,1143 **** --- 1129,1137 ---- external + + : 1/f ( fs: r1 -- r2 ) \ W32F Floating extra + \ *G r2 is the reciprocal of r1. + -1 f**n ; + \ *N Trigonometric functions *************** *** 1217,1228 **** \ *N Logarithmic functions code FLNP1 ( fs: r1 -- r2 ) \ ANSI Floating ext \ *G ? error for x <= -1 fstack-check_1 - fldln2 - >FPU - fld FSIZE sq2m1 fcomp st(1) --- 1211,1227 ---- \ *N Logarithmic functions + code FLN ( fs: r1 -- r2 ) \ ANSI Floating ext + fstack-check_1 + fldln2 + >FPU + fyl2x + FPU> + float; + code FLNP1 ( fs: r1 -- r2 ) \ ANSI Floating ext \ *G ? error for x <= -1 fstack-check_1 fldln2 >FPU fld FSIZE sq2m1 fcomp st(1) *************** *** 1237,1243 **** jb short L$4 fyl2xp1 - (FPU>) \ Used to balance branches - jmp short L$2 L$4: fld1 \ add the "1" explicitly --- 1236,1240 ---- *************** *** 1245,1273 **** fabs fyl2x - FPU> - jmp short L$2 L$3: fcompp \ return arg if incomparable - L$2: float; ! code FLOG ( fs: r1 -- r2 ) fstack-check_1 - fldlg2 - fabs \ ? error for x <= 0 >FPU fyl2x FPU> float; ! code FEXPM1 ( fs: r1 -- r2 ) \ ? overflow error ! mov ecx, FSP_MEMORY ! sub ecx, # B/FLOAT ! js short L$1 fldl2e ! fld FSIZE FSTACK_MEMORY fld1 fcom st(1) --- 1242,1284 ---- fabs fyl2x FPU> jmp short L$2 L$3: fcompp \ return arg if incomparable L$2: float; ! code FLOG ( fs: r1 -- r2 ) \ ANSI Floating ext fstack-check_1 fldlg2 >FPU fyl2x FPU> + float; + + \ *N Exponential functions + code FEXP ( fs: r1 -- r2 ) \ ANSI Floating ext + fstack-check_1 + fldl2e \ log base 2 of e \ 1 + >FPU \ 2 + fmulp st(1), st \ modified exponent \ 1 + fld st(0) \ duplicate exponent \ 2 + frndint \ take integer part \ 2 + fsub st(1), st \ get fractional part \ 2 + fld1 \ 3 + fscale \ 2**int \ 3 + fstp st(1) \ remove unneeded part \ 2 + fxch st(1) \ frac \ 2 + f2xm1 \ (2**frac) - 1 \ 2 + fld1 \ 1.0 \ 3 + faddp st(1), st \ 2**frac \ 2 + fmulp st(1), st \ 2**(int + frac) \ 1 + FPU> \ 0 float; ! code FEXPM1 ( fs: r1 -- r2 ) \ ANSI Floating ext ! ! fstack-check_1 fldl2e ! >fpu fld1 fcom st(1) *************** *** 1283,1287 **** fmulp st(1), st(0) f2xm1 ! fstp FSIZE FSTACK_MEMORY jmp short L$2 L$4: fstp st(0) \ 2 --- 1294,1298 ---- fmulp st(1), st(0) f2xm1 ! (fpu>) jmp short L$2 L$4: fstp st(0) \ 2 *************** *** 1290,1297 **** jp short L$3 frndint \ take integer part \ 2 - \ June 5th, 1996 - 16:03 tjz changed to FSUB which should be correct, since - \ the FSUBR instruction was used to correct for a bug in the MPE assembler fsub st(1), st \ get fractional part \ 2 - \ fsubr st(1), st \ get fractional part \ 2 fld1 \ 3 fscale \ 2**int \ 3 --- 1301,1305 ---- *************** *** 1304,1341 **** fld1 fsubp st(1), st \ Should be fsubrp ??????? ! fstp FSIZE FSTACK_MEMORY \ 0 jmp short L$2 L$3: fstp st(1) ! jmp short L$2 ! L$1: mov esi, # ' FSTKUFLO >body ! L$2: next, ! end-code ! code FEXP ( fs: r1 -- r2 ) \ ? error for x too large ! fstack-check_1 ! fldl2e \ log base 2 of e \ 1 ! >FPU \ 2 ! fmulp st(1), st \ modified exponent \ 1 ! fld st(0) \ duplicate exponent \ 2 ! frndint \ take integer part \ 2 ! \ June 5th, 1996 - 16:03 tjz changed to FSUB which should be correct, since ! \ the FSUBR instruction was used to correct for a bug in the MPE assembler ! fsub st(1), st \ get fractional part \ 2 ! \ fsubr st(1), st \ get fractional part \ 2 ! fld1 \ 3 ! fscale \ 2**int \ 3 ! fstp st(1) \ remove unneeded part \ 2 ! fxch st(1) \ frac \ 2 ! f2xm1 \ (2**frac) - 1 \ 2 ! fld1 \ 1.0 \ 3 ! faddp st(1), st \ 2**frac \ 2 ! fmulp st(1), st \ 2**(int + frac) \ 1 ! FPU> \ 0 ! float; ! : FCOSH ( f: r1 -- r2 ) \ ? error for x too large ! fabs fexp f1.0 fover f/ f+ f2/ ; ! : FTANH ( f: r1 -- r2 ) \ should be OK for legal args fdup fabs f1.0 f< IF f2* fexpm1 fdup f2.0 f+ f/ --- 1312,1347 ---- fld1 fsubp st(1), st \ Should be fsubrp ??????? ! fpu> jmp short L$2 L$3: fstp st(1) ! L$2: float; ! : f** ( F: r1 r2 -- r3 ) ! fswap fln f* fexp ; ! synonym f^x f** DEPRECATED ! internal ! ! : (fsinh) ( f: r1 -- r2 ) \ hyperbolic sine, more accurate for positive. ! fexp fdup 1/f f- f2/ ; ! ! external ! ! \ *N Hyperbolic functions ! ! : FSINH ( f: r1 -- r2 ) \ ANSI Floating ext ! \ *G r2 is the hyperbolic sine of r1. ! fdup f0< ! IF fabs (fsinh) fnegate ! ELSE (fsinh) ! THEN ; ! ! : FCOSH ( f: r1 -- r2 ) \ ANSI Floating ext ! \ *G r2 is the hyperbolic cosine of r1. ! fabs fexp fdup 1/f f+ f2/ ; ! ! : FTANH ( f: r1 -- r2 ) \ ANSI Floating ext ! \ *G r2 is the hyperbolic tangent of r1, |r2| <= 1. fdup fabs f1.0 f< IF f2* fexpm1 fdup f2.0 f+ f/ *************** *** 1347,1370 **** THEN ; ! internal ! ! : (fsinh) ( f: r1 -- r2 ) ! fexp f1.0 fover f/ f- f2/ ; ! external ! : FSINH ( f: r1 -- r2 ) \ ? overflow error ? ! fdup f0< ! IF fabs (fsinh) fnegate ! ELSE (fsinh) ! THEN ; : FATANH ( f: r1 -- r2 ) \ OK for valid args ! fdup f1.0 f+ fdup f0= ! IF f2drop finf fnegate EXIT ! THEN ! fswap f1.0 f- fdup f0= ! IF f2drop finf EXIT ! THEN f/ fln f2/ ; --- 1353,1389 ---- THEN ; ! \ *N Inverse hyperbolic functions ! code FASINH ( fs: r1 -- r2 ) \ Note: well defined for r1 < 0 ! fstack-check_1 ! fldln2 ! >FPU ! fld st(0) ! fmul st(0), st(0) ! fld1 ! faddp st(1), st(0) ! fsqrt ! faddp st(1), st(0) ! fyl2x ! FPU> ! float; ! code FACOSH ( fs: r1 -- r2 ) \ ANSI Floating ext ! fstack-check_1 ! fldln2 ! >FPU ! fld st(0) ! fmul st(0), st(0) ! fld1 ! fsubp st(1), st(0) ! fsqrt ! faddp st(1), st(0) ! fyl2x ! FPU> ! float; : FATANH ( f: r1 -- r2 ) \ OK for valid args ! fdup f1.0 f+ ! fswap f1.0 fswap f- f/ fln f2/ ; *************** *** 1501,1550 **** internal - code f**+n ( f: r1 -- r2 ; n -- ) - fstack-check_1 - fld1 - or tos, tos - je short L$5 - >fpu - fxch st(1) - L$1: shr tos, # 1 - jnc short L$2 - fmul st(0), st(1) - L$2: jz short L$3 - fxch st(1) - fmul st(0), st(0) - fxch st(1) - jmp short L$1 - L$3: fxch st(1) - fstp st(0) - L$5: fpu> - pop tos - float; - - : f**n ( F: r1 -- r2 ; n -- ) \ Floating number raised to integer power. - DUP 0< - IF ABS F**+N F1.0 FSWAP F/ - ELSE F**+N - THEN ; - - external - - \ rbs January 26th, 2003 --> - \ : F** ( F: r1 r2 -- r3 ) - \ fdup fround fdup f>s f- \ r1 r4 - \ fdup f0= 0= - \ IF \ non-zero fractional part of exponent - \ fover fabs fln f* fexp fswap f**n f* - \ ELSE fdrop f**n - \ THEN ; - - : f** ( F: r1 r2 -- r3 ) - fswap fln f* fexp ; - - synonym f^x f** DEPRECATED - \ <-- rbs - - internal - fvariable ftemp 128 newuser $ftemp --- 1520,1523 ---- *************** *** 2090,2095 **** synonym fsqr fsqrt deprecated - : 1/f -1 f**n ; - : f>r r> rp@ b/float - rp! rp@ f! >r ; deprecated --- 2063,2066 ---- |
