Menu
▾
▴
[Win32forth-cvs] win32forth/src FLOAT.F,1.39,1.40
|
From: George H. <geo...@us...> - 2006-02-21 11:04:01
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15442/win32forth/src Modified Files: FLOAT.F Log Message: gah: More Dexing (still work in progress) optimizations and bug fixes Index: FLOAT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v retrieving revision 1.39 retrieving revision 1.40 diff -C2 -d -r1.39 -r1.40 *** FLOAT.F 20 Feb 2006 12:32:45 -0000 1.39 --- FLOAT.F 21 Feb 2006 11:03:56 -0000 1.40 *************** *** 457,462 **** : 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 --- 457,462 ---- : FTO \ W32F Floating extra ! \ *G \b Interpretation: ( -<fvalue>- -- FS: r -- ) \n ! \ ** Compilation: ( -<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 *************** *** 624,628 **** 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 -- } --- 624,628 ---- fover fover ; ! : F2SWAP ( fs: r1 r2 r3 r4 -- r3 r4 r1 r2 ) \ W32F Floating extra \ *G Swap the top pair of floating-point numbers with the second pair. { \ ftemp -- } *************** *** 704,707 **** --- 704,719 ---- B/FLOAT 10 = [IF] + f0.0 fconstant fbig + ' fbig >body -1 over ! nostack + -1 over cell+ ! + 0x7ffe swap 2 cells+ w! stack-check + + f0.0 fconstant feps \ smallest non-zero-number + 1 ' feps >body ! + + f0.0 fconstant fsmall + 0 ' fsmall >body tuck ! 0x80000000 over cell+ ! + 1 swap 2 cells+ w! + fvariable a2**63 0 a2**63 ! 0x80000000 a2**63 cell+ ! *************** *** 719,734 **** 0xbffd sq2/2m1 2 cells+ w! - f0.0 fconstant fbig - ' fbig >body -1 over ! nostack - -1 over cell+ ! - 0x7ffe swap 2 cells+ w! stack-check - - f0.0 fconstant feps \ smallest non-zero-number - 1 ' feps >body ! - - f0.0 fconstant fsmall - 0 ' fsmall >body tuck ! 0x80000000 over cell+ ! - 1 swap 2 cells+ w! - [ELSE] ( 8 byte mode ) --- 731,734 ---- *************** *** 1098,1101 **** --- 1098,1130 ---- float; + internal + + : (F~) ( -- f ; fs: r1 r2 r3 -- ) + frot frot f- fabs f> ; + + external + + \ July 29th, 1998 - 8:53 tjz + \ added '@' after FLOATSP to fix a bug reported by Pierre Abbat + : F~ ( -- flag ; fs: r1 r2 r3 -- ) \ ANSI Floating ext + \ *G If r3 is positive, flag is true if the absolute value of (r1 minus r2) is less than + \ ** r3. If r3 is zero, flag is true if the implementation-dependent encoding of r1 and + \ ** r2 are exactly identical (positive and negative zero are unequal). + \ ** If r3 is negative, flag is true if the absolute value of (r1 minus r2) is less than the + \ ** absolute value of r3 times the sum of the absolute values of r1 and r2. + \ *P This provides the three types of floating point equality in common use -- close in + \ ** absolute terms, exact equality as represented, and relatively close. + fdup f0< + IF fabs fover fabs 3 fpick fabs f+ f* \ r1 r2 r3*(r1+r2) + (f~) + ELSE fdup f0= + IF fdrop FLOATSTACK FLOATSP @ + B/FLOAT - dup B/FLOAT - + swap B/FLOAT swap B/FLOAT str= + f2drop + ELSE + (f~) + THEN + THEN ; + \ The following constants are documented earlier *************** *** 1476,1502 **** f/ fln f2/ ; - \ July 29th, 1998 - 8:53 tjz - \ added '@' after FLOATSP to fix a bug reported by Pierre Abbat - : F~ ( -- flag ; fs: r1 r2 r3 -- ) \ ANSI Floating ext - \ *G If r3 is positive, flag is true if the absolute value of (r1 minus r2) is less than - \ ** r3. If r3 is zero, flag is true if the implementation-dependent encoding of r1 and - \ ** r2 are exactly identical (positive and negative zero are unequal). - \ ** If r3 is negative, flag is true if the absolute value of (r1 minus r2) is less than the - \ ** absolute value of r3 times the sum of the absolute values of r1 and r2. - \ *P This provides the three types of floating point equality in common use -- close in - \ ** absolute terms, exact equality as represented, and relatively close. - fdup f0< - IF fabs fover fabs 3 fpick fabs f+ f* \ r1 r2 r3*(r1+r2) - frot frot f- fabs fswap f< - ELSE fdup f0= - IF fdrop FLOATSTACK FLOATSP @ + B/FLOAT - dup B/FLOAT - - swap B/FLOAT swap B/FLOAT str= - f2drop - ELSE \ January 16th, 1998 rls add "fswap" - frot frot f- fabs fswap f< - THEN - THEN ; - - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ floating point defining words and array operators --- 1505,1508 ---- *************** *** 1629,1636 **** cell newuser mantsign ! cell newuser expsign cell newuser intcnt cell newuser fracnt ! cell newuser expcnt cell newuser charcnt cell newuser zerochar --- 1635,1642 ---- cell newuser mantsign ! \ cell newuser expsign \ seems to only be set to 0 ! cell newuser intcnt cell newuser fracnt ! \ cell newuser expcnt \ seems to only be set to 0 ! cell newuser charcnt cell newuser zerochar *************** *** 1638,1644 **** 128 newuser $fsignif 10 newuser fbcd-buf ! fvariable ftemp ! 128 newuser $ftemp ! create $ftemp1 128 allot : 10**n ( fs: -- r ) ( n -- ) \ 10 raised to n --- 1644,1649 ---- 128 newuser $fsignif 10 newuser fbcd-buf ! ! create $ftemp1 128 allot deprecated \ doesn't appear to be used! : 10**n ( fs: -- r ) ( n -- ) \ 10 raised to n *************** *** 1648,1658 **** 10**n f0.5 f- ; - code f>bcd ( fs: r -- ) ( addr -- ) - fstack-check_1 - >fpu - fbstp DATASTACK_MEMORY - pop tos - float; - : bcd-char@ ( n -- char ) dup 1 and swap 2/ fbcd-buf + c@ swap --- 1653,1656 ---- *************** *** 1718,1723 **** : init->float ( -- ) ! 0 expsign ! 0 intcnt ! \ initialize various ! 0 fracnt ! 0 expcnt ! \ counts and such 0 zerochar ! 0 mantsign ! false havedigits ! --- 1716,1721 ---- : init->float ( -- ) ! ( 0 expsign ! ) 0 intcnt ! \ initialize various ! 0 fracnt ! ( 0 expcnt ! ) \ counts and such 0 zerochar ! 0 mantsign ! false havedigits ! *************** *** 1903,1923 **** in-system ! : f# ( "fp no." -- ; fs: -- r ) \ W32F Floating extra ! \ *G An attempt is made to convert the space delimited string following F# to internal \ ** floating-point representation. If the string represents a valid floating-point ! \ ** number in the syntax below, its value r and true are returned. If the string does not \ ** represent a valid floating-point number an error is thrown. \n \ ** F# used at the end of a line is treated as a special case representing zero. \n \ ** If interpreting the FP number is placed on the FP stack, while it is compiled as ! \ ** an Fliteral if compiling. ! \ *E The syntax of a convertible string := <significand>[<exponent>] ! \ ** ! \ ** <significand> := [<sign>]{<digits>[.<digits0>] | ! \ ** .<digits> } ! \ ** <exponent> := <marker><digits0> ! \ ** <marker> := {<e-form> | <sign-form>} ! \ ** <e-form> := <e-char>[<sign-form>] ! \ ** <sign-form> := { + | - } ! \ ** <e-char> := { D | d | E | e } bl word count >float 0= abort" invalid floating point number" --- 1901,1914 ---- in-system ! : f# ( Interpretation: "fp no." -- ; fs: -- r ) \ W32F Floating extra ! \ *G \b ( Compilation: "fp no." -- ; run-time: fs: -- r ) \d ! \ *P An attempt is made to convert the space delimited string following F# to internal \ ** floating-point representation. If the string represents a valid floating-point ! \ ** number in the syntax below, its value r is returned. If the string does not \ ** represent a valid floating-point number an error is thrown. \n \ ** F# used at the end of a line is treated as a special case representing zero. \n \ ** If interpreting the FP number is placed on the FP stack, while it is compiled as ! \ ** an Fliteral if compiling. \n ! \ ** The syntax of a convertible string is the same as \b >FLOAT \d. bl word count >float 0= abort" invalid floating point number" *************** *** 1935,1938 **** --- 1926,1936 ---- internal + code f>bcd ( fs: r -- ) ( addr -- ) + fstack-check_1 + >fpu + fbstp DATASTACK_MEMORY + pop tos + float; + : rep-normal ( addr u -- n true ; fs: r -- ) 1 max 2dup [char] 0 fill 18 umin *************** *** 2024,2027 **** --- 2022,2027 ---- internal + 128 newuser $ftemp + : +sign ( $buf -- ) fexam FPU_STATUS_CCF_MASK_1 and *************** *** 2347,2350 **** --- 2347,2356 ---- r> base ! ; + internal + + fvariable ftemp + + external + : .ftempx ( -- ) 0 B/FLOAT 1- *************** *** 2437,2440 **** --- 2443,2448 ---- ' fdiscard-number is discard-number + module + only forth also definitions |
