[Win32forth-cvs] win32forth/src FLOAT.F,1.53.2.2,1.53.2.3

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

Update of /cvsroot/win32forth/win32forth/src
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv13816

Modified Files:
      Tag: V614XX
	FLOAT.F 
Log Message:
Fixed bug in Fdrop and F2drop

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.53.2.2
retrieving revision 1.53.2.3
diff -C2 -d -r1.53.2.2 -r1.53.2.3
*** FLOAT.F	5 Jun 2010 07:37:48 -0000	1.53.2.2
--- FLOAT.F	14 Aug 2013 18:01:05 -0000	1.53.2.3
***************
*** 86,90 ****
                  0 [tos] endm

! in-application

  \ *W <a name="Sec#1"></a>
--- 86,90 ----
                  0 [tos] endm

! in-previous

  \ *W <a name="Sec#1"></a>
***************
*** 166,170 ****
  [THEN]

! in-application

  previous definitions
--- 166,170 ----
  [THEN]

! in-previous

  previous definitions
***************
*** 187,191 ****
                  FLOATSTACK + [ecx] [up] endm

! in-application

  -45 Constant THROW_FLOATSTACKUNDER
--- 187,191 ----
                  FLOATSTACK + [ecx] [up] endm

! in-previous

  -45 Constant THROW_FLOATSTACKUNDER
***************
*** 273,277 ****
                  endm

! \ makro to copy ST(0) on the separate float stack
  macro:  (FPU>)
                  fsp-cached? 0= if
--- 273,277 ----
                  endm

! \ macro to copy ST(0) on the separate float stack
  macro:  (FPU>)
                  fsp-cached? 0= if
***************
*** 288,292 ****
                  endm

! \ makro to move the top of the separate float stack into st(0)
  macro:  >FPU
                  fsp-cached? 0= if
--- 288,292 ----
                  endm

! \ macro to move the top of the separate float stack into st(0)
  macro:  >FPU
                  fsp-cached? 0= if
***************
*** 316,320 ****
                  false to fsp-cached? next ;c endm

! in-application

  \ Subroutine to check the depth of the float stack for underflow errors.
--- 316,320 ----
                  false to fsp-cached? next ;c endm

! in-previous

  \ Subroutine to check the depth of the float stack for underflow errors.
***************
*** 331,335 ****
  in-system

! \ makro to check if there is at least one element on the floating point stack
  macro:  fstack-check_1
                  mov     eax, # b/float
--- 331,335 ----
  in-system

! \ macro to check if there is at least one element on the floating point stack
  macro:  fstack-check_1
                  mov     eax, # b/float
***************
*** 338,342 ****
                  endm

! \ makro to check if there are at least two elements on the floating point stack
  macro:  fstack-check_2
                  mov     eax, # b/float 2*
--- 338,342 ----
                  endm

! \ macro to check if there are at least two elements on the floating point stack
  macro:  fstack-check_2
                  mov     eax, # b/float 2*
***************
*** 345,349 ****
                  endm

! \ makro to check if there are at least three elements on the floating point stack
  macro:  fstack-check_3
                  mov     eax, # b/float 3 *
--- 345,349 ----
                  endm

! \ macro to check if there are at least three elements on the floating point stack
  macro:  fstack-check_3
                  mov     eax, # b/float 3 *
***************
*** 352,356 ****
                  endm

! in-application

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 352,356 ----
                  endm

! in-previous

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 425,469 ****
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

  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 f,
                  ;code
!                   fld      fsize 4 [eax]
                    FPU>
                  float;

- in-application
- 
- code _fto       ( FS: n -  ; 'fvalue  - )
-                 fstack-check_1
-                 >FPU
-                 add     ebx, # cell \ >body
-                 fstp    FSIZE DATASTACK_MEMORY
-                 pop     ebx
-                 float;

! 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
! \ ** 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      ( -<name>- ; fs: r -- )      \ ANSI               Floating
! \ *G      \b Interpretation: ( -<name>- ; fs: r -- ) \d \n
  \ ** Define an FP constant. \n
  \ **      \b Compilation: \d \n
--- 425,485 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

+ internal
+ 
+ cfa-code dofvalue!  ( fs: r -- )
+     push    ebx
+     mov     ebx, -4 [eax]
+     fstack-check_1
+     >FPU  \ to st(0)
+     fstp    FSIZE datastack_memory
+     pop     ebx
+     float;
+ 
+ cfa-code dofvalue+! ( fs: r -- )
+     push    tos
+     mov     ebx, -8 [eax]
+     fstack-check_1
+     >FPU
+     fld     FSIZE DATASTACK_MEMORY
+     faddp   st(1), st
+     fstp    fsize datastack_memory
+     pop     tos
+     float;
+ 
+ external
+ 
  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 ;

! in-previous
! 
! : FVALUE  ( compiling "name" -- ; fs: r -- ; run-time FS: -- r  ) \ W32F    Floating ext
  \ *G Define a floating point value initialised from the FP stack.
!                 create here 0 , dofvalue! , dofvalue+! , here swap ! f,
                  ;code
!                   mov      ecx,  4 [eax]
!                   fld      fsize 0 [ecx]
                    FPU>
                  float;

! synonym fto to                          \ W32F               Floating extra
! \ *G \b Interpretation: ( -<fvalue>- -- fs: r -- ) \n
! \ ** Compilation:    ( -<fvalue>- --  Run-time: FS: r -- ) \d
! \ *P Store r into -<fvalue>-.

! synonym +fto +to                        \ W32F               Floating extra
  \ *G \b Interpretation: ( -<fvalue>- -- fs: r -- ) \n
  \ ** Compilation:    ( -<fvalue>- --  Run-time: FS: r -- ) \d
! \ *P Add r into -<fvalue>-.

! in-previous
! 
! : FCONSTANT      ( "name" -- ; fs: r -- )      \ ANSI               Floating
! \ *G      \b Interpretation: ( "name" ; fs: r -- ) \d \n
  \ ** Define an FP constant. \n
  \ **      \b Compilation: \d \n
***************
*** 514,517 ****
--- 530,568 ----
  \ in-application

+ in-system
+ 
+ also assembler
+ 
+ : DFIELD:    ( n1 "name" -- n2 ) ( addr -- 'addr )
+ \ *G Skip leading space delimiters. Parse name delimited by a space. Offset is the first
+ \ ** double-float aligned value greater than or equal to n1. n2 = offset + 1 double-float.
+ \ ** Create a definition for name with the execution semantics given below.
+ \ ** name Execution: ( addr1 -- addr2 )
+ \ ** Add the offset calculated during the compile time action to addr1 giving the
+ \ ** double-float aligned address addr2.
+ double field+ ;
+ 
+ : FFIELD:    ( n1 "name" -- n2 ) ( addr -- 'addr )
+ \ *G Skip leading space delimiters. Parse name delimited by a space. Offset is the first
+ \ ** float aligned value greater than or equal to n1. n2 = offset + 1 float.
+ \ ** Create a definition for name with the execution semantics given below.
+ \ ** name Execution: ( addr1 -- addr2 )
+ \ ** Add the offset calculated during the compile time action to addr1 giving the float
+ \ ** aligned address addr2.
+ fsize field+ ;
+ 
+ : SFIELD:    ( n1 "name" -- n2 ) ( addr -- 'addr )
+ \ *G Skip leading space delimiters. Parse name delimited by a space. Offset is the first
+ \ ** singe-float aligned value greater than or equal to n1. n2 = offset + 1 single-float.
+ \ ** Create a definition for name with the execution semantics given below.
+ \ ** name Execution: ( addr1 -- addr2 )
+ \ ** Add the offset calculated during the compile time action to addr1 giving the
+ \ ** single-float aligned address addr2.
+ float field+ ;
+ 
+ previous
+ 
+ in-previous
+ 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ Floating point stack operators
***************
*** 524,528 ****
  \ *G Remove r from the floating-point stack.
                  fstack-check_1
!                 sub     FSP_MEMORY , # B/FLOAT
                  float;

--- 575,580 ----
  \ *G Remove r from the floating-point stack.
                  fstack-check_1
!                 sub     ecx , # B/FLOAT
!                 mov     FSP_MEMORY , ecx
                  float;

***************
*** 602,606 ****
  \ *G Remove the top 2 FP stack entries.
                  fstack-check_2
!                 sub     FSP_MEMORY , # B/FLOAT 2*
                  float;

--- 654,659 ----
  \ *G Remove the top 2 FP stack entries.
                  fstack-check_2
!                 sub     ecx , # B/FLOAT 2*
!                 mov     FSP_MEMORY , ecx
                  float;

***************
*** 788,792 ****
                  endm

! in-application

  code FLOOR      ( fs: r1 --  r2 )         \ ANSI         Floating
--- 841,845 ----
                  endm

! in-previous

  code FLOOR      ( fs: r1 --  r2 )         \ ANSI         Floating
***************
*** 934,938 ****
                  endm

! in-application

  code fcomppx    ( -- flags ; fs: r1 r2 -- ) \ for comparing 2 FP values
--- 987,991 ----
                  endm

! in-previous

  code fcomppx    ( -- flags ; fs: r1 r2 -- ) \ for comparing 2 FP values
***************
*** 1512,1516 ****
  in-system

! : float-array   ( n1 -<name>- )         \ compile time
                  ( -- a1 )               \ runtime
                  create floats allot ;
--- 1565,1569 ----
  in-system

! : float-array   ( n1 "name" -- )         \ compile time
                  ( -- a1 )               \ runtime
                  create floats allot ;
***************
*** 1518,1522 ****
  internal

! in-application

  \ pointer to a float primitives
--- 1571,1575 ----
  internal

! in-previous

  \ pointer to a float primitives
***************
*** 1560,1594 ****
  external

! : ^float        ( a1 -<name>- )         \ compile time          64-bits
                  ( fs: -- r )      \ runtime
                  header ^float@ , ^float! , ^float+! , ( a1 ) , ;

! : #^float-array ( n1 -<name>- )         \ compile time          64-bits
                  ( n1 -- ; fs: -- r )   \ runtime
                  header ^#float@ , ^#float! , ^#float+! , ( n1 ) , ;

! : FLOAT         ( -<name>- )            \ compile time          64-bits
                  ( -- ; fs: -- r )   \ runtime
                  header float@ , float! , float+! ,
                  1 floats here over erase allot ;

! : #float-array  ( n1 -<name>- )         \ compile time          64-bits
                  ( n1 -- ; fs: -- r )   \ runtime
                  header #float@ , #float! , #float+! ,
                  ( n1 ) 1+ floats here over erase allot ;

! : f->           ( n1 -<name>- )         \ store a value into a float
                  ' ?float  1 cells+ cfa-comp, ; immediate

! : f+>           ( n1 -<name>- )         \ increment the value of a float
                  ' ?float  2 cells+ cfa-comp, ; immediate

! : f#->          ( n1 -<name>- )         \ store a value into a float
                  ' ?#float  1 cells+ cfa-comp, ; immediate

! : f#+>          ( n1 -<name>- )         \ increment the value of a float
                  ' ?#float  2 cells+ cfa-comp, ; immediate

! in-application

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 1613,1647 ----
  external

! : ^float        ( a1 "name" -- )         \ compile time          64-bits
                  ( fs: -- r )      \ runtime
                  header ^float@ , ^float! , ^float+! , ( a1 ) , ;

! : #^float-array ( n1 "name" -- )         \ compile time          64-bits
                  ( n1 -- ; fs: -- r )   \ runtime
                  header ^#float@ , ^#float! , ^#float+! , ( n1 ) , ;

! : FLOAT         ( "name" -- )            \ compile time          64-bits
                  ( -- ; fs: -- r )   \ runtime
                  header float@ , float! , float+! ,
                  1 floats here over erase allot ;

! : #float-array  ( n1 "name" -- )         \ compile time          64-bits
                  ( n1 -- ; fs: -- r )   \ runtime
                  header #float@ , #float! , #float+! ,
                  ( n1 ) 1+ floats here over erase allot ;

! : f->           ( n1 "name" -- )         \ store a value into a float
                  ' ?float  1 cells+ cfa-comp, ; immediate

! : f+>           ( n1 "name" -- )         \ increment the value of a float
                  ' ?float  2 cells+ cfa-comp, ; immediate

! : f#->          ( n1 "name" -- )         \ store a value into a float
                  ' ?#float  1 cells+ cfa-comp, ; immediate

! : f#+>          ( n1 "name" -- )         \ increment the value of a float
                  ' ?#float  2 cells+ cfa-comp, ; immediate

! in-previous

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 1892,1896 ****
          IF  postpone fliteral  THEN ;   immediate

! in-application

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 1945,1949 ----
          IF  postpone fliteral  THEN ;   immediate

! in-previous

  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 2373,2377 ****
  defer .float    ' see.float is .float

! in-application

  \ changed arm 25/04/2005 23:09:50 to use new number chain technique (see numconv.f)
--- 2426,2430 ----
  defer .float    ' see.float is .float

! in-previous

  \ changed arm 25/04/2005 23:09:50 to use new number chain technique (see numconv.f)
***************
*** 2400,2410 ****
  number?-chain chain-add float-number?           \ link into number conversion chain

  \ 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? 0 to fsp-adjust ;

! reset-stack-chain chain-add FLOAT-RESET-STACKS

  : _FLOAT-NUMBER, ( d1 -- d1 )           \ interpreting a double
--- 2453,2468 ----
  number?-chain chain-add float-number?           \ link into number conversion chain

+ reset-stack-chain chain-add finit
+ 
+ in-system
+ 
  \ changed to use the reset-stack-chain
  \ January 22nd, 2004 - 13:53 dbu
! : FLOAT-RESET-STACKS ( -- ) \ reset compile time values
!                  0 to fsp-cached? 0 to fsp-adjust ;

! \in-system-ok reset-stack-chain chain-add FLOAT-RESET-STACKS
! 
! in-previous

  : _FLOAT-NUMBER, ( d1 -- d1 )           \ interpreting a double