Menu
▾
▴
[Win32forth-cvs] win32forth/src FLOAT.F,1.23,1.24
|
From: George H. <geo...@us...> - 2006-01-16 15:47:58
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25551/win32forth/src Modified Files: FLOAT.F Log Message: gah: Further optimisations and some dexing (work in progress) Index: FLOAT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v retrieving revision 1.23 retrieving revision 1.24 diff -C2 -d -r1.23 -r1.24 *** FLOAT.F 13 Jan 2006 12:05:01 -0000 1.23 --- FLOAT.F 16 Jan 2006 15:47:50 -0000 1.24 *************** *** 37,40 **** --- 37,59 ---- \ ------------------------------------------------------------------------- + \ *! doc\p-float W32F float + \ *T Floating point words in Win32Forth + + \ *P Win32Forth implements the full ANSI floating-point and floating-point extension + \ ** wordsets as well as a number of useful extra words. It uses a separate floating-point + \ ** stack (implemented in the USER area for task safety). + + \ *P The floating-point words can be compiled as 8 bit (for speed) or 10 bit (for accuracy). + \ ** The default when the system is built is 8 bit, but can be set to 10 bit (in src\extend.f) by + \ ** altering the CONSTANT B/FLOAT and re-extending the system (using setup.exe). + \ ** If the CONSTANT is not defined then the file automatically creates it and compiles + \ ** the code for 10 bit floats. + + \ *P The only error that is thrown is for FP stack Underflow (error code -45); + \ ** arithmetic operations which produce values too large to be represented use infinity, + \ ** while indeterminate results produce NANs. + + \ *S Glossary + cr .( Loading Floating Point...) *************** *** 172,176 **** end-code ! code finit ( -- ) \ W32F Float extra \ *G Clears the floating-point stack & sets the appropriate byte mode. \ ** It is executed by the system on start-up and by the default exception handler. --- 191,195 ---- end-code ! code finit ( -- ) \ W32F Floating extra \ *G Clears the floating-point stack & sets the appropriate byte mode. \ ** It is executed by the system on start-up and by the default exception handler. *************** *** 205,208 **** --- 224,235 ---- 0 value fsp-adjust + macro: +fsp-adjust + b/float +to fsp-adjust + endm + + macro: -fsp-adjust + b/float negate +to fsp-adjust + endm + \ makro to copy ST(0) on the seperate float stack macro: (FPU>) *************** *** 214,222 **** ! \ makro to move ST(0) on the seperate float stack macro: FPU> (FPU>) ! \ add ecx, # B/FLOAT ! B/FLOAT +to fsp-adjust endm --- 241,248 ---- ! \ macro to move ST(0) on the seperate float stack macro: FPU> (FPU>) ! +fsp-adjust endm *************** *** 226,231 **** mov ecx, FSP_MEMORY true to fsp-cached? then ! \ sub ecx, # B/FLOAT ! b/float negate +to fsp-adjust fld FSIZE fsp-adjust +FSTACK_MEMORY endm --- 252,256 ---- mov ecx, FSP_MEMORY true to fsp-cached? then ! -fsp-adjust fld FSIZE fsp-adjust +FSTACK_MEMORY endm *************** *** 234,239 **** macro: (>FPU) >FPU ! \ add ecx, # B/FLOAT ! b/float +to fsp-adjust endm --- 259,263 ---- macro: (>FPU) >FPU ! +fsp-adjust endm *************** *** 293,347 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! code F@ ( addr -- ) ( FS: -- r ) \ fetch a float fld FSIZE DATASTACK_MEMORY FPU> - pop ebx float; ! code SF@ ( addr -- ) ( FS: -- r ) \ fetch a 32 bit (short) float fld float DATASTACK_MEMORY FPU> - pop ebx float; ! code DF@ ( addr -- ) ( FS: -- r ) \ fetch a 64 bit (double) float fld double DATASTACK_MEMORY FPU> - pop ebx float; ! code F! ( addr -- ) ( fs: r -- ) \ store a float fstack-check_1 - >FPU fstp FSIZE DATASTACK_MEMORY - pop ebx float; ! code SF! ( addr -- ) ( fs: r -- ) \ store a 32 bit (short) float fstack-check_1 - >FPU fstp float DATASTACK_MEMORY - pop ebx float; ! code DF! ( addr -- ) ( fs: r -- ) \ store a 64 bit (double) float fstack-check_1 - >FPU fstp double DATASTACK_MEMORY - pop ebx float; ! code F+! ( addr -- ) ( fs: r -- ) \ ? overflow error fstack-check_1 - >FPU fld FSIZE DATASTACK_MEMORY --- 317,370 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Memory Access ! ! code F@ ( addr -- ) ( FS: -- r ) \ ANSI Floating ! \ *G Fetch a float. fld FSIZE DATASTACK_MEMORY FPU> pop ebx float; ! code SF@ ( addr -- ) ( FS: -- r ) \ ANSI Floating ext ! \ *G Fetch a 32 bit (short) float. fld float DATASTACK_MEMORY FPU> pop ebx float; ! code DF@ ( addr -- ) ( FS: -- r ) \ ANSI Floating ext ! \ *G Fetch a 64 bit (double) float. fld double DATASTACK_MEMORY FPU> pop ebx float; ! code F! ( addr -- ) ( fs: r -- ) \ ANSI Floating ! \ *G Store a float. fstack-check_1 >FPU fstp FSIZE DATASTACK_MEMORY pop ebx float; ! code SF! ( addr -- ) ( fs: r -- ) \ ANSI Floating ext ! \ *G Store a 32 bit (short) float. fstack-check_1 >FPU fstp float DATASTACK_MEMORY pop ebx float; ! code DF! ( addr -- ) ( fs: r -- ) \ ANSI Floating ext ! \ *G Store a 64 bit (double) float. fstack-check_1 >FPU fstp double DATASTACK_MEMORY pop ebx float; ! code F+! ( addr -- ) ( fs: r -- ) \ W32F Floating extra ! \ *G Add the value to a float. fstack-check_1 >FPU fld FSIZE DATASTACK_MEMORY *************** *** 365,375 **** in-system ! : FVARIABLE ( -<name>- ) \ compile time ! ( -- a1 ) \ runtime create B/FLOAT allot ; ! : FVALUE \ compiletime: ( FS: n - ) ( -<name>- ) create here B/FLOAT allot f! ! ;code \ runtime: ( FS: - n ) push ebx lea ebx, 4 [eax] --- 388,399 ---- in-system ! : FVARIABLE ( compiling -<name>- -- ; run-time -- addr) \ ANSI Floating ! \ *G Define a floating-point variable in the dictionary. The contents are undefined. create B/FLOAT allot ; ! : 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 push ebx lea ebx, 4 [eax] *************** *** 384,390 **** code _fto ( FS: n - ) ( 'fvalue - ) fstack-check_1 - >FPU ! add ebx, # 4 \ >body fstp FSIZE DATASTACK_MEMORY pop ebx --- 408,413 ---- code _fto ( FS: n - ) ( 'fvalue - ) fstack-check_1 >FPU ! add ebx, # cell \ >body fstp FSIZE DATASTACK_MEMORY pop ebx *************** *** 393,406 **** in-system ! : FTO ! state @ \ compiletime: ( FS: n - ) ( -<name_fvalue>- ) if postpone ['] postpone _fto ! else ' _fto \ runtime: ( FS: n - ) ( 'fvalue - ) then ; IMMEDIATE in-application ! : FCONSTANT ( -<name>- ) ( F: r -- ) \ compile time ! ( F: -- r ) \ runtime create here f! B/FLOAT allot does> f@ ; --- 416,436 ---- in-system ! : FTO \ W32F Floating extra ! \ *G \b Interpreting: ( -<fvalue>- -- FS: r -- ) \n ! \ ** Compiling: ( -<fvalue>- -- Run-time: FS: r -- ) \d ! \ *P Store r into -<fvalue>-. If -<fvalue>- is not defined with fvalue then memory may ! \ ** be corrupted; no checks are made so the user should take care. FTO should not be ! \ ** POSTPONEd. ! state @ if postpone ['] postpone _fto ! else ' _fto then ; IMMEDIATE in-application ! : FCONSTANT \ ANSI Floating ! \ *G \b Compiling: ( -<name>- ) ( F: r -- ) \n ! \ ** \b Run-time: ( F: -- r ) \d \n ! \ *P Define an FP constant. create here f! B/FLOAT allot does> f@ ; *************** *** 411,443 **** code fpush ( f: r -- ) ( fs: -- r ) \ move from FPU on simulated stack FPU> - float; DEPRECATED code fpop ( f: -- r ) ( fs: r -- ) \ move from simulated stack on FPU stack fstack-check_1 - >FPU - float; DEPRECATED ! code FDROP ( fs: r -- ) ! fstack-check_1 sub FSP_MEMORY , # B/FLOAT - float; ! code FDUP ( fs: r -- r r ) fstack-check_1 - - \ TODO optimize (>FPU) FPU> - float; code FSWAP ( fs: r1 r2 -- r2 r1 ) fstack-check_2 - \ TODO optimize 2>FPU --- 441,468 ---- code fpush ( f: r -- ) ( fs: -- r ) \ move from FPU on simulated stack FPU> float; DEPRECATED code fpop ( f: -- r ) ( fs: r -- ) \ move from simulated stack on FPU stack fstack-check_1 >FPU float; DEPRECATED ! \ *N Stack operations + code FDROP ( fs: r -- ) \ ANSI Floating + \ *G Remove r from the floating-point stack. + fstack-check_1 sub FSP_MEMORY , # B/FLOAT float; ! code FDUP ( fs: r -- r r ) \ ANSI Floating ! \ *G Duplicate the top entry on the floating-point stack. fstack-check_1 (>FPU) FPU> float; code FSWAP ( fs: r1 r2 -- r2 r1 ) fstack-check_2 \ TODO optimize 2>FPU *************** *** 450,486 **** code FOVER ( fs: r1 r2 -- r1 r2 r3 ) fstack-check_2 ! ! \ TODO optimize ! mov ecx, FSP_MEMORY ! sub ecx, # B/FLOAT 2* ! fld FSIZE FSTACK_MEMORY ! add ecx, # B/FLOAT 2* fstp FSIZE FSTACK_MEMORY ! add ecx, # B/FLOAT ! mov FSP_MEMORY , ecx ! float; code FROT ( fs: r1 r2 r3 -- r2 r3 r1 ) fstack-check_3 - - \ TODO optimize mov ecx, FSP_MEMORY ! sub ecx, # B/FLOAT ! fld FSIZE FSTACK_MEMORY ! sub ecx, # B/FLOAT ! fld FSIZE FSTACK_MEMORY ! sub ecx, # B/FLOAT ! fld FSIZE FSTACK_MEMORY ! add ecx, # B/FLOAT 2* ! fstp FSIZE FSTACK_MEMORY ! sub ecx, # B/FLOAT 2* ! fstp FSIZE FSTACK_MEMORY ! add ecx, # B/FLOAT ! fstp FSIZE FSTACK_MEMORY ! float; ! code FPICK ( n -- ) ( fs: -- r ) mov eax, ebx inc eax --- 475,503 ---- code FOVER ( fs: r1 r2 -- r1 r2 r3 ) fstack-check_2 ! fld FSIZE b/float 2* negate +FSTACK_MEMORY fstp FSIZE FSTACK_MEMORY ! +fsp-adjust float; code FROT ( fs: r1 r2 r3 -- r2 r3 r1 ) fstack-check_3 mov ecx, FSP_MEMORY ! -fsp-adjust ! fld FSIZE fsp-adjust +FSTACK_MEMORY ! -fsp-adjust ! fld FSIZE fsp-adjust +FSTACK_MEMORY ! -fsp-adjust ! fld FSIZE fsp-adjust +FSTACK_MEMORY ! +fsp-adjust +fsp-adjust ! fstp FSIZE fsp-adjust +FSTACK_MEMORY ! -fsp-adjust -fsp-adjust ! fstp FSIZE fsp-adjust +FSTACK_MEMORY ! +fsp-adjust ! fstp FSIZE fsp-adjust +FSTACK_MEMORY ! +fsp-adjust +fsp-adjust float; ! code FPICK ( n -- ) ( fs: -- r ) \ W32F Floating extra ! \ *G Copy the n'th number from the FP stack. mov eax, ebx inc eax *************** *** 491,511 **** [THEN] call fstack-check - - \ TODO optimize - push edx - mov eax, # B/FLOAT - mul eax, ebx - pop edx - mov ecx, FSP_MEMORY - mov ebx, ecx - sub ecx, # B/FLOAT sub ecx, eax fld FSIZE FSTACK_MEMORY ! mov ecx, ebx ! fstp FSIZE FSTACK_MEMORY ! add ecx, # B/FLOAT ! mov FSP_MEMORY , ecx ! pop ebx float; --- 508,517 ---- [THEN] call fstack-check sub ecx, eax fld FSIZE FSTACK_MEMORY ! add ecx, eax pop ebx + fstp FSIZE FSTACK_MEMORY + +fsp-adjust float; *************** *** 515,521 **** code F2DROP ( fs: r1 r2 -- ) fstack-check_2 - sub FSP_MEMORY , # B/FLOAT 2* - float; --- 521,525 ---- *************** *** 523,527 **** fover fover ; ! : F2SWAP ( fs: r1 r2 r3 r4 -- r3 r4 r2 r1 ) \ W32F Float extra \ *G Swap the top pair of floating-point numbers with the second pair. { \ ftemp -- } --- 527,531 ---- fover fover ; ! : F2SWAP ( fs: r1 r2 r3 r4 -- r3 r4 r2 r1 ) \ W32F Floating extra \ *G Swap the top pair of floating-point numbers with the second pair. { \ ftemp -- } *************** *** 537,557 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! code fpi ( fs: -- r ) \ W32F Float extra ! \ *G Push the value 3.141596... on to the FP stack fldpi FPU> - float; ! code f1.0 ( fs: -- r ) fld1 FPU> - float; ! code fL2t ( fs: -- r ) \ log base 2 of 10 fldl2t FPU> - float; --- 541,562 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Constants ! ! code fpi ( fs: -- r ) \ W32F Floating extra ! \ *G Push the value 3.141596... on to the FP stack. fldpi FPU> float; ! code f1.0 ( fs: -- r ) \ W32F Floating extra ! \ *G Push the value 1.0 on to the FP stack. fld1 FPU> float; ! code fL2t ( fs: -- r ) \ W32F Floating extra ! \ *G Push the value of log base 2 of 10. fldl2t FPU> float; *************** *** 738,760 **** external ! code FLOOR ( fs: f1 -- fs: f2 ) push ebx ! mov bx, # 0x00400 \ Set rounding to -infinity (fround) pop ebx - float; ! code FCEIL ( fs: f1 -- fs: f2 ) \ Added 3/13/99 rls push ebx ! mov bx, # 0x00800 \ Set rounding to +infinity (fround) pop ebx - float; ! code FTRUNC ( fs: f1 -- fs: f2 ) \ Added 3/13/99 rls push ebx ! mov bx, # 0x00c00 \ Set rounding to truncate (fround) pop ebx --- 743,768 ---- external ! \ *N Rounding Modes ! ! code FLOOR ( fs: f1 -- fs: f2 ) \ ANSI Floating ! \ *G Set rounding mode to round to -infinity. push ebx ! mov bx, # 0x00400 (fround) pop ebx float; ! code FCEIL ( fs: f1 -- fs: f2 ) \ W32F Floating wxtra ! \ *G Set rounding mode to round to +infinity. push ebx ! mov bx, # 0x00800 (fround) pop ebx float; ! code FTRUNC ( fs: f1 -- fs: f2 ) \ W32F Floating extra ! \ *G Set rounding mode to truncate. push ebx ! mov bx, # 0x00c00 (fround) pop ebx *************** *** 762,771 **** float; ! code FROUND ( fs: f1 -- fs: f2 ) push ebx ! mov bx, # 0x00000 \ set rounding to nearest (fround) pop ebx - float; --- 770,779 ---- float; ! code FROUND ( fs: f1 -- fs: f2 ) \ ANSI Floating ! \ *G Set rounding mode to round to nearest. push ebx ! mov bx, # 0x00000 (fround) pop ebx float; *************** *** 775,778 **** --- 783,788 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ *N Integer to float coversion + code D>F ( d -- ) ( F: -- r ) lea esp, -4 [esp] *************** *** 794,798 **** >FPU push ebx ! mov bx, # 0x00c00 \ Set rounding to chop set-rounding-mode sub esp, # 8 --- 804,808 ---- >FPU push ebx ! mov bx, # 0x00c00 \ Set rounding to truncate set-rounding-mode sub esp, # 8 *************** *** 918,970 **** code F- ( fs: r1 r2 -- r3 ) \ ? overflow errors fstack-check_2 - 2>FPU ! fxch ! fsubp st(1), st FPU> - float; code F* ( fs: r1 r2 -- r3 ) \ ? overflow errors fstack-check_2 - 2>FPU fmulp st(1), st FPU> - float; code F/ ( fs: r1 r2 -- r3 ) \ ? error for ofl or /0 ? fstack-check_2 - 2>FPU fxch fdivp st(1), st FPU> - float; code FATAN2 ( fs: r1 r2 -- r3 ) \ OK for valid args fstack-check_2 - 2>FPU fxch fpatan FPU> - float; code FNEGATE ( fs: r1 -- r2 ) fstack-check_1 - >FPU fchs FPU> - float; code f2/ ( fs: r1 -- r2 ) fstack-check_1 - fld1 fchs --- 928,969 ---- code F- ( fs: r1 r2 -- r3 ) \ ? overflow errors fstack-check_2 2>FPU ! \ fxch ! fsubrp st(1), st FPU> float; code F* ( fs: r1 r2 -- r3 ) \ ? overflow errors fstack-check_2 2>FPU fmulp st(1), st FPU> float; code F/ ( fs: r1 r2 -- r3 ) \ ? error for ofl or /0 ? fstack-check_2 2>FPU fxch fdivp st(1), st FPU> float; code FATAN2 ( fs: r1 r2 -- r3 ) \ OK for valid args fstack-check_2 2>FPU fxch fpatan FPU> float; code FNEGATE ( fs: r1 -- r2 ) fstack-check_1 >FPU fchs FPU> float; code f2/ ( fs: r1 -- r2 ) fstack-check_1 fld1 fchs *************** *** 973,982 **** FPU> fstp st(0) - float; code f2* ( fs: r1 -- r2 ) \ ? overflow error fstack-check_1 - fld1 >FPU --- 972,979 ---- *************** *** 984,1012 **** FPU> fstp st(0) - float; code FABS ( fs: r1 -- r2 ) fstack-check_1 - >FPU fabs FPU> - float; code FSQRT ( fs: r1 -- r2 ) fstack-check_1 - >FPU fabs \ ? error for x < 0 ? fsqrt FPU> - float; code FLN ( fs: r1 -- r2 ) fstack-check_1 - fldln2 >FPU --- 981,1003 ---- *************** *** 1014,1023 **** fyl2x FPU> - float; code FACOSH ( fs: r1 -- r2 ) \ ? error for x < 1 fstack-check_1 - fldln2 >FPU --- 1005,1012 ---- *************** *** 1032,1036 **** fyl2x FPU> - float; --- 1021,1024 ---- *************** *** 2030,2036 **** \ <-- rbs ! \ ****************************************************************** \ Debugging tools ! \ ****************************************************************** create allregs 110 allot --- 2018,2024 ---- \ <-- rbs ! \ \****************************************************************** \ Debugging tools ! \ \****************************************************************** create allregs 110 allot *************** *** 2255,2256 **** --- 2243,2245 ---- )) + \ *Z |
