Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16037/win32forth/src
Modified Files:
FLOAT.F
Log Message:
gah: modified rep-normal to (hopefully) work correctly for precision of 1 and fixed a few stack comments
Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** FLOAT.F 25 Jun 2005 16:29:02 -0000 1.10
--- FLOAT.F 1 Jul 2005 09:42:41 -0000 1.11
***************
*** 27,30 ****
--- 27,32 ----
\ gah Thursday, May 26 2005 added macro 2>FPU
\ gah Saturday, June 25 2005 modified rep-zero to correct bug in represent
+ \ gah Thursday, June 30 2005 modified rep-normal to correct bug in represent
+ \ gah Thursday, June 30 2005 made FLOOR FROUND FTRUNC thread-safe
\ -------------------------------------------------------------------------
***************
*** 696,700 ****
internal
! variable cwtemp
in-system
--- 698,702 ----
internal
! cell newuser cwtemp
in-system
***************
*** 704,714 ****
\ output: bx = org FPU Control Word
macro: set-rounding-mode
! fstcw word cwtemp
! mov ax, cwtemp
push ax
and ax, # 0x0f3ff
or ax, bx
! mov cwtemp , ax
! fldcw word cwtemp
pop bx
endm
--- 706,716 ----
\ output: bx = org FPU Control Word
macro: set-rounding-mode
! fstcw word cwtemp [up]
! mov ax, cwtemp [up]
push ax
and ax, # 0x0f3ff
or ax, bx
! mov cwtemp [up], ax
! fldcw word cwtemp [up]
pop bx
endm
***************
*** 717,725 ****
\ input: bx = org FPU Control Word
macro: restore-rounding-mode
! mov cwtemp , bx
! fldcw word cwtemp
endm
! \ Subroutine to round a floating point value
\ input: bx = rounding mode mask for the FPU Control Word
macro: (fround)
--- 719,727 ----
\ input: bx = org FPU Control Word
macro: restore-rounding-mode
! mov cwtemp [up], bx
! fldcw word cwtemp [up]
endm
! \ Macro to round a floating point value
\ input: bx = rounding mode mask for the FPU Control Word
macro: (fround)
***************
*** 1565,1578 ****
THEN ;
! : rep-normal ( addr u -- n true )
! 1 max 2dup ascii 0 fill 18 umin
! fabs fdup dup 10**n-0.5 f<
! IF fdup dup dup 1- 10**n-0.5 f<
! IF fdup flog floor f>s 1+ dup>r
! - f*10**n
! ELSE >r
! THEN
! ELSE fdup flog floor f>s 1+ dup>r
! over - 10**n f/
THEN
fround fdup dup 10**n f<
--- 1567,1576 ----
THEN ;
! : rep-normal ( addr u -- n true ) ( f: 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<
***************
*** 1588,1598 ****
;
! : rep-denormal ( addr u -- n true )
! rep-normal ;
\ 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 ) ( f: r -- )
! ascii 0 fill 1 true fdrop ;
: rep-spec ( addr u cstr -- n false ) ( f: r -- )
--- 1586,1595 ----
;
! ' rep-normal alias rep-denormal ( addr u -- n true ) ( f: 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 ) ( f: r -- )
! [char] 0 fill 1 true fdrop ;
: rep-spec ( addr u cstr -- n false ) ( f: r -- )
|
