Menu
▾
▴
[Win32forth-cvs] win32forth/src Debug.f,1.10,1.11 FLOAT.F,1.37,1.38
|
From: George H. <geo...@us...> - 2006-02-20 12:06:23
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4132/win32forth/src Modified Files: Debug.f FLOAT.F Log Message: gah: More Dexing (still work in progress) optimizations and bug fixes Index: Debug.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Debug.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** Debug.f 29 Aug 2005 15:56:27 -0000 1.10 --- Debug.f 20 Feb 2006 12:06:14 -0000 1.11 *************** *** 73,80 **** & dup 0= UNTIL ; ! : <& ( n -- 0 n ) 0 swap ; ! : &> drop ; --- 73,80 ---- & dup 0= UNTIL ; ! : <& ( n -- 0 n ) 0 swap ; ! : &> drop ; *************** *** 118,122 **** THEN drop ; ! \ -------------------- Variables -------------------- --- 118,122 ---- THEN drop ; ! \ -------------------- Variables -------------------- *************** *** 155,159 **** : m0cfa? ( cfa -- f ) @ m0cfa = ; ! : unnest? ( cfa -- f ) @ dup ['] unnest = --- 155,159 ---- : m0cfa? ( cfa -- f ) @ m0cfa = ; ! : unnest? ( cfa -- f ) @ dup ['] unnest = *************** *** 198,202 **** ['] leave of drop rp@ 5 cells+ @ ENDOF ['] ?leave of over ! if drop rp@ 5 cells+ @ else cell+ then ENDOF ['] ?BRANCH OF OVER 0= ?JUMP ENDOF --- 198,202 ---- ['] leave of drop rp@ 5 cells+ @ ENDOF ['] ?leave of over ! if drop rp@ 5 cells+ @ else cell+ then ENDOF ['] ?BRANCH OF OVER 0= ?JUMP ENDOF *************** *** 294,298 **** 1 nesting +! else dup does>? \ does> definitions ! if ." DOES> nesting " @ 3 + @ dup \ offset to vector to high level code is implementation dependent ?name cfa-watch --- 294,298 ---- 1 nesting +! else dup does>? \ does> definitions ! if ." DOES> nesting " @ 3 + @ dup \ offset to vector to high level code is implementation dependent ?name cfa-watch *************** *** 369,373 **** if i @ here u< if dup >name nfa-count type ! i @ swap >body - cell / 1- ." +" %. else h%. --- 369,373 ---- if i @ here u< if dup >name nfa-count type ! i @ swap >body - cell / 1- ." +" %. else h%. *************** *** 546,550 **** ." ]" THEN ! r> to obj-save 20 nesting @ ?dup if 1+ - then getxy drop max col --- 546,550 ---- ." ]" THEN ! r> to obj-save 20 nesting @ ?dup if 1+ - then getxy drop max col *************** *** 602,606 **** restore-io debug-exit ! [ last @ name> ] literal patch ; \ patch in trace ' trace to 'trace --- 602,606 ---- restore-io debug-exit ! [ last @ name> ] literal patch ; \ patch in trace ' trace to 'trace *************** *** 613,617 **** \ ------ Added for SEE; replaces TRACE with the traced word --- ! .execution-class-chain : .debug-trace ( ip cfa flag -- ip' cfa flag ) dup ?EXIT \ leave if non-zero flag --- 613,619 ---- \ ------ Added for SEE; replaces TRACE with the traced word --- ! ! [defined] .execution-class-chain [if] ! : .debug-trace ( ip cfa flag -- ip' cfa flag ) dup ?EXIT \ leave if non-zero flag *************** *** 623,626 **** --- 625,630 ---- .execution-class-chain chain-add .debug-trace + [then] + \ -------------------- Initialize Debugger -------------------- *************** *** 688,704 **** then until tracing ; ! : debug ( -<name>- ) ' adebug ; synonym bp debug ! \ see also mDebug for methods IN-APPLICATION ! : debug-io TURNKEYED? ?EXIT ! \IN-SYSTEM-OK debug-io ; ! : restore-io TURNKEYED? ?EXIT \IN-SYSTEM-OK restore-io --- 692,708 ---- then until tracing ; ! : debug ( -<name>- ) ' adebug ; synonym bp debug ! \ see also mDebug for methods IN-APPLICATION ! : debug-io TURNKEYED? ?EXIT ! \IN-SYSTEM-OK debug-io ; ! : restore-io TURNKEYED? ?EXIT \IN-SYSTEM-OK restore-io *************** *** 715,719 **** else dbg-watch then ; ! : ?unbug ( nfa -- nfa ) \ If word being debugged is being forgotten unbug dup ip @ trim? if unbug then ; --- 719,723 ---- else dbg-watch then ; ! : ?unbug ( nfa -- nfa ) \ If word being debugged is being forgotten unbug dup ip @ trim? if unbug then ; Index: FLOAT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v retrieving revision 1.37 retrieving revision 1.38 diff -C2 -d -r1.37 -r1.38 *** FLOAT.F 13 Feb 2006 14:02:19 -0000 1.37 --- FLOAT.F 20 Feb 2006 12:06:14 -0000 1.38 *************** *** 57,60 **** --- 57,82 ---- \ *S Glossary + \ *W <ul><li><a href="#Sec#1">Loading and saving FPU registers</a></li> + \ *W <li><a href="#Sec#2">Memory Access</a></li> + \ *W <li><a href="#Sec#3">FP Stack operations</a></li> + \ *W <li><a href="#Sec#4">FP Stack operations on pairs of entries</a></li> + \ *W <li><a href="#Sec#5">FP Constants</a></li> + \ *W <li><a href="#Sec#6">FP Variables</a></li> + \ *W <li><a href="#Sec#7">Rounding functions</a></li> + \ *W <li><a href="#Sec#8">Integer to float conversion</a></li> + \ *W <li><a href="#Sec#9">FP Comparison operators</a></li> + \ *W <li><a href="#Sec#10">Arithmetic operators</a></li> + \ *W <li><a href="#Sec#11">Trigonometric functions/a></li> + \ *W <li><a href="#Sec#12">Inverse Trigonometric functions</a></li> + \ *W <li><a href="#Sec#13">Logarithmic functions</a></li> + \ *W <li><a href="#Sec#14">Exponential functions</a></li> + \ *W <li><a href="#Sec#15">Hyperbolic functions</a></li> + \ *W <li><a href="#Sec#16">Inverse hyperbolic functions</a></li> + \ *W <li><a href="#Sec#17">Input of Floating Point numbers</a></li> + \ *W <li><a href="#Sec#18">Output conversion</a></li> + \ *W <li><a href="#Sec#19">Format FP number to a buffer</a></li> + \ *W <li><a href="#Sec#20">Display FP numbers</a></li> + \ *W <li><a href="#Sec#21">Debugging tools</a></li></ul> + cr .( Loading Floating Point...) *************** *** 66,69 **** --- 88,92 ---- in-application + \ *W <a name="Sec#1"></a> \ *N Loading and saving FPU registers *************** *** 337,340 **** --- 360,364 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ *W <a name="Sec#2"></a> \ *N Memory Access *************** *** 508,512 **** float; DEPRECATED ! \ *N Stack operations code FDROP ( fs: r -- ) \ ANSI Floating --- 532,537 ---- float; DEPRECATED ! \ *W <a name="Sec#3"></a> ! \ *N FP Stack operations code FDROP ( fs: r -- ) \ ANSI Floating *************** *** 583,586 **** --- 608,612 ---- FSWAP FDROP ; + \ *W <a name="Sec#4"></a> \ *N FP Stack operations on pairs of entries *************** *** 613,617 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Constants code fpi ( fs: -- r ) \ W32F Floating extra --- 639,644 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *W <a name="Sec#5"></a> ! \ *N FP Constants code fpi ( fs: -- r ) \ W32F Floating extra *************** *** 718,722 **** ' fsmall >body 0 over ! 0x00100000 swap cell+ ! ! \ *N Variables fvariable a2**63 ( -- addr ) \ W32F Floating extra --- 745,750 ---- ' fsmall >body 0 over ! 0x00100000 swap cell+ ! ! \ *W <a name="Sec#6"></a> ! \ *N FP Variables fvariable a2**63 ( -- addr ) \ W32F Floating extra *************** *** 736,739 **** --- 764,769 ---- [THEN] + \ *W <a name="Sec#7"></a> + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *N Rounding functions *************** *** 815,818 **** --- 845,849 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ *W <a name="Sec#8"></a> \ *N Integer to float conversion *************** *** 937,941 **** external ! \ *N Comparison operators : F0= ( -- f ; fs: r -- ) \ ANSI Floating --- 968,973 ---- external ! \ *W <a name="Sec#9"></a> ! \ *N FP Comparison operators : F0= ( -- f ; fs: r -- ) \ ANSI Floating *************** *** 982,985 **** --- 1014,1018 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ *W <a name="Sec#10"></a> \ *N Arithmetic operators *************** *** 1147,1150 **** --- 1180,1184 ---- external + \ *W <a name="Sec#11"></a> \ *N Trigonometric functions *************** *** 1166,1169 **** --- 1200,1204 ---- fsincos f/ ; + \ *W <a name="Sec#12"></a> \ *N Inverse Trigonometric functions *************** *** 1222,1225 **** --- 1257,1261 ---- float; + \ *W <a name="Sec#13"></a> \ *N Logarithmic functions *************** *** 1274,1277 **** --- 1310,1314 ---- float; + \ *W <a name="Sec#14"></a> \ *N Exponential functions *************** *** 1279,1283 **** \ *G Raise e to the power r1, giving r2. fstack-check_1 ! >FPU \ 1 fxam fstsw ax --- 1316,1322 ---- \ *G Raise e to the power r1, giving r2. fstack-check_1 ! >FPU \ 1 ! fldl2e \ log base 2 of e \ 2 ! fmulp st(1), st \ modified exponent \ 1 fxam fstsw ax *************** *** 1290,1307 **** fldz jmp short L$2 ! L$1: fldl2e \ log base 2 of e \ 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 ! L$2: FPU> \ 0 float; --- 1329,1343 ---- fldz jmp short L$2 ! L$1: fld st(0) \ duplicate exponent \ 2 ! frndint \ take integer part \ 2 ! fsub st(1), st \ get fractional part \ 2 ! fld1 \ 1 \ 3 ! fscale \ 2**int \ 3 ! fstp st(1) \ remove unneeded part \ 2 ! fxch st(1) \ frac \ 2 ! f2xm1 \ (2**frac) - 1 \ 2 ! fmul st(0), st(1) \ 2**(int + frac) - 2**int \ 2 ! faddp st(1), st \ 2**(int + frac) \ 1 ! L$2: FPU> \ 0 float; *************** *** 1314,1364 **** fstack-check_1 >fpu ! fxam fstsw ax and ax, # FPU_STATUS_CCF_MASK cmp ax, # FPU_STATUS_CCF_INFINITY ! je short L$6 cmp ax, # 0x700 \ FPU_STATUS_CCF_INFINITY FPU_STATUS_CCF_MASK_1 or ! jne short L$1 fstp st(0) fld1 fchs ! jmp short L$6 ! L$1: fldl2e ! fxch ! fld1 ! fcom st(1) ! fstsw ax ! sahf ! jbe short L$4 ! fchs ! fcomp st(1) ! fstsw ax ! sahf ! jnc short L$5 ! je short L$5 ! fmulp st(1), st(0) ! f2xm1 ! jmp short L$6 ! L$4: fstp st(0) \ 2 ! L$5: fmulp st(1), st(0) \ 1 ! fld st(0) \ duplicate exponent \ 2 ! jp short L$3 ! 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 fld1 ! fsubp st(1), st \ Should be fsubrp ??????? ! L$6: fpu> ! jmp short L$2 ! L$3: fstp st(1) ! L$2: float; : f** ( fs: r1 r2 -- r3 ) \ ANSI Floating ext --- 1350,1394 ---- fstack-check_1 >fpu ! fldl2e \ 2 ! fmulp st(1), st(0) \ 1 ! fld1 \ 2 ! fcom st(1) \ 2 ! fstsw ax \ 2 ! sahf \ 2 ! jbe short L$1 \ arg > 1 \ 2 ! fchs \ 2 ! fcomp st(1) \ 1 ! fstsw ax \ 1 ! sahf \ 1 ! jnc short L$2 \ arg <= -1 \ 1 ! je short L$4 \ is NAN \ 1 ! f2xm1 \ 1 ! jmp short L$4 ! L$1: fstp st(0) \ 1 ! L$2: fxam fstsw ax and ax, # FPU_STATUS_CCF_MASK cmp ax, # FPU_STATUS_CCF_INFINITY ! je short L$4 cmp ax, # 0x700 \ FPU_STATUS_CCF_INFINITY FPU_STATUS_CCF_MASK_1 or ! jne short L$3 fstp st(0) fld1 fchs ! jmp short L$4 ! fld st(0) \ duplicate exponent \ 2 ! L$3: 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 ! fmul st(0), st(1) \ 2**(int + frac) - 2**int \ 2 ! faddp st(1), st \ 2**(int + frac) \ 1 fld1 ! fsubp st(1), st ! L$4: fpu> ! float; : f** ( fs: r1 r2 -- r3 ) \ ANSI Floating ext *************** *** 1382,1385 **** --- 1412,1416 ---- external + \ *W <a name="Sec#15"></a> \ *N Hyperbolic functions *************** *** 1406,1409 **** --- 1437,1441 ---- THEN ; + \ *W <a name="Sec#16"></a> \ *N Inverse hyperbolic functions *************** *** 1576,1590 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Floating point number conversion. We do not have the floating point ! \ integrated with the interpreter, so we must prefix floating point ! \ literals with f#. ( f# 1.23E6 ) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ internal fvariable ftemp 128 newuser $ftemp create $ftemp1 128 allot - 10 newuser fbcd-buf : 10**n ( fs: -- r ) ( n -- ) \ 10 raised to n --- 1608,1644 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ string input number conversion \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ internal + : xsign ( char -- char false | nflag true ) + CASE [char] + OF false true ENDOF + [char] - OF true true ENDOF + ( else ) false over + ENDCASE ; + + : e-char ( char -- true | char false ) + dup upc [char] D [char] E between -if nip then ; + + : 10digit ( char -- n flag ) + 10 digit ; + + : digit0 ( char -- flag ) + dup [char] 0 = ; + + cell newuser mantsign + cell newuser expsign + cell newuser intcnt + cell newuser fracnt + cell newuser expcnt + cell newuser charcnt + cell newuser zerochar + cell newuser havedigits + 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 *************** *** 1608,1619 **** ascii 0 + ; - : bcd-char! ( char n -- ) - swap 0x0f and swap - dup 1 and swap 2/ fbcd-buf + swap - IF dup c@ 0x0f and rot 4 lshift - ELSE dup c@ 0xf0 and rot - THEN - or swap c! ; - B/FLOAT 10 = [IF] 4932 constant big-power --- 1662,1665 ---- *************** *** 1631,1726 **** THEN ; - : rep-normal ( addr u -- n true ; fs: r -- ) - 1 max 2dup [char] 0 fill 18 umin - fdup flog floor f>s 1+ dup>r over - - fdup over 10**n-0.5 f< - IF negate f*10**n - ELSE 10**n f/ - THEN - fround fdup dup 10**n f< - IF fdup dup 1- 10**n f< - IF f10.0 f* r> 1- >r - THEN - ELSE f10.0 f/ r> 1+ >r - THEN - fbcd-buf f>bcd dup>r + 1- r> 0 - DO I bcd-char@ over c! 1- - LOOP - drop r> true - ; - - ' rep-normal alias rep-denormal ( addr u -- n true ; fs: r -- ) - - \ February 6th, 1996 - 18:05 tjz added 'FDROP' to the following def to - \ correct for a floating point zero left on the stack during E. and F.S - : rep-zero ( addr u -- 1 true ; fs: r -- ) - [char] 0 fill 1 true fdrop ; - - : rep-spec ( addr u cstr -- n false ; fs: r -- ) - >r 2dup blank r> count \ addr1 u addr2 v - rot umin >r swap r> move - 0x7fffffff false fdrop ; - - external - - : REPRESENT ( addr u -- n flag1 flag2 ; fs: r -- ) \ ANSI Floating - \ *G At c-addr, place the character-string external representation of the significand of - \ ** the floating-point number r. Return the decimal-base exponent as n, the sign as flag1 - \ ** and valid result as flag2. The character string shall consist of the u most significant - \ ** digits of the significand represented as a decimal fraction with the implied decimal - \ ** point to the left of the first digit, and the first digit zero only if all digits - \ ** are zero. The significand is rounded to u digits following the round to nearest - \ ** rule; n is adjusted, if necessary, to correspond to the rounded magnitude of the - \ ** significand. If flag2 is true then r was in the implementation-defined range of - \ ** floating-point numbers. If flag1 is true then r is negative. \n - \ ** An ambiguous condition exists if the value of BASE is not decimal ten. \n - \ ** When flag2 is false, n is 7FFFFFFF and flag1 is the sign. The contents of c-addr are - \ ** the first u characters of either NAN or Infinity, padded with spaces if necessary. - fexam \ get type of operand - dup FPU_STATUS_CCF_MASK_1 and 0<> >r \ save sign = flag1 - fabs - FPU_STATUS_CCF_MASK_023 and \ clear C1 - CASE FPU_STATUS_CCF_UNSUPPORTED OF c" Unsupported" rep-spec ENDOF - FPU_STATUS_CCF_NAN OF c" NAN" rep-spec ENDOF - FPU_STATUS_CCF_NORMAL OF rep-normal ENDOF - FPU_STATUS_CCF_INFINITY OF c" Infinity" rep-spec ENDOF - FPU_STATUS_CCF_ZERO OF rep-zero ENDOF - FPU_STATUS_CCF_EMPTY OF c" Empty" rep-spec ENDOF - FPU_STATUS_CCF_DENORMAL OF rep-denormal ENDOF - ( else ) c" Unknown" rep-spec - ENDCASE - r> swap ; - - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - \ string input number conversion - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - internal - - : xsign ( char -- char false | nflag true ) - CASE [char] + OF false true ENDOF - [char] - OF true true ENDOF - ( else ) false over - ENDCASE ; - - : e-char ( char -- true | char false ) - dup upc [char] D [char] E between -if nip then ; - - : 10digit ( char -- n flag ) - 10 digit ; - - : digit0 ( char -- flag ) - dup [char] 0 = ; - - cell newuser mantsign - cell newuser expsign - cell newuser intcnt - cell newuser fracnt - cell newuser expcnt - cell newuser charcnt - cell newuser zerochar - cell newuser havedigits - 128 newuser $fsignif - : next-char ( addr1 -- addr2 char flag ) \ flag = 0 means valid char count -1 charcnt +! charcnt @ 0< ; --- 1677,1680 ---- *************** *** 1731,1734 **** --- 1685,1696 ---- float; + : bcd-char! ( char n -- ) + swap 0x0f and swap + dup 1 and swap 2/ fbcd-buf + swap + IF dup c@ 0x0f and rot 4 lshift + ELSE dup c@ 0xf0 and rot + THEN + or swap c! ; + : >float-int ( fs: -- r ) intcnt @ 18 min dup 1- swap 0 *************** *** 1784,1787 **** --- 1746,1750 ---- external + \ *W <a name="Sec#17"></a> \ *N Input of Floating Point numbers *************** *** 1965,1969 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ *N Output conversion. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 1928,2004 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Floating point number conversion. We do not have the floating point ! \ integrated with the interpreter, so we must prefix floating point ! \ literals with f#. ( f# 1.23E6 ) ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! ! internal ! ! : rep-normal ( addr u -- n true ; fs: r -- ) ! 1 max 2dup [char] 0 fill 18 umin ! fdup flog floor f>s 1+ dup>r over - ! fdup over 10**n-0.5 f< ! IF negate f*10**n ! ELSE 10**n f/ ! THEN ! fround fdup dup 10**n f< ! IF fdup dup 1- 10**n f< ! IF f10.0 f* r> 1- >r ! THEN ! ELSE f10.0 f/ r> 1+ >r ! THEN ! fbcd-buf f>bcd dup>r + 1- r> 0 ! DO I bcd-char@ over c! 1- ! LOOP ! drop r> true ! ; ! ! ' rep-normal alias rep-denormal ( addr u -- n true ; fs: r -- ) ! ! \ February 6th, 1996 - 18:05 tjz added 'FDROP' to the following def to ! \ correct for a floating point zero left on the stack during E. and F.S ! : rep-zero ( addr u -- 1 true ; fs: r -- ) ! [char] 0 fill 1 true fdrop ; ! ! : rep-spec ( addr u cstr -- n false ; fs: r -- ) ! >r 2dup blank r> count \ addr1 u addr2 v ! rot umin >r swap r> move ! 0x7fffffff false fdrop ; ! ! external ! ! \ *W <a name="Sec#18"></a> ! \ *N Output conversion ! ! : REPRESENT ( addr u -- n flag1 flag2 ; fs: r -- ) \ ANSI Floating ! \ *G At c-addr, place the character-string external representation of the significand of ! \ ** the floating-point number r. Return the decimal-base exponent as n, the sign as flag1 ! \ ** and valid result as flag2. The character string shall consist of the u most significant ! \ ** digits of the significand represented as a decimal fraction with the implied decimal ! \ ** point to the left of the first digit, and the first digit zero only if all digits ! \ ** are zero. The significand is rounded to u digits following the round to nearest ! \ ** rule; n is adjusted, if necessary, to correspond to the rounded magnitude of the ! \ ** significand. If flag2 is true then r was in the implementation-defined range of ! \ ** floating-point numbers. If flag1 is true then r is negative. \n ! \ ** An ambiguous condition exists if the value of BASE is not decimal ten. \n ! \ ** When flag2 is false, n is 7FFFFFFF and flag1 is the sign. The contents of c-addr are ! \ ** the first u characters of either NAN or Infinity, padded with spaces if necessary. ! fexam \ get type of operand ! dup FPU_STATUS_CCF_MASK_1 and 0<> >r \ save sign = flag1 ! fabs ! FPU_STATUS_CCF_MASK_023 and \ clear C1 ! CASE FPU_STATUS_CCF_UNSUPPORTED OF c" Unsupported" rep-spec ENDOF ! FPU_STATUS_CCF_NAN OF c" NAN" rep-spec ENDOF ! FPU_STATUS_CCF_NORMAL OF rep-normal ENDOF ! FPU_STATUS_CCF_INFINITY OF c" Infinity" rep-spec ENDOF ! FPU_STATUS_CCF_ZERO OF rep-zero ENDOF ! FPU_STATUS_CCF_EMPTY OF c" Empty" rep-spec ENDOF ! FPU_STATUS_CCF_DENORMAL OF rep-denormal ENDOF ! ( else ) c" Unknown" rep-spec ! ENDCASE ! r> swap ; ! ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Output conversion. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 2002,2005 **** --- 2037,2041 ---- external + \ *W <a name="Sec#19"></a> \ *N Format FP number to a buffer *************** *** 2064,2069 **** base @ >r decimal (.) $buf +PLACE r> base ! ; ! : (E.) ( addr -- ; fs: r -- ) \ W32F Floating extra ! \ *G Format r as a string in scientific notation. { $buf \ -- } $buf off --- 2100,2109 ---- base @ >r decimal (.) $buf +PLACE r> base ! ; ! : (FS.) ( addr -- ; fs: r -- ) \ W32F Floating extra ! \ *G Format r as a string in scientific notation: ! \ *E <significand><exponent> ! \ *P where: ! \ *E <significand> := [-]<digit>.<digits0> ! \ ** <exponent> := E[-]<digits> { $buf \ -- } $buf off *************** *** 2080,2083 **** --- 2120,2126 ---- base @ >r decimal (.) $buf +PLACE r> base ! ; + SYNONYM (E.) (FS.) ( addr -- ; fs: r -- ) \ W32F Floating extra + \ *G See above. + : (G.) ( addr -- ; fs: r -- ) \ W32F Floating extra \ *G Format r as a string using scientific notation or ordinary representation according *************** *** 2093,2099 **** THEN ; - SYNONYM (FS.) (E.) ( addr -- ; fs: r -- ) \ W32F Floating extra - \ *G Format r as a string in scientific notation. - \ ----------------------------------------------------------------------------- \ display floating point numbers --- 2136,2139 ---- *************** *** 2114,2131 **** external ! : F. ( fs: r -- ) \ display fp # ['] (f.) (fp.) ; ! : FE. ( fs: r -- ) \ display fp # in engineering notation ['] (fe.) (fp.) ; ! : E. ( fs: r -- ) \ display fp # in scientific notation ! ['] (e.) (fp.) ; ! ! : G. ( fs: r -- ) \ display fp # ! ['] (g.) (fp.) ; ! SYNONYM FS. E. ( fs: r -- ) \ display fp # in scientific notation \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 2154,2188 ---- external ! \ *W <a name="Sec#20"></a> ! \ *N Display FP numbers ! ! : F. ( fs: r -- ) \ ANSI Floating ext ! \ *G Display, with a trailing space, the top number on the floating-point stack using ! \ ** fixed-point notation: ! \ *E [-] <digits>.<digits0> ['] (f.) (fp.) ; ! : FE. ( fs: r -- ) \ ANSI Floating ext ! \ *G Display, with a trailing space, the top number on the floating-point stack using ! \ ** engineering notation, where the significand is greater than or equal to 1.0 and less ! \ ** than 1000.0 and the decimal exponent is a multiple of three. ['] (fe.) (fp.) ; ! : FS. ( fs: r -- ) \ ANSI Floating ext ! \ *G Display, with a trailing space, the top number on the floating-point stack in ! \ ** scientific notation: ! \ *E <significand><exponent> ! \ *P where: ! \ *E <significand> := [-]<digit>.<digits0> ! \ ** <exponent> := E[-]<digits> ! ['] (fs.) (fp.) ; ! SYNONYM E. FS. ( fs: r -- ) \ W32F Floating extra ! \ *G See above. + : G. ( fs: r -- ) \ W32F Floating extra + \ *G Display the top number on the floating-point stack using scientific notation or + \ ** ordinary representation according to the size of r. + ['] (g.) (fp.) ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 2176,2179 **** --- 2233,2237 ---- \ \****************************************************************** + \ *W <a name="Sec#21"></a> \ *N Debugging tools *************** *** 2316,2320 **** : .onefloat ( -- r1 ) ! f# 0 g. ; : see.float ( a1 -- a2 ) --- 2374,2378 ---- : .onefloat ( -- r1 ) ! f0.0 g. ; : see.float ( a1 -- a2 ) *************** *** 2354,2358 **** \ changed to use the reset-stack-chain \ January 22nd, 2004 - 13:53 dbu ! ' finit alias FLOAT-RESET-STACKS ( ?? -- ) \ reset stack reset-stack-chain chain-add FLOAT-RESET-STACKS --- 2412,2418 ---- \ changed to use the reset-stack-chain \ January 22nd, 2004 - 13:53 dbu ! : FLOAT-RESET-STACKS ( ?? -- ) \ reset stack ! finit turnkeyed? ?exit ! \in-system-ok 0 to fsp-cached? ; reset-stack-chain chain-add FLOAT-RESET-STACKS |
