[Win32forth-cvs] win32forth/src FLOAT.F, 1.57, 1.58 KEYBOARD.F, 1.2, 1.3 Primutil.f, 1.59, 1.60

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-serv28876

Modified Files:
	FLOAT.F KEYBOARD.F Primutil.f 
Log Message:
Added 200X words (work in progress). Tidied up some comments.

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.59
retrieving revision 1.60
diff -C2 -d -r1.59 -r1.60
*** Primutil.f	20 Mar 2013 23:51:21 -0000	1.59
--- Primutil.f	22 Apr 2013 19:53:53 -0000	1.60
***************
*** 16,19 ****
--- 16,23 ----
  DECIMAL                                 \ start everything in decimal
  
+ : HOLDS         ( c-addr u -- )       \ 200X core-ext
+ \ *G Add string c-addr u to pictured numeric output buffer.
+                 begin ?dup while 1- 2dup + c@ hold repeat drop ;
+ 
  \ -------------------- Address Conversion -----------------------------------
  
***************
*** 193,196 ****
--- 197,223 ----
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \ Move multiple values to and from return stack
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ 
+ : N>R  ( i*x +n -- ) ( R: -- j*x +n ) \       "n-to-r"   200X TOOLS EXT
+ \ *G Interpretation: must be paired with NR> on the same line.
+ \ ** Execution: Remove n+1 items from the data stack and store them for later retrieval by NR>.
+ \ ** The return stack may be used to store the data. Until this data has been retrieved by NR>:
+ \ ** this data will not be overwritten by a subsequent invocation of N>R and
+ \ ** a program may not access data placed on the return stack before the invocation of
+ \ ** N>R.
+ 
+ \ *P NOTE: +n MUST not exceed 8191 (or 1023 during callbacks) minus the number of values previously
+ \ ** placed on the return stack OTHERWISE the user area (or for callbacks the data stack will be
+ \ ** corrupted probably causing a CRASH.
+ r> over begin ?dup while >r rot r> swap >r 1- repeat swap >r >r ;
+ 
+ : NR>  ( -- i*x +n ) ( R: j*x +n -- ) \       "n-r-from" 200X TOOLS EXT
+ \ *G Interpretation: must be paired with N>R on the same line.
+ \ ** Execution: Retrieve the items previously stored by an invocation of N>R. n is the number of items
+ \ ** placed on the data stack. It is an ambiguous condition if NR> is used with data not stored by N>R.
+ r> r> dup begin ?dup while r> swap >r -rot r> 1- repeat swap >r ;
+ 
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
***************
*** 439,443 ****
  \ *P \b Note: \d This word is obsolescent and is included as a concession to existing
  \ ** implementations. Its function is superseded by >NUMBER.
!                 char+ 64 >number drop ;
  
  VARIABLE SPAN   ( -- a-addr )                     \ ANSI        Core Ext
--- 466,470 ----
  \ *P \b Note: \d This word is obsolescent and is included as a concession to existing
  \ ** implementations. Its function is superseded by >NUMBER.
!                 char+ 64 >number drop ; deprecated
  
  VARIABLE SPAN   ( -- a-addr )                     \ ANSI        Core Ext
***************
*** 446,453 ****
  \ *P \b Note: \d This word is obsolescent and is included as a concession to existing
  \ ** implementations.
  
  
  : EXPECT        ( a1 n1 -- )            \ accept the text
!                 accept span ! ;
  
  : UNUSED        ( -- n1 )               \ return unused HERE in BYTES
--- 473,484 ----
  \ *P \b Note: \d This word is obsolescent and is included as a concession to existing
  \ ** implementations.
+ deprecated
  
+ DPR-WARNING? DPR-WARNING-OFF
  
  : EXPECT        ( a1 n1 -- )            \ accept the text
!                 accept span ! ; deprecated
! 
! to DPR-WARNING?
  
  : UNUSED        ( -- n1 )               \ return unused HERE in BYTES

Index: KEYBOARD.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/KEYBOARD.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** KEYBOARD.F	15 May 2008 04:28:26 -0000	1.2
--- KEYBOARD.F	22 Apr 2013 19:53:53 -0000	1.3
***************
*** 22,29 ****
  in-application
  
! 0x01 fkey K_F1          0x02 fkey K_F2          0x03 fkey K_F3
! 0x04 fkey K_F4          0x05 fkey K_F5          0x06 fkey K_F6
! 0x07 fkey K_F7          0x08 fkey K_F8          0x09 fkey K_F9
! 0x10 fkey K_F10         0x11 fkey K_F11         0x12 fkey K_F12
  
  in-system
--- 22,43 ----
  in-application
  
! 0x01 fkey K-F1          0x02 fkey K-F2          0x03 fkey K-F3
! 0x04 fkey K-F4          0x05 fkey K-F5          0x06 fkey K-F6
! 0x07 fkey K-F7          0x08 fkey K-F8          0x09 fkey K-F9
! 0x10 fkey K-F10         0x11 fkey K-F11         0x12 fkey K-F12
! 
! SYNONYM K_F1  K-F1
! SYNONYM K_F2  K-F2
! SYNONYM K_F3  K-F3
! SYNONYM K_F4  K-F4
! SYNONYM K_F5  K-F5
! SYNONYM K_F6  K-F6
! SYNONYM K_F7  K-F7
! SYNONYM K_F8  K-F8
! SYNONYM K_F9  K-F9
! SYNONYM K_F10 K-F10
! SYNONYM K_F11 K-F11
! SYNONYM K_F12 K-F12
! 
  
  in-system
***************
*** 34,51 ****
  in-application
  
! 0x00 splkey K_HOME      0x01 splkey K_END       0x02 splkey K_INSERT
! 0x03 splkey K_DELETE    0x04 splkey K_LEFT      0x05 splkey K_RIGHT
! 0x06 splkey K_UP        0x07 splkey K_DOWN      0x08 splkey K_SCROLL
! 0x09 splkey K_PAUSE     0x10 splkey K_PGUP      0x11 splkey K_PGDN
  
  
! : +K_SHIFT      ( c1 -- c2 )  shift_mask or ;   \ add in shift bit
  \ 07/18/95 08:56 tjz ALT keys are for Windows Use ONLY!"
! : +K_ALT        ( c1 -- c2 )    alt_mask or ;   \ add in the Alt bit
  
  : +K_CONTROL    ( c1 -- c2 )
                  dup proc_mask 0x7FF or and upc 'A' 'Z' between
                  if      0xFF1F and              \ handle control letters
!                 else    control_mask or         \ add in control bit
                  then    ;
  
--- 48,79 ----
  in-application
  
! 0x00 splkey K-HOME      0x01 splkey K-END       0x02 splkey K-INSERT
! 0x03 splkey K-DELETE    0x04 splkey K-LEFT      0x05 splkey K-RIGHT
! 0x06 splkey K-UP        0x07 splkey K-DOWN      0x08 splkey K-SCROLL
! 0x09 splkey K-PAUSE     0x10 splkey K-PRIOR     0x11 splkey K-NEXT
  
  
! SYNONYM K_HOME   K-HOME
! SYNONYM K_END    K-END
! SYNONYM K_INSERT K-INSERT
! SYNONYM K_DELETE K-DELETE
! SYNONYM K_LEFT   K-LEFT
! SYNONYM K_RIGHT  K-RIGHT
! SYNONYM K_UP     K-UP
! SYNONYM K_DOWN   K-DOWN
! SYNONYM K_SCROLL K-SCROLL
! SYNONYM K_PAUSE  K-PAUSE
! SYNONYM K_PGDN   K-NEXT
! SYNONYM K_PGUP   K-PRIOR
! 
! 
! : +K_SHIFT      ( c1 -- c2 )  K-SHIFT-MASK or ;   \ add in shift bit
  \ 07/18/95 08:56 tjz ALT keys are for Windows Use ONLY!"
! : +K_ALT        ( c1 -- c2 )    K-ALT-MASK or ;   \ add in the Alt bit
  
  : +K_CONTROL    ( c1 -- c2 )
                  dup proc_mask 0x7FF or and upc 'A' 'Z' between
                  if      0xFF1F and              \ handle control letters
!                 else    K-CTRL-MASK or         \ add in control bit
                  then    ;
  

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.57
retrieving revision 1.58
diff -C2 -d -r1.57 -r1.58
*** FLOAT.F	14 Feb 2013 20:05:47 -0000	1.57
--- FLOAT.F	22 Apr 2013 19:53:53 -0000	1.58
***************
*** 425,428 ****
--- 425,435 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
+ internal
+ 
+   cfa-func dofvalue!   2 cells - @ f!  ; \ to be optimised
+   cfa-func dofvalue+!  3 cells - @ f+! ; \ to be optimised
+ 
+ external
+ 
  in-system
  
***************
*** 431,455 ****
                  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-previous
! 
! 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
--- 438,471 ----
                  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 f,
! \                 ;code
! \                   fld      fsize 4 [eax]
! \                   FPU>
! \                 float;
!                 create here 0 , dofvalue! , dofvalue+! , here swap ! f,
                  ;code
!                   mov      ecx,  4 [eax]
!                   fld      fsize 0 [ecx]
                    FPU>
                  float;
  
! \ in-previous
! \
! \ 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
! synonym fto to                          \ W32F               Floating extra
  \ *G \b Interpretation: ( -<fvalue>- -- fs: r -- ) \n
  \ ** Compilation:    ( -<fvalue>- --  Run-time: FS: r -- ) \d
***************
*** 457,464 ****
  \ ** 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-previous
--- 473,488 ----
  \ ** 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
! 
! 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>-. 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.
! 
  
  in-previous
***************
*** 514,517 ****
--- 538,576 ----
  \ 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