[Win32forth-cvs] win32forth/src FLOAT.F,1.43,1.44

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4685/win32forth/src

Modified Files:
	FLOAT.F 
Log Message:
gah: Fixed bug in decompiling Fliterals plus minor mods

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.43
retrieving revision 1.44
diff -C2 -d -r1.43 -r1.44
*** FLOAT.F	25 Feb 2006 10:39:32 -0000	1.43
--- FLOAT.F	25 Apr 2006 10:24:56 -0000	1.44
***************
*** 102,106 ****
  \ *P \b WARNING! \d do not alter the settings unless you know what you're doing.
  
! code >fregs     ( addr -- )      \ W32F         Floating extra
  \ *G Restore x87 FPU State.
                  frstor  DATASTACK_MEMORY
--- 102,106 ----
  \ *P \b WARNING! \d do not alter the settings unless you know what you're doing.
  
! code >fregs     ( addr -- )             \ W32F         Floating extra
  \ *G Restore x87 FPU State.
                  frstor  DATASTACK_MEMORY
***************
*** 109,113 ****
                  end-code
  
! code >fregs>    ( addr -- )       \ W32F        Floating extra
  \ *G Save and Restore x87 FPU State.
                  fsave   DATASTACK_MEMORY
--- 109,113 ----
                  end-code
  
! code >fregs>    ( addr -- )             \ W32F        Floating extra
  \ *G Save and Restore x87 FPU State.
                  fsave   DATASTACK_MEMORY
***************
*** 117,121 ****
                  end-code
  
! code fpcw>      ( -- n )          \ W32F        Floating extra
  \ *G Get x87 FPU Control Word.
                  push    tos
--- 117,121 ----
                  end-code
  
! code fpcw>      ( -- n )                \ W32F        Floating extra
  \ *G Get x87 FPU Control Word.
                  push    tos
***************
*** 127,131 ****
                  end-code
  
! code >fpcw      ( n -- )          \ W32F        Floating extra
  \ *G Set x87 FPU Control Word.
                  push    tos
--- 127,131 ----
                  end-code
  
! code >fpcw      ( n -- )                \ W32F        Floating extra
  \ *G Set x87 FPU Control Word.
                  push    tos
***************
*** 136,140 ****
                  end-code
  
! code fpsw>      ( -- n )          \ W32F        Floating extra
  \ *G Get x87 FPU Status Word.
                  push    tos
--- 136,140 ----
                  end-code
  
! code fpsw>      ( -- n )                \ W32F        Floating extra
  \ *G Get x87 FPU Status Word.
                  push    tos
***************
*** 145,149 ****
  
  [undefined] B/FLOAT [if]
!  10 constant B/FLOAT  ( -- n )    \ W32F         Floating extra
  \ *G Number of bytes in a floating-point number. Note the default is 8 bytes.
  [then]
--- 145,149 ----
  
  [undefined] B/FLOAT [if]
!  10 constant B/FLOAT  ( -- n )          \ W32F         Floating extra
  \ *G Number of bytes in a floating-point number. Note the default is 8 bytes.
  [then]
***************
*** 170,174 ****
  previous definitions
  
! cell NEWUSER FLOATSP                    \ floating point stack pointer in the user area  (new)
  256 constant fstack-elements            \ 256 floating point elements in stack
  next-user @ 0x10 naligned next-user !   \ align next user to quadword
--- 170,175 ----
  previous definitions
  
! cell NEWUSER FLOATSP ( -- addr )                    \ W32F             Floating extra
! \ *G Address of floating point stack pointer in the user area.
  256 constant fstack-elements            \ 256 floating point elements in stack
  next-user @ 0x10 naligned next-user !   \ align next user to quadword
***************
*** 241,245 ****
                  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.
--- 242,246 ----
                  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.
***************
*** 363,367 ****
  \ *N Memory Access
  
! code F@         ( addr --  ; fs: -- r )  \ ANSI      Floating
  \ *G Fetch a float.
                  fld     FSIZE DATASTACK_MEMORY
--- 364,368 ----
  \ *N Memory Access
  
! code F@         ( addr -- ; fs: -- r )  \ ANSI      Floating
  \ *G Fetch a float.
                  fld     FSIZE DATASTACK_MEMORY
***************
*** 408,412 ****
                  float;
  
! code F+!        ( addr -- ; fs: r -- )    \ W32F       Floating extra
  \ *G Add the value to a float.
                  fstack-check_1
--- 409,413 ----
                  float;
  
! code F+!        ( addr -- ; fs: r -- )  \ W32F       Floating extra
  \ *G Add the value to a float.
                  fstack-check_1
***************
*** 418,422 ****
                  float;
  
! : F,            ( fs: r -- ) \ compile a float
                  here f! B/FLOAT allot ;
  
--- 419,424 ----
                  float;
  
! : F,            ( fs: r -- )     \ W32F        Floating extra
! \ *G Compile a float into the dictionary.
                  here f! B/FLOAT allot ;
  
***************
*** 456,461 ****
  in-system
  
! : 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
--- 458,463 ----
  in-system
  
! : 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
***************
*** 897,901 ****
                  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 ;
--- 899,903 ----
                  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 ;
***************
*** 984,988 ****
  \ *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  = ;
--- 986,990 ----
  \ *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  = ;
***************
*** 1718,1724 ****
  
  : init->float   ( -- )
!                 ( 0 expsign ! ) 0 intcnt !                 \ initialize various
!                 0 fracnt ! ( 0 expcnt ! )                 \ counts and such
!                 0 zerochar ! 0 mantsign !
                  false havedigits !
                  fbcd-buf 10 erase                       \ clear bcd buffer
--- 1720,1725 ----
  
  : init->float   ( -- )
!                 0 intcnt ! 0 fracnt !                   \ initialize various counts
!                 0 zerochar ! 0 mantsign !               \  and such
                  false havedigits !
                  fbcd-buf 10 erase                       \ clear bcd buffer
***************
*** 1928,1932 ****
  internal
  
! code f>bcd      ( fs: r -- )  ( addr -- )
                  fstack-check_1
                  >fpu
--- 1929,1933 ----
  internal
  
! code f>bcd      ( addr -- ; fs: r -- )
                  fstack-check_1
                  >fpu
***************
*** 2032,2036 ****
                  THEN ;
  
! : +represent    { $buf \ -- flag }
                  $ftemp precision represent 0=
                  -IF  3drop $ftemp precision $buf +PLACE s"  " $buf +PLACE true
--- 2033,2037 ----
                  THEN ;
  
! : +represent    { $buf -- true | exp sign false ; fs: r -- }
                  $ftemp precision represent 0=
                  -IF  3drop $ftemp precision $buf +PLACE s"  " $buf +PLACE true
***************
*** 2096,2100 ****
                  $buf +represent ?EXIT
  
!                 drop 1- 3 /mod swap 1+ $ftemp over $buf +PLACE
                  s" ." $buf +PLACE
                  $ftemp over + swap precision swap - $buf +PLACE
--- 2097,2101 ----
                  $buf +represent ?EXIT
  
!                 drop 1- s>d 3 fm/mod swap 1+ $ftemp over $buf +PLACE
                  s" ." $buf +PLACE
                  $ftemp over + swap precision swap - $buf +PLACE
***************
*** 2131,2138 ****
  
                  fdup fabs precision 2/ negate 10**n f<
!                 IF   (e.)
                  ELSE fdup fabs precision 10**n f<
                       IF   (f.)
!                      ELSE (e.)
                       THEN
                  THEN ;
--- 2132,2139 ----
  
                  fdup fabs precision 2/ negate 10**n f<
!                 IF   (fs.)
                  ELSE fdup fabs precision 10**n f<
                       IF   (f.)
!                      ELSE (fs.)
                       THEN
                  THEN ;
***************
*** 2383,2390 ****
  \ If you don't understand what the following definition is doing, don't
  \ concern yourself. It is moving a floating point number from a1 into
! \ the body of its own definition so it can display it easily.
  
  : .onefloat     ( -- r1 )
!                 f0.0 g. ;
  
  : see.float     ( a1 -- a2 )
--- 2384,2392 ----
  \ If you don't understand what the following definition is doing, don't
  \ concern yourself. It is moving a floating point number from a1 into
! \ the body of its own definition so it can display it easily. Note it must
! \ compile an fliteral NOT a fconstant.
  
  : .onefloat     ( -- r1 )
!                 [ f0.0 ] fliteral g. ;
  
  : see.float     ( a1 -- a2 )