win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth/Help/hdb Help.cfg, 1.9, 1.10 HelpCls.tv, 1.15, 1.16 HelpSrc.hdb, 1.7, 1.8 HelpWrd.hdb, 1.21, 1.22 HelpWrd.tv, 1.20, 1.21 HelpWrd.txt, 1.21, 1.22 HelpWrd.ndx, 1.21, NONE

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/Help/hdb
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv18417/hdb

Modified Files:
	Help.cfg HelpCls.tv HelpSrc.hdb HelpWrd.hdb HelpWrd.tv 
	HelpWrd.txt 
Removed Files:
	HelpWrd.ndx 
Log Message:
Renamed index file extension to.hdx to avoid confusion with .ndx files used by the editors. Index file appears only to be needed to build the database: should it be a temporary file?

Index: HelpCls.tv
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpCls.tv,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** HelpCls.tv	14 Aug 2012 14:18:05 -0000	1.15
--- HelpCls.tv	7 Mar 2013 16:19:15 -0000	1.16
***************
*** 1,2290 ****
! 0 tvn| CLASSROOT| tvd| 5531|
  1 tvn| -methods-| tvd| 0|
! -2 tvn| CLASSINIT:| tvd| 5532|
! -2 tvn| ~:| tvd| 5533|
! -2 tvn| ADDR:| tvd| 5534|
! -2 tvn| PRINT:| tvd| 5535|
! 1 tvn| OBJECT| tvd| 5536|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| GET:| tvd| 5537|
! -3 tvn| PUT:| tvd| 5538|
[...4551 lines suppressed...]
! -4 tvn| FIELDNAME:| tvd| 8592|
! -4 tvn| GETINT:| tvd| 8593|
! -4 tvn| GETDOUBLE:| tvd| 8594|
! -4 tvn| GETFLOAT:| tvd| 8595|
! -4 tvn| GETSTR:| tvd| 8596|
! -4 tvn| GETBLOB:| tvd| 8597|
! -4 tvn| ISNULL?:| tvd| 8598|
! -4 tvn| NEXTROW:| tvd| 8599|
! -4 tvn| (BIND):| tvd| 8600|
! -4 tvn| BINDINT:| tvd| 8601|
! -4 tvn| BINDDOUBLE:| tvd| 8602|
! -4 tvn| BINDFLOAT:| tvd| 8603|
! -4 tvn| BINDSTR:| tvd| 8604|
! -4 tvn| BINDBLOB:| tvd| 8605|
! 1 tvn| STRING| tvd| 8612|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| GET:| tvd| 8613|
! -3 tvn| PUT:| tvd| 8614|
! -3 tvn| ADD:| tvd| 8615|
! -3 tvn| APPEND:| tvd| 8616|

Index: HelpSrc.hdb
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpSrc.hdb,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
Binary files /tmp/cvsosjzw6 and /tmp/cvsR4i54a differ

Index: Help.cfg
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/Help.cfg,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Help.cfg	26 Feb 2012 19:43:25 -0000	1.9
--- Help.cfg	7 Mar 2013 16:19:15 -0000	1.10
***************
*** 1,7 ****
  [WindowX] -2
  [WindowY] -2
! [WindowW] 1021
  [WindowH] 708
! [SplitterV] 201
  [SplitterH] 112
    
\ No newline at end of file
--- 1,7 ----
  [WindowX] -2
  [WindowY] -2
! [WindowW] 1020
  [WindowH] 708
! [SplitterV] 200
  [SplitterH] 112
    
\ No newline at end of file

Index: HelpWrd.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.txt,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -d -r1.21 -r1.22
*** HelpWrd.txt	14 Aug 2012 14:18:05 -0000	1.21
--- HelpWrd.txt	7 Mar 2013 16:19:16 -0000	1.22
***************
*** 1448,1453 ****
  BYTES &PS 
  : (CLASSINIT) ( -- ) 
- : (CLASSINIT) ( x y width height -- ) 
  : (CLASSINIT) ( n1 -- ) 
  CONSTANT 1/1 
  CONSTANT 1/2 
--- 1448,1453 ----
  BYTES &PS 
  : (CLASSINIT) ( -- ) 
  : (CLASSINIT) ( n1 -- ) 
[...1799 lines suppressed...]
  INT PS_FERASE 
--- 14677,14681 ----
  :M PARENTWINDOW: ( -- hWndParent ) 
  \ Get the handle of the owner window (0 if no parent).
! \ NOTE: This method is deprecated. Use GetParentWindow: instead.
  INT PS_BOTTOM 
  INT PS_FERASE 
***************
*** 14713,14717 ****
  :M SETPARENT: ( hWndParent -- ) 
  \ Set handle of the owner window (0 if no parent).
! \ NOTE: This method is depreacted. Use SetParentWindow: instead.
  :M SETPARENTWINDOW: ( hWndParent -- ) 
  \ Set handle of the owner window (0 if no parent).
--- 14713,14717 ----
  :M SETPARENT: ( hWndParent -- ) 
  \ Set handle of the owner window (0 if no parent).
! \ NOTE: This method is deprecated. Use SetParentWindow: instead.
  :M SETPARENTWINDOW: ( hWndParent -- ) 
  \ Set handle of the owner window (0 if no parent).

Index: HelpWrd.hdb
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.hdb,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -d -r1.21 -r1.22
Binary files /tmp/cvssqwcza and /tmp/cvsQig5ff differ

Index: HelpWrd.tv
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.tv,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** HelpWrd.tv	14 Aug 2012 14:18:05 -0000	1.20
--- HelpWrd.tv	7 Mar 2013 16:19:16 -0000	1.21
***************
*** 1,5278 ****
  0 tvn| Words| tvd| 0|
! 1 tvn| CLASSROOT| tvd| 5531|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| CLASSINIT:| tvd| 5532|
! -3 tvn| ~:| tvd| 5533|
! -3 tvn| ADDR:| tvd| 5534|
! -3 tvn| PRINT:| tvd| 5535|
! 2 tvn| OBJECT| tvd| 5536|
  3 tvn| -methods-| tvd| 0|
! -4 tvn| GET:| tvd| 5537|
[...24602 lines suppressed...]
! 2 tvn| \+| tvd| 5350|
! 2 tvn| \-| tvd| 5351|
! 2 tvn| \IN-SYSTEM-OK| tvd| 5356|
! 2 tvn| \S| tvd| 5405|
! 2 tvn| ]MACRO| tvd| 5242|
! 2 tvn| __STDCALL| tvd| 5233|
! 2 tvn| {| tvd| 5428|
! 2 tvn| {:| tvd| 5427|
! 2 tvn| |IF| tvd| 4927|
! 2 tvn| |OF| tvd| 4926|
  1 tvn| Deprecated| tvd| 0|
! 2 tvn| .DIR->FILE-NAME| tvd| 5080|
! 2 tvn| >BOLD| tvd| 4139|
! 2 tvn| >NORM| tvd| 4138|
! 2 tvn| ABS>REL| tvd| 5376|
! 2 tvn| REL>ABS| tvd| 5377|
  2 tvn| TASK-SLEEP| tvd| 2597|
! 2 tvn| _PRINT-DIR-FILES| tvd| 5078|
  1 tvn| Vocabularies| tvd| 0|
  2 tvn| Application space| tvd| 0|

--- HelpWrd.ndx DELETED ---

[Win32forth-cvs] win32forth/apps/Setup Setup.f,1.28,1.29

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Setup
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv9767/Setup

Modified Files:
	Setup.f 
Log Message:
Removed some files from the build

Index: Setup.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Setup/Setup.f,v
retrieving revision 1.28
retrieving revision 1.29
diff -C2 -d -r1.28 -r1.29
*** Setup.f	17 Jan 2012 21:12:25 -0000	1.28
--- Setup.f	7 Mar 2013 15:36:22 -0000	1.29
***************
*** 30,60 ****
      FLOAD ..\..\src\ansfile.f
      FLOAD ..\..\src\callback.f
- 
-     FLOAD ..\..\src\mapfile.f      \ Windows32 file into memory mapping words
- 
-     FLOAD ..\..\src\w32fmsglist.f  \ win32forth applications & messages IDs
- 
- \ The current Version of the file w32fmsg.f needs the word MS@
- \ wich is defined in utils.f.
- \ Because including utils.f here doesn't work so I added copy of the MS@ code here.
- \ Not nice, but working...
- \ Montag, August 30 2010 - 19:17 dbu
- 16 constant TIME-LEN
- time-len newuser TIME-BUF
- 
- 1 proc GetLocalTime
- 
- : get-local-time ( -- )                 \ get the local computer date and time
- 	time-buf call GetLocalTime drop ;
- 
- : ms@	( -- ms )
- 	get-local-time
- 	time-buf
- 	dup   8 + w@     60 *           \ hours
- 	over 10 + w@ +   60 *           \ minutes
- 	over 12 + w@ + 1000 *           \ seconds
- 	swap 14 + w@ + ;                \ milli-seconds
- 
-     FLOAD ..\..\src\w32fmsg.f      \ w32f application messaging
      FLOAD ..\..\src\shell.f
  SYS-FLOAD ..\..\src\imageman.f
--- 30,33 ----

[Win32forth-cvs] win32forth/src CreateProcess.f, NONE, 1.1 Pre-save.f, 1.2, 1.3 Primutil.f, 1.55, 1.56 Shell.f, 1.11, 1.12 imageman.f, 1.28, 1.29 sysload.f, 1.3, 1.4 w32fMsg.f, 1.20, 1.21

[George H. <geo...@us...>]

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

Modified Files:
	Pre-save.f Primutil.f Shell.f imageman.f sysload.f w32fMsg.f 
Added Files:
	CreateProcess.f 
Log Message:
Removed dependencies between Shell.f and W32fMsg.f. Added file CreateProcess.f. Moved some values to Primutil.f from w32Msg.f to remove dependencies in imageman.f. Imroved save  etc.

Index: w32fMsg.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/w32fMsg.f,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** w32fMsg.f	11 Jul 2011 18:50:40 -0000	1.20
--- w32fMsg.f	7 Mar 2013 15:29:02 -0000	1.21
***************
*** 112,123 ****
  \ ------------------------------------------------------------------------------
  
  Require mapfile.f
  
! 0 value MyAppID
  \ *G My unique current win32forth application identifier \n
  \ ** A value of 0 means I don't share memory \n
  \ ** READ-ONLY : DON'T change this value directly, set \tNewAppID\d instead.
  
! 0 value NewAppID
  \ *G Set this value to change the ID of your application \n
  \ ** Change will be effective after either \tSAVE\d or \tTURNKEY\d .
--- 112,125 ----
  \ ------------------------------------------------------------------------------
  
+ Require w32fMsgList.f
+ 
  Require mapfile.f
  
! \ 0 value MyAppID
  \ *G My unique current win32forth application identifier \n
  \ ** A value of 0 means I don't share memory \n
  \ ** READ-ONLY : DON'T change this value directly, set \tNewAppID\d instead.
  
! \ 0 value NewAppID
  \ *G Set this value to change the ID of your application \n
  \ ** Change will be effective after either \tSAVE\d or \tTURNKEY\d .
***************
*** 125,135 ****
  \ ** Used to configurate your application
  
! 0 value RunUnique
  \ *G Set this value to true if you want your application to run as a unique instance \n
  \ ** Change will be effective after either \tSAVE\d or \tTURNKEY\d . \n
  \ ** Used to configurate your application
  
! 0 value MyRunUnique    \ true if I am running as a unique instance
! 0 value StopLaunching  \ true if a new instance of me must be stopped
   create w32fshareName  \ a complex enough win32forth application shared-memory name
          z," *.Win32ForthSharedMemory.*"
--- 127,136 ----
  \ ** Used to configurate your application
  
! \ 0 value RunUnique
  \ *G Set this value to true if you want your application to run as a unique instance \n
  \ ** Change will be effective after either \tSAVE\d or \tTURNKEY\d . \n
  \ ** Used to configurate your application
  
! \ 0 value MyRunUnique    \ true if I am running as a unique instance
   create w32fshareName  \ a complex enough win32forth application shared-memory name
          z," *.Win32ForthSharedMemory.*"
***************
*** 188,191 ****
--- 189,201 ----
                  -1 abort" in EnableW32FMsg : Enable shared memory before messaging" ;
  
+ : (?EnableConsoleMessages) ( -- )
+                 MyAppID w32fForth =             \ if win32for.exe itself
+                 if conhndl EnableW32FMsg then ; \ enable messaging thru Console
+ 
+ : Set?EnableConsoleMessages ( -- )
+                 ['] (?EnableConsoleMessages) is ?EnableConsoleMessages ;
+ 
+ initialization-chain  chain-add         Set?EnableConsoleMessages
+ 
  : SetShared    ( AppID -- ) \ append AppID record in shared memory
                  w32fsharep                      \ get next available record
***************
*** 456,518 ****
  \ ------------------------------------------------------------------------------
  
! 10 proc CreateProcess
!  1 proc CloseHandle
!  1 proc IsIconic
!  2 proc ShowWindow
!  1 proc SetForegroundWindow
!  2 proc WaitForInputIdle
! 
! create StartupInfo
! NoStack         here 0 ,                \ cb
!                 0 ,                     \ lpReserved
!                 0 ,                     \ lpDesktop
!                 0 ,                     \ lpTitle
!                 0 ,                     \ dwX
!                 0 ,                     \ dwY
!                 0 ,                     \ dwXSize
!                 0 ,                     \ dwYSize
!                 0 ,                     \ dwXCountChars
!                 0 ,                     \ dwYCountChars
!                 0 ,                     \ dwFillAttribute
!                 STARTF_USESHOWWINDOW ,  \ dwFlags
!                 SW_SHOWNORMAL W,        \ wShowWindow
!                 0 W,                    \ cbReserved2
!                 0 ,                     \ lpReserved2
!                 0 ,                     \ hStdInput
!                 0 ,                     \ hStdOutput
!                 0 ,                     \ hStdError
!                 here over - swap !
! 
! create ProcInfo
!                 0 ,                     \ hProcess
!                 0 ,                     \ hThread
!                 0 ,                     \ dwPriocessId
!                 0 ,                     \ dwThreadId
! 
! create processcmd max-path 1+ allot \ counted null-terminated command line
! 
! : [CreateProcess] ( addr len -- flag )  \ create the process given as the first token in
!                 \ the "command line" addr/len . Flag true if failed
!                 ProcInfo 4 cells erase  \ clear procinfo
!                 processcmd place
!                 processcmd +null        \ null terminated command line string
!                 ProcInfo                \ lppiProcInfo
!                 StartupInfo             \ lpsiStartInfo
!                 0                       \ lpszCurDir
!                 0                       \ lpvEnvironment
!                 0                       \ fdwCreate
!                 0                       \ fInheritHandles
!                 0                       \ lpsaThread
!                 0                       \ lpsaProcess
!                 processcmd 1+           \ lpszCommandLine
!                 0                       \ lpszImageName
!                 call CreateProcess 0= ;
! 
! : CloseProcess  ( -- ) \ close process handle of opened process
!                 ProcInfo @ call CloseHandle drop ;   \ process
! 
! : CloseThread   ( -- ) \ close thread handle of opened process
!                 ProcInfo cell+ @ call CloseHandle drop ;   \ thread
! 
  
  \ ------------------------------------------------------------------------------
--- 466,470 ----
  \ ------------------------------------------------------------------------------
  
! Require CreateProcess.f
  
  \ ------------------------------------------------------------------------------
***************
*** 543,547 ****
                       SetForegroundWindow drop        \ and activate it
                       2drop 0
!                 else >r [createprocess]              \ launch the w32fapp
                       if   r>drop -1
                       else 2000  30 time-taken * + ( ms) ProcInfo @      \ give the launched process a..
--- 495,499 ----
                       SetForegroundWindow drop        \ and activate it
                       2drop 0
!                 else >r ((createprocess))            \ launch the w32fapp
                       if   r>drop -1
                       else 2000  30 time-taken * + ( ms) ProcInfo @      \ give the launched process a..

Index: sysload.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/sysload.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** sysload.f	19 Aug 2011 13:10:45 -0000	1.3
--- sysload.f	7 Mar 2013 15:29:02 -0000	1.4
***************
*** 209,213 ****
  
      [char] " r@ c+place
!     s" src=lib\" prepend<home>\ r@ +place
      bl word count -trailing r@ +place
      s" \*.F" r@ +place
--- 209,213 ----
  
      [char] " r@ c+place
!     s" src\lib\" prepend<home>\ r@ +place
      bl word count -trailing r@ +place
      s" \*.F" r@ +place

Index: Shell.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Shell.f,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** Shell.f	31 Aug 2010 08:02:47 -0000	1.11
--- Shell.f	7 Mar 2013 15:29:02 -0000	1.12
***************
*** 13,19 ****
  
  
! \ [CreateProcess] is defined in w32fmsg.f
  
! Require w32fmsg.f
  
  2 proc WaitForInputIdle
--- 13,19 ----
  
  
! \ ((CreateProcess)) is defined in CreateProcess.f
  
! Require CreateProcess.f
  
  2 proc WaitForInputIdle
***************
*** 36,40 ****
  
  : zEXEC-CMD     ( a1 -- f1 ) \ execute a command line
!         count [CreateProcess] dup 0=
          if   CloseThread
               CloseProcess
--- 36,40 ----
  
  : zEXEC-CMD     ( a1 -- f1 ) \ execute a command line
!         count ((CreateProcess)) dup 0=
          if   CloseThread
               CloseProcess
***************
*** 42,46 ****
  
  : zEXEC-CMD-WAIT ( a1 -- f1 ) \ execute a command line, and wait for terminating of the process
!         count [CreateProcess] dup 0=
          IF   CloseThread               \ close the thread handle
               EXEC-PROCESS-WAIT         \ wait for the process
--- 42,46 ----
  
  : zEXEC-CMD-WAIT ( a1 -- f1 ) \ execute a command line, and wait for terminating of the process
!         count ((CreateProcess)) dup 0=
          IF   CloseThread               \ close the thread handle
               EXEC-PROCESS-WAIT         \ wait for the process

Index: imageman.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/imageman.f,v
retrieving revision 1.28
retrieving revision 1.29
diff -C2 -d -r1.28 -r1.29
*** imageman.f	5 Mar 2013 20:46:01 -0000	1.28
--- imageman.f	7 Mar 2013 15:29:02 -0000	1.29
***************
*** 864,869 ****
                       s" Exception occured in Forth initialization" MsgBox
                       \ .exception ?
!                 else MyAppID w32fForth =            \ if win32for.exe itself
!                      if conhndl EnableW32FMsg then  \ enable messaging thru Console
  
                       action-of default-application catch
--- 864,868 ----
                       s" Exception occured in Forth initialization" MsgBox
                       \ .exception ?
!                 else ?EnableConsoleMessages
  
                       action-of default-application catch
***************
*** 931,953 ****
  
  
! : ((SAVE))      { addr len \ $name -- }         \ build .exe
!                 MAXSTRING localAlloc: $name
!                 z" .EXE"                        \ .exe extension
!                 addr len $name ascii-z dup>r    \ z-string the name
!                 call PathAddExtension drop      \ add extension
!                 r> zcount &appdir count         \ add application directory
!                 MakeAbsolutePath count          \ if needed
  
!                 STD-IMG2EXE                     \ make image
!                 IMAGE-PTR release ;             \ free image-copy buffer
  
  
- : (SAVE)        ( addr len  -- ) \ use current image & build .exe
-                 2>r
-                 MyAppId                         \ save saver's app params
-                 if   MyAppId SharedHwnd -1
-                      MyAppId MyRunUnique
-                 else 0 0 0
-                 then                            \ ( -- [hwnd id runmode] id )
  
                  ConsoleMode
--- 930,948 ----
  
  
! \ : ((SAVE))      { addr len \ $name -- }         \ build .exe
! \                 MAXSTRING localAlloc: $name
! \                 z" .EXE"                        \ .exe extension
! \                 addr len $name ascii-z dup>r    \ z-string the name
! \                 call PathAddExtension drop      \ add extension
! \                 r> zcount &appdir count         \ add application directory
! \                 MakeAbsolutePath count          \ if needed
! \
! \                 STD-IMG2EXE                     \ make image
! \                 IMAGE-PTR release ;             \ free image-copy buffer
! \
  
! : (SAVE)        { addr len | $name -- } \ use current image & build .exe
  
  
  
                  ConsoleMode
***************
*** 961,974 ****
                  is DoConsoleBoot                \ set SAVEd console mode
                  0 to ConsoleMode                \ reset default (saver & image)
!                 RunAsNewAppID                   \ transiently switch to new appID
  
                  IMAGE-COPY                      \ create memory .img
!                 2r> ['] ((SAVE)) catch >r       \ save memory image
  
!                 to RunUnique to NewAppID        \ restore saver's app params
!                 RunAsNewAppID
!                 if EnableW32fMsg then
  
-                 r> throw ;                      \ throw error after restore
  
  \ Note: no need to preserve BOOT and DEFAULT-APPLICATION because they are both
--- 956,972 ----
                  is DoConsoleBoot                \ set SAVEd console mode
                  0 to ConsoleMode                \ reset default (saver & image)
! 
  
                  IMAGE-COPY                      \ create memory .img
!                 MAXSTRING localAlloc: $name
!                 z" .EXE"                        \ .exe extension
!                 addr len $name ascii-z dup>r    \ z-string the name
!                 call PathAddExtension drop      \ add extension
!                 r> zcount &appdir count         \ add application directory
!                 MakeAbsolutePath count          \ if needed
  
!                 STD-IMG2EXE                     \ make image
!                 IMAGE-PTR release ;             \ free image-copy buffer
  
  
  \ Note: no need to preserve BOOT and DEFAULT-APPLICATION because they are both
***************
*** 985,991 ****
                  r> is default-application
                  &except off                       \ no previous exceptions...
!                 2r> ['] (SAVE) catch >r
! 
!                 r> throw ;                        \ throw error after restore
  
  : SAVE          ( cfa -<exename>- -- ) \ create application "exename" that runs the
--- 983,987 ----
                  r> is default-application
                  &except off                       \ no previous exceptions...
!                 2r> (SAVE) ;
  
  : SAVE          ( cfa -<exename>- -- ) \ create application "exename" that runs the

Index: Pre-save.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Pre-save.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Pre-save.f	3 Mar 2012 09:15:14 -0000	1.2
--- Pre-save.f	7 Mar 2013 15:29:02 -0000	1.3
***************
*** 31,33 ****
--- 31,46 ----
  pre-save-image-chain chain-add init-image-handles
  
+ : Init?EnableConsoleMessages ( -- )
+                 ['] noop ['] ?EnableConsoleMessages >image >body ! ;
+ 
+ pre-save-image-chain chain-add Init?EnableConsoleMessages
+ 
  in-previous
+ 
+ : PreInitAppID  ( -- )
+                 NewAppID &of MyAppID >image !
+                 RunUnique &of MyRunUnique >image !
+                 0 to RunUnique                \ restore defaults
+                 0 to NewAppID ;
+ 
+  pre-save-image-chain chain-add PreInitAppID

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.55
retrieving revision 1.56
diff -C2 -d -r1.55 -r1.56
*** Primutil.f	14 Feb 2013 20:05:48 -0000	1.55
--- Primutil.f	7 Mar 2013 15:29:02 -0000	1.56
***************
*** 185,193 ****
  
  : defer@        ( xt1 -- xt2 )           \ 200X               Core ext x:deferred
! \ *G xt1 is deffered word. xt2 is current setting.
                  ?is >body @ ;
  
  : DEFER!        ( xt2 xt1 -- )           \ 200X               Core ext x:deferred
! \ *G xt1 is deffered word. xt2 is new setting.
                  ?is >body ! ;
  
--- 185,193 ----
  
  : defer@        ( xt1 -- xt2 )           \ 200X               Core ext x:deferred
! \ *G xt1 is deferred word. xt2 is current setting.
                  ?is >body @ ;
  
  : DEFER!        ( xt2 xt1 -- )           \ 200X               Core ext x:deferred
! \ *G xt1 is deferred word. xt2 is new setting.
                  ?is >body ! ;
  
***************
*** 957,960 ****
--- 957,974 ----
  : ERASE$ ( adr - )   MAXSTRING ERASE ;
  
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ 
+ 0 value MyAppID
+ 0 value NewAppID
+ 0 value RunUnique
+ 0 value MyRunUnique
+ 0 value StopLaunching  \ true if a new instance of me must be stopped
+ 
+ defer ?EnableConsoleMessages
+ ' noop is ?EnableConsoleMessages
+ 
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

--- NEW FILE: CreateProcess.f ---
\ $Id: CreateProcess.f,v 1.1 2013/03/07 15:29:02 georgeahubert Exp $

\ Made into separate file since it's used by both w32fMsg.f and Shell.f

10 proc CreateProcess
 1 proc CloseHandle
 1 proc IsIconic
 2 proc ShowWindow
 1 proc SetForegroundWindow
 2 proc WaitForInputIdle

create StartupInfo
NoStack         here 0 ,                \ cb
                0 ,                     \ lpReserved
                0 ,                     \ lpDesktop
                0 ,                     \ lpTitle
                0 ,                     \ dwX
                0 ,                     \ dwY
                0 ,                     \ dwXSize
                0 ,                     \ dwYSize
                0 ,                     \ dwXCountChars
                0 ,                     \ dwYCountChars
                0 ,                     \ dwFillAttribute
                STARTF_USESHOWWINDOW ,  \ dwFlags
                SW_SHOWNORMAL W,        \ wShowWindow
                0 W,                    \ cbReserved2
                0 ,                     \ lpReserved2
                0 ,                     \ hStdInput
                0 ,                     \ hStdOutput
                0 ,                     \ hStdError
                here over - swap !

create ProcInfo
                0 ,                     \ hProcess
                0 ,                     \ hThread
                0 ,                     \ dwPriocessId
                0 ,                     \ dwThreadId

create processcmd max-path 1+ allot \ counted null-terminated command line

: ((CreateProcess)) ( addr len -- flag )
                \ create the process given as the first token in the "command line" addr/len . Flag true if failed
                ProcInfo 4 cells erase  \ clear procinfo
                processcmd place
                processcmd +null        \ null terminated command line string
                ProcInfo                \ lppiProcInfo
                StartupInfo             \ lpsiStartInfo
                0                       \ lpszCurDir
                0                       \ lpvEnvironment
                0                       \ fdwCreate
                0                       \ fInheritHandles
                0                       \ lpsaThread
                0                       \ lpsaProcess
                processcmd 1+           \ lpszCommandLine
                0                       \ lpszImageName
                call CreateProcess 0= ;

: CloseProcess  ( -- ) \ close process handle of opened process
                ProcInfo @ call CloseHandle drop ;   \ process

: CloseThread   ( -- ) \ close thread handle of opened process
                ProcInfo cell+ @ call CloseHandle drop ;   \ thread

[Win32forth-cvs] win32forth/src imagehds.f, 1.2, 1.3 imageman.f, 1.27, 1.28

[George H. <geo...@us...>]

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

Modified Files:
	imagehds.f imageman.f 
Log Message:
Modified Imageman to not mark code section as unitialised, modified Statusbar to use a local structure plus minor corrections.

Index: imagehds.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/imagehds.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** imagehds.f	5 Jan 2005 23:30:00 -0000	1.2
--- imagehds.f	5 Mar 2013 20:46:01 -0000	1.3
***************
*** 126,131 ****
  0X40000000 CONSTANT S-READ
  0X80000000 CONSTANT S-WRITE
! S-CODE S-EXECUTE S-READ S-INIT OR OR OR CONSTANT STD-CODE \ abbreviation
! S-READ S-WRITE S-INIT OR OR             CONSTANT STD-DATA \ abbreviation
  
  FLDBASE BASE-IID
--- 126,131 ----
  0X40000000 CONSTANT S-READ
  0X80000000 CONSTANT S-WRITE
! S-CODE S-EXECUTE S-READ OR OR     CONSTANT STD-CODE \ abbreviation
! S-READ S-WRITE   S-INIT OR OR     CONSTANT STD-DATA \ abbreviation
  
  FLDBASE BASE-IID
***************
*** 159,164 ****
           4 FLD         RELOC-BLOCKLEN   \ length of the reloc section (from RELOC-RVA-PAGE)
           2 FLD         RELOC-FIXUP      \ 4 bit type, 12 bit offset
!    VALUE RELOC-LEN DROP                 \ length, variable  
!    
  0x0000 CONSTANT RELOC-ABS               \ absolute (a noop)
  0x3000 CONSTANT RELOC-HILO              \ high/low relocation (32 bit relocation)
--- 159,164 ----
           4 FLD         RELOC-BLOCKLEN   \ length of the reloc section (from RELOC-RVA-PAGE)
           2 FLD         RELOC-FIXUP      \ 4 bit type, 12 bit offset
!    VALUE RELOC-LEN DROP                 \ length, variable
! 
  0x0000 CONSTANT RELOC-ABS               \ absolute (a noop)
  0x3000 CONSTANT RELOC-HILO              \ high/low relocation (32 bit relocation)

Index: imageman.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/imageman.f,v
retrieving revision 1.27
retrieving revision 1.28
diff -C2 -d -r1.27 -r1.28
*** imageman.f	26 Feb 2012 16:43:58 -0000	1.27
--- imageman.f	5 Mar 2013 20:46:01 -0000	1.28
***************
*** 683,687 ****
  
          s" .code"                  SECTION
!         STD-DATA STD-CODE or         SECTIONTYPE
          IMAGE-CODEPTR IMAGE-CACTUAL   SECTIONDATA
          IMAGE-CSIZE                   SECTIONSIZE
--- 683,687 ----
  
          s" .code"                  SECTION
!         STD-CODE S-WRITE or           SECTIONTYPE
          IMAGE-CODEPTR IMAGE-CACTUAL   SECTIONDATA
          IMAGE-CSIZE                   SECTIONSIZE

[Win32forth-cvs] win32forth/apps/WinEd Ed_Search.F,1.4,1.5

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/WinEd
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv31391

Modified Files:
	Ed_Search.F 
Log Message:
Jos Adapted also the duplicate

Index: Ed_Search.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Search.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Ed_Search.F	20 Feb 2013 22:10:15 -0000	1.4
--- Ed_Search.F	21 Feb 2013 01:09:57 -0000	1.5
***************
*** 240,253 ****
   ;
  
! : +trailing ( adr count char - adr2 count2 )
!     over 0>
!        if   -rot dup>r over + swap dup>r
!                  ?do   i c@ over <>
!                        if   i leave
!                        then
!                  loop
!              nip r> -dup - r> swap -
!        else  drop
!        then
   ;
  
--- 240,250 ----
   ;
  
! : +trailing  ( addr count  char -- adr2 count2 ) \ remove leading char
!    locals| char |
!      dup 0>
!         if  begin   over c@ char =
!             while   1 /string
!             repeat
!         then
   ;
  

[Win32forth-cvs] win32forth/src/lib w_search.f,1.8,1.9

[Jos v.d.V. <jo...@us...>]

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

Modified Files:
	w_search.f 
Log Message:
Jos  complete makeover of +trailing

Index: w_search.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/w_search.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** w_search.f	20 Feb 2013 21:56:30 -0000	1.8
--- w_search.f	21 Feb 2013 01:05:34 -0000	1.9
***************
*** 21,24 ****
--- 21,27 ----
  \  - Added "SetToForeground
  
+ \ February 21st, 2013
+ \  - Improved +training
+ 
  \  From toolset.f \ load it here when you would like to use it.
  
***************
*** 263,276 ****
   ;
  
! : +trailing ( adr count char - adr2 count2 )
!     over 0>
!        if   -rot dup>r over + swap dup>r
!                  ?do   i c@ over <>
!                        if   i leave
!                        then
!                  loop
!              nip r> -dup - r> swap -
!        else  drop
!        then
   ;
  
--- 266,276 ----
   ;
  
! : +trailing  ( addr count  char -- adr2 count2 ) \ remove leading char
!    locals| char |
!      dup 0>
!         if  begin   over c@ char =
!             while   1 /string
!             repeat
!         then
   ;
  

[Win32forth-cvs] win32forth/apps/WinEd Ed_Search.F,1.3,1.4

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/WinEd
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv18061

Modified Files:
	Ed_Search.F 
Log Message:
Jos Also adapted the duplicate +trailing

Index: Ed_Search.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Search.F,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Ed_Search.F	5 May 2005 09:43:28 -0000	1.3
--- Ed_Search.F	20 Feb 2013 22:10:15 -0000	1.4
***************
*** 4,8 ****
  \ Created: Sunday, January 30 2005 - 16:45 aws
  \
! \ 
  
  : never         ( flag - false ) drop false ;
--- 4,8 ----
  \ Created: Sunday, January 30 2005 - 16:45 aws
  \
! \
  
  : never         ( flag - false ) drop false ;
***************
*** 241,250 ****
  
  : +trailing ( adr count char - adr2 count2 )
!     -rot dup>r over + swap dup>r
!         ?do   i c@ over <>
!                 if   i leave
!                 then
!         loop
!      nip r> -dup - r> swap -
   ;
  
--- 241,253 ----
  
  : +trailing ( adr count char - adr2 count2 )
!     over 0>
!        if   -rot dup>r over + swap dup>r
!                  ?do   i c@ over <>
!                        if   i leave
!                        then
!                  loop
!              nip r> -dup - r> swap -
!        else  drop
!        then
   ;
  
***************
*** 678,681 ****
                  THEN
          THEN
!         SetFocus: DocWindow ; 
! 

[Win32forth-cvs] win32forth/src/lib w_search.f,1.7,1.8

[Jos v.d.V. <jo...@us...>]

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

Modified Files:
	w_search.f 
Log Message:
Jos Now +trailing is also right when 0 characters are offered

Index: w_search.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/w_search.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** w_search.f	24 Feb 2007 18:11:05 -0000	1.7
--- w_search.f	20 Feb 2013 21:56:30 -0000	1.8
***************
*** 264,273 ****
  
  : +trailing ( adr count char - adr2 count2 )
!     -rot dup>r over + swap dup>r
!         ?do   i c@ over <>
!                 if   i leave
!                 then
!         loop
!      nip r> -dup - r> swap -
   ;
  
--- 264,276 ----
  
  : +trailing ( adr count char - adr2 count2 )
!     over 0>
!        if   -rot dup>r over + swap dup>r
!                  ?do   i c@ over <>
!                        if   i leave
!                        then
!                  loop
!              nip r> -dup - r> swap -
!        else  drop
!        then
   ;
  

[Win32forth-cvs] win32forth/src CALLBACK.f, 1.18, 1.19 CLASSDBG.F, 1.10, 1.11 Class.f, 1.42, 1.43 Debug.f, 1.22, 1.23 FLOAT.F, 1.56, 1.57 Menu.f, 1.8, 1.9 Primutil.f, 1.54, 1.55 Window.f, 1.27, 1.28

[George H. <geo...@us...>]

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

Modified Files:
	CALLBACK.f CLASSDBG.F Class.f Debug.f FLOAT.F Menu.f 
	Primutil.f Window.f 
Log Message:
Tidy up of comments

Index: CALLBACK.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/CALLBACK.f,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** CALLBACK.f	20 Nov 2011 19:42:10 -0000	1.18
--- CALLBACK.f	14 Feb 2013 20:05:47 -0000	1.19
***************
*** 170,174 ****
                  BUILD-CALLBACK >R CONSTANT ' R> ! ;
  
! : CALLBACK:     ( args -<name>- )               \ w32f sys
  \ *G Define a callback function that has n1 arguments.
  \ *P CALLBACK: creates TWO definitions! The first has the name you specify,
--- 170,174 ----
                  BUILD-CALLBACK >R CONSTANT ' R> ! ;
  
! : CALLBACK:     ( args -"name"- )               \ w32f sys
  \ *G Define a callback function that has n1 arguments.
  \ *P CALLBACK: creates TWO definitions! The first has the name you specify,

Index: Debug.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Debug.f,v
retrieving revision 1.22
retrieving revision 1.23
diff -C2 -d -r1.22 -r1.23
*** Debug.f	8 Oct 2008 09:15:07 -0000	1.22
--- Debug.f	14 Feb 2013 20:05:47 -0000	1.23
***************
*** 21,27 ****
  \ ------------------------------------------------------------------------------
  
! \ theese chains are used to later add new words types to be debugged
! new-chain dbg-nest-chain        ( cfa flag -- cfa false | true )
! new-chain .word-type-chain
  new-chain dbg-next-cell         ( ip cfa -- ip' cfa )
  
--- 21,27 ----
  \ ------------------------------------------------------------------------------
  
! \ these chains are used to later add new words types to be debugged
! new-chain dbg-nest-chain        ( i*x cfa flag --  i*x cfa false | true )
! new-chain .word-type-chain      ( cfa flag -- cfa false | true )
  new-chain dbg-next-cell         ( ip cfa -- ip' cfa )
  

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.56
retrieving revision 1.57
diff -C2 -d -r1.56 -r1.57
*** FLOAT.F	27 Feb 2012 15:04:53 -0000	1.56
--- FLOAT.F	14 Feb 2013 20:05:47 -0000	1.57
***************
*** 427,435 ****
  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,
--- 427,435 ----
  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,
***************
*** 464,469 ****
  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
--- 464,469 ----
  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
***************
*** 1512,1516 ****
  in-system
  
! : float-array   ( n1 -<name>- )         \ compile time
                  ( -- a1 )               \ runtime
                  create floats allot ;
--- 1512,1516 ----
  in-system
  
! : float-array   ( n1 "name" -- )         \ compile time
                  ( -- a1 )               \ runtime
                  create floats allot ;
***************
*** 1560,1591 ****
  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
  
--- 1560,1591 ----
  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
  

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.42
retrieving revision 1.43
diff -C2 -d -r1.42 -r1.43
*** Class.f	26 Feb 2012 16:43:58 -0000	1.42
--- Class.f	14 Feb 2013 20:05:47 -0000	1.43
***************
*** 1010,1014 ****
  0 value BeginningOfRecordAddress
  
! : Record:       ( -<name>- )  \ W32F             Class
  \ *G Define a word that returns the starting address of a group of data fields that
  \ ** need to be contiguous. Object IVARS have their class pointer suppressed if used
--- 1010,1014 ----
  0 value BeginningOfRecordAddress
  
! : Record:       ( -"name"- )  \ W32F             Class
  \ *G Define a word that returns the starting address of a group of data fields that
  \ ** need to be contiguous. Object IVARS have their class pointer suppressed if used
***************
*** 1025,1029 ****
                  0 to contiguous-data? ;
  
! : ;RecordSize:  ( -<name>- )  \ W32F             Class
  \ *G End a group of data fields that need to be contiguous and create a name with the
  \ ** size of the record.
--- 1025,1029 ----
                  0 to contiguous-data? ;
  
! : ;RecordSize:  ( -"name"- )  \ W32F             Class
  \ *G End a group of data fields that need to be contiguous and create a name with the
  \ ** size of the record.
***************
*** 1032,1036 ****
  \ -------------------- Instance Variables --------------------
  
! : bytes         ( n -<name>- )         \ W32F          Class
  \ *G n-Bytes instance variable (array of bytes)
                  header
--- 1032,1036 ----
  \ -------------------- Instance Variables --------------------
  
! : bytes         ( n -"name"- )         \ W32F          Class
  \ *G n-Bytes instance variable (array of bytes)
                  header
***************
*** 1044,1048 ****
  :noname 0 bytes ; is ivar-name
  
! : byte          ( -<name>- )           \ W32F          Class
  \ *G Byte (8bit) size instance variable.
                  header
--- 1044,1048 ----
  :noname 0 bytes ; is ivar-name
  
! : byte          ( -"name"- )           \ W32F          Class
  \ *G Byte (8bit) size instance variable.
                  header
***************
*** 1088,1092 ****
  in-system
  
! : bits          { nbits -- -<name>- }   \ W32F          Class
  \ *G Define an 'nbits' bit field in prev data item.
  \ *E Example:
--- 1088,1092 ----
  in-system
  
! : bits          { nbits -- -"name"- }   \ W32F          Class
  \ *G Define an 'nbits' bit field in prev data item.
  \ *E Example:
***************
*** 1113,1118 ****
                  nbits class-bitallot ;
  
! : short         ( -<name>- )             \ W32F          Class
! \ *G Word integer (16bit) instance variable. When -<name>- is executed the value of -<name>-
  \ ** is zero-extended before pushing onto the stack.
                  header
--- 1113,1118 ----
                  nbits class-bitallot ;
  
! : short         ( -"name"- )             \ W32F          Class
! \ *G Word integer (16bit) instance variable. When -"name"- is executed the value of -"name"-
  \ ** is zero-extended before pushing onto the stack.
                  header
***************
*** 1124,1128 ****
                  2 class-allot ;
  
! : int           ( -<name>- )              \ W32F          Class
  \ *G Long integer (32bit) instance variable. When used as an object variable has the same
  \ ** behaviour as VALUEs.
--- 1124,1128 ----
                  2 class-allot ;
  
! : int           ( -"name"- )              \ W32F          Class
  \ *G Long integer (32bit) instance variable. When used as an object variable has the same
  \ ** behaviour as VALUEs.
***************
*** 1135,1139 ****
                  cell class-allot ;
  
! : dint          ( -<name>- )              \ W32F          Class
  \ *G Double (64bit) instance variable.
                  header
--- 1135,1139 ----
                  cell class-allot ;
  
! : dint          ( -"name"- )              \ W32F          Class
  \ *G Double (64bit) instance variable.
                  header
***************
*** 1213,1217 ****
   THROW_INDEX_OFR throw ;
  
! \ : int-array    ( size -<name>- )
  \                header
  \                (iv[]@) ,
--- 1213,1217 ----
   THROW_INDEX_OFR throw ;
  
! \ : int-array    ( size -"name"- )
  \                header
  \                (iv[]@) ,

Index: Window.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Window.f,v
retrieving revision 1.27
retrieving revision 1.28
diff -C2 -d -r1.27 -r1.28
*** Window.f	9 Jun 2012 18:45:47 -0000	1.27
--- Window.f	14 Feb 2013 20:05:48 -0000	1.28
***************
*** 454,463 ****
  :M SetParent:   ( hWndParent -- )
  \ *G Set handle of the owner window (0 if no parent).
! \ *P NOTE: This method is depreacted. Use SetParentWindow: instead.
                  to hWndParent ;M DEPRECATED
  
  :M ParentWindow: ( -- hWndParent )
  \ *G Get the handle of the owner window (0 if no parent).
! \ *P NOTE: This method is depreacted. Use GetParentWindow: instead.
                  hWndParent ;M DEPRECATED
  
--- 454,463 ----
  :M SetParent:   ( hWndParent -- )
  \ *G Set handle of the owner window (0 if no parent).
! \ *P NOTE: This method is deprecated. Use SetParentWindow: instead.
                  to hWndParent ;M DEPRECATED
  
  :M ParentWindow: ( -- hWndParent )
  \ *G Get the handle of the owner window (0 if no parent).
! \ *P NOTE: This method is deprecated. Use GetParentWindow: instead.
                  hWndParent ;M DEPRECATED
  

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.54
retrieving revision 1.55
diff -C2 -d -r1.54 -r1.55
*** Primutil.f	3 Mar 2012 09:15:14 -0000	1.54
--- Primutil.f	14 Feb 2013 20:05:48 -0000	1.55
***************
*** 616,620 ****
  
  : IN-SYS-SPACE?   ( addr -- flag )
!                 SYS-ORIGIN SYS-HERE WITHIN SYS-SIZE AND ;
  
  : IN-CODE-SPACE?   ( addr -- flag )
--- 616,620 ----
  
  : IN-SYS-SPACE?   ( addr -- flag )
!                 SYS-ORIGIN SYS-HERE WITHIN SYS-SIZE AND 0<> ;
  
  : IN-CODE-SPACE?   ( addr -- flag )
***************
*** 827,831 ****
  : MessageLoop ( -- )
  \ This word launches a message loop. It will exit only when receiving a
! \ WM_QUIT message. Used with programms TURNKEYed without console.
                  BEGIN  0 0 0 MessageStructure  Call GetMessage
                  WHILE  MessageStructure  HandleMessages drop
--- 827,831 ----
  : MessageLoop ( -- )
  \ This word launches a message loop. It will exit only when receiving a
! \ WM_QUIT message. Used with programs TURNKEYed without console.
                  BEGIN  0 0 0 MessageStructure  Call GetMessage
                  WHILE  MessageStructure  HandleMessages drop

Index: Menu.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Menu.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** Menu.f	26 Jun 2010 08:24:15 -0000	1.8
--- Menu.f	14 Feb 2013 20:05:48 -0000	1.9
***************
*** 435,444 ****
                  ;
  
  in-application
  
  \in-system-ok :M ClassInit: (ClassInit) ;M
  
- : m"text"       ( -<"text">- )
-                 here to mtext ,"text" ;
  
  :M Check:       ( f1 -- )
--- 435,445 ----
                  ;
  
+ : m"text"       ( -<"text">- )
+                 here to mtext ,"text" ;
+ 
  in-application
  
  \in-system-ok :M ClassInit: (ClassInit) ;M
  
  
  :M Check:       ( f1 -- )

Index: CLASSDBG.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/CLASSDBG.F,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** CLASSDBG.F	16 Apr 2007 08:29:06 -0000	1.10
--- CLASSDBG.F	14 Feb 2013 20:05:47 -0000	1.11
***************
*** 82,88 ****
  
  
! : matches   ( -<name>- )                 \ W32F      Class debug
  \ *G Print out all the method selectors and IVAR names that have the same hash value as
! \ ** -<name>- will be assigned. If -<name>- is already in use as a selector or an IVAR name
  \ ** then it will appear in the list.
              bl word count "matches ;
--- 82,88 ----
  
  
! : matches   ( -"name"- )                 \ W32F      Class debug
  \ *G Print out all the method selectors and IVAR names that have the same hash value as
! \ ** -"name"- will be assigned. If -"name"- is already in use as a selector or an IVAR name
  \ ** then it will appear in the list.
              bl word count "matches ;

[Win32forth-cvs] win32forth/src Boot.f,1.6,1.7

[George H. <geo...@us...>]

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

Modified Files:
	Boot.f 
Log Message:
Tidy up of boot code (NEEDS new Fkernel.exe to build).

Index: Boot.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Boot.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Boot.f	22 Dec 2008 11:04:52 -0000	1.6
--- Boot.f	14 Feb 2013 19:25:19 -0000	1.7
***************
*** 50,60 ****
                  config$ LoadConfigFile
  
!                 &EXCEPT @ 0= sys-size and
!                 IF      CMDLINE ['] EVALUATE CATCH DUP
!                         IF      DUP 1+ IF MESSAGE THEN
!                         THEN
!                 THEN
! 
!                 RESET-STACKS
  
!                 QUIT ;
--- 50,54 ----
                  config$ LoadConfigFile
  
!                 Start-Interpreter ;
  
! in-previous

[Win32forth-cvs] win32forth/Help/html w32f-HelpConventions.htm, 1.2, 1.3 w32f-MoveTo.6.14.htm, 1.4, 1.5 w32f-chains.htm, 1.1, 1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/Help/html
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv31140

Modified Files:
	w32f-HelpConventions.htm w32f-MoveTo.6.14.htm w32f-chains.htm 
Log Message:
Updated docs

Index: w32f-MoveTo.6.14.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/w32f-MoveTo.6.14.htm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** w32f-MoveTo.6.14.htm	3 Mar 2012 09:15:14 -0000	1.4
--- w32f-MoveTo.6.14.htm	14 Feb 2013 19:07:42 -0000	1.5
***************
*** 26,30 ****
  
  <ul>
!   <li><b>Steep change </b><a href='#savewords'>Saving programms</a></li>
    <li><b>Steep change </b><a href='#w32fmsg'>Win32Forth messaging</a></li>
    <li><b>Soft change </b><a href='#deprecated'>Deprecated words</a></li>
--- 26,30 ----
  
  <ul>
!   <li><b>Steep change </b><a href='#savewords'>Saving programs</a></li>
    <li><b>Steep change </b><a href='#w32fmsg'>Win32Forth messaging</a></li>
    <li><b>Soft change </b><a href='#deprecated'>Deprecated words</a></li>
***************
*** 33,37 ****
  
  
! <a name='savewords'><h3>Saving programms</h3></a>
  
  <p>The words <code>APPLICATION</code> and <code>FSAVE</code> have been removed
--- 33,37 ----
  
  
! <a name='savewords'><h3>Saving programs</h3></a>
  
  <p>The words <code>APPLICATION</code> and <code>FSAVE</code> have been removed
***************
*** 42,46 ****
  before a save, particularly <code>DEFAULT-HELLO</code> which is too close to
  the sytem and easily handle the inclusion of a console and/or message loop
! in the saved programm.</p>
  
  <p>You can have further details about new <code>SAVE</code> and
--- 42,46 ----
  before a save, particularly <code>DEFAULT-HELLO</code> which is too close to
  the sytem and easily handle the inclusion of a console and/or message loop
! in the saved program.</p>
  
  <p>You can have further details about new <code>SAVE</code> and
***************
*** 54,58 ****
  
  <p>If you had any application specific initializations in your own definitions
! for BOOT or DEFAULT-HELLO , move them in your programm's main word.  Delete the
  words you were using as BOOT and DEFAULT-HELLO .</p>
  
--- 54,58 ----
  
  <p>If you had any application specific initializations in your own definitions
! for BOOT or DEFAULT-HELLO , move them in your program's main word.  Delete the
  words you were using as BOOT and DEFAULT-HELLO .</p>
  
***************
*** 61,69 ****
  
  <p>Suppress any use of <code>MessageLoop</code> (and words that you could get
! undefined such as <code>NoConsole></code>) in your programm.</p>
  
  <p><br>Then :<br></p>
  
! <p>Replace FSAVE and APPLICATION with SAVE : don't forget to give your programm's
  main word as the application cfa of SAVE . <br>(TURNKEY remains the same)</p>
  
--- 61,69 ----
  
  <p>Suppress any use of <code>MessageLoop</code> (and words that you could get
! undefined such as <code>NoConsole></code>) in your program.</p>
  
  <p><br>Then :<br></p>
  
! <p>Replace FSAVE and APPLICATION with SAVE : don't forget to give your program's
  main word as the application cfa of SAVE . <br>(TURNKEY remains the same)</p>
  
***************
*** 73,77 ****
  remove any reference to :</p>
  <pre>     NoConsole NoConsoleInImage</pre>
! <p>and remove from your programm's main word:</p>
  <pre>     Turnkeyed? if MessageLoop Bye then</pre>
  
--- 73,77 ----
  remove any reference to :</p>
  <pre>     NoConsole NoConsoleInImage</pre>
! <p>and remove from your program's main word:</p>
  <pre>     Turnkeyed? if MessageLoop Bye then</pre>
  
***************
*** 85,89 ****
  <pre>     ConsoleHiddenBoot</pre>
  <p>before your SAVE or TURNKEY command and do whatever further console
! initialization in your programm's main word.</p>
  
  
--- 85,89 ----
  <pre>     ConsoleHiddenBoot</pre>
  <p>before your SAVE or TURNKEY command and do whatever further console
! initialization in your program's main word.</p>
  
  

Index: w32f-chains.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/w32f-chains.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** w32f-chains.htm	15 May 2008 06:28:27 -0000	1.1
--- w32f-chains.htm	14 Feb 2013 19:07:42 -0000	1.2
***************
*** 105,109 ****
        <td>initialization-chain</td>
        <td>chain of things to initialize</td>
!       <td>HELLO DEFAULT-HELLO</td>
      </tr>
      <tr>
--- 105,109 ----
        <td>initialization-chain</td>
        <td>chain of things to initialize</td>
!       <td>GENERALBOOT</td>
      </tr>
      <tr>
***************
*** 123,131 ****
      </tr>
      <tr>
-       <td>mouse-chain</td>
-       <td>chain of things to do on mouse down</td>
-       <td>MOUSE-CLICK</td>
-     </tr>
-     <tr>
        <td>semicolon-chain</td>
        <td>chain of things to do at end of definition</td>
--- 123,126 ----
***************
*** 143,165 ****
      </tr>
      <tr>
-       <td>ledit-chain</td>
-       <td>line editor function key chain</td>
-       <td>LINEEDITOR</td>
-     </tr>
-     <tr>
        <td>msg-chain</td>
!       <td>chain of forth key messages</td>
        <td>HandleMessages</td>
      </tr>
      <tr>
-       <td>forth-msg-chain</td>
-       <td>chain of forth window message</td>
-       <td>HandleWindowsMessages</td>
-     </tr>
-     <tr>
        <td>reset-stack-chain</td>
        <td>chain for resetting the stack</td>
        <td>RESET-STACKS</td>
      </tr>
    </tbody>
  </table>
--- 138,155 ----
      </tr>
      <tr>
        <td>msg-chain</td>
!       <td>chain of handlers for Windows messages</td>
        <td>HandleMessages</td>
      </tr>
      <tr>
        <td>reset-stack-chain</td>
        <td>chain for resetting the stack</td>
        <td>RESET-STACKS</td>
      </tr>
+     <tr>
+       <td>pre-save-image-chain</td>
+       <td>chain of things to do to the new image prior to saving</td>
+       <td>IMAGE-COPY</td>
+     </tr>
    </tbody>
  </table>
***************
*** 187,191 ****
      </tr>
      <tr>
!       <td>word-type-chain</td>
        <td></td>
        <td>.WORDTYPE</td>
--- 177,181 ----
      </tr>
      <tr>
!       <td>.word-type-chain</td>
        <td></td>
        <td>.WORDTYPE</td>
***************
*** 207,221 ****
    <tbody>
      <tr>
!       <td>execution-class-chain</td>
        <td></td>
        <td>.EXECUTION-CLASS</td>
      </tr>
      <tr>
!       <td>other-class-chain</td>
        <td></td>
        <td>.OTHER</td>
      </tr>
      <tr>
!       <td>word-chain</td>
        <td></td>
        <td>.WORD</td>
--- 197,211 ----
    <tbody>
      <tr>
!       <td>.execution-class-chain</td>
        <td></td>
        <td>.EXECUTION-CLASS</td>
      </tr>
      <tr>
!       <td>.other-class-chain</td>
        <td></td>
        <td>.OTHER</td>
      </tr>
      <tr>
!       <td>.word-chain</td>
        <td></td>
        <td>.WORD</td>
***************
*** 226,230 ****
  <hr>
  
! <p>Document : w32f-chains.htm -- 2004/12/21 -- alex_mcdonald</p>
  
  </body>
--- 216,220 ----
  <hr>
  
! <p>Document $Id$</p>
  
  </body>

Index: w32f-HelpConventions.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/w32f-HelpConventions.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** w32f-HelpConventions.htm	28 May 2008 04:01:07 -0000	1.2
--- w32f-HelpConventions.htm	14 Feb 2013 19:07:42 -0000	1.3
***************
*** 79,86 ****
    </thead>
    <tbody>
!     </tr>
      <td>&lt;name&gt</td>
      <td>name to be parsed from input stream</td>
!     <td><code>VARIABLE \ Comp: ( &lt;name&gt; -- ) Run name: ( -- addr )</code></td>
      </tr>
      <tr>
--- 79,91 ----
    </thead>
    <tbody>
!     <tr>
      <td>&lt;name&gt</td>
      <td>name to be parsed from input stream</td>
!     <td><code>VARIABLE \ Comp: ( &lt;name&gt; -- ) Run time: ( -- addr )</code></td>
!     </tr>
!     <tr>
!     <td>&quot;name&quot</td>
!     <td>name to be parsed from input stream</td>
!     <td><code>VALUE \ Comp: ( &quot;name&quot; -- ) Run time: ( -- addr )</code></td>
      </tr>
      <tr>
***************
*** 101,106 ****
      <tr>
      <td>addr cnt</td>
!     <td>addr and lenght of a string</td>
!     <td><code>TYPE ( addr count -- )</code></td>
      </tr>
      <tr>
--- 106,137 ----
      <tr>
      <td>addr cnt</td>
!     <td>addr and length of a string</td>
!     <td><code>TYPE ( addr cnt -- )</code></td>
!     </tr>
!     <tr>
!     <td>addr len</td>
!     <td>addr and length of a string</td>
!     <td><code>TYPE ( addr len -- )</code></td>
!     </tr>
!     <tr>
!     <td>addr u</td>
!     <td>addr and length of a string</td>
!     <td><code>TYPE ( addr u -- )</code></td>
!     </tr>
!     </tr>
!     <tr>
!     <td>c-addr cnt</td>
!     <td>addr and length of a string</td>
!     <td><code>TYPE ( c-addr cnt -- )</code></td>
!     </tr>
!     <tr>
!     <td>c-addr len</td>
!     <td>c-addr and length of a string</td>
!     <td><code>TYPE ( c-addr len -- )</code></td>
!     </tr>
!     <tr>
!     <td>c-addr u</td>
!     <td>c-addr and length of a string</td>
!     <td><code>TYPE ( c-addr u -- )</code></td>
      </tr>
      <tr>
***************
*** 127,131 ****
      <td>r or f</td>
      <td>real or floating point number</td>
!     <td></td>
      </tr>
      <tr>
--- 158,162 ----
      <td>r or f</td>
      <td>real or floating point number</td>
!     <td><code>F+         ( fs: r1 r2 -- r3 )</code></td>
      </tr>
      <tr>
***************
*** 146,150 ****
      <tr>
      <td>???-sys</td>
!     <td>parameter used by Forth system</td>
      <td><code>LEAVE ( -- ) ( R: loop-sys -- )</code></td>
      </tr>
--- 177,181 ----
      <tr>
      <td>???-sys</td>
!     <td>parameters used by Forth system</td>
      <td><code>LEAVE ( -- ) ( R: loop-sys -- )</code></td>
      </tr>

[Win32forth-cvs] win32forth/src/console CommandWindow.f,1.30,1.31

[Rod O. <rod...@us...>]

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

Modified Files:
	CommandWindow.f 
Log Message:
Rod:  a character was lost when the text wraps at the edge of the console window.  Fixed.

Index: CommandWindow.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/CommandWindow.f,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -d -r1.30 -r1.31
*** CommandWindow.f	17 Jan 2012 19:50:41 -0000	1.30
--- CommandWindow.f	24 Dec 2012 16:16:45 -0000	1.31
***************
*** 776,784 ****
  : AdjustCount ( n -- n )   wrap IF  wrap 0< IF  VisibleCols: self  ELSE  wrap  THEN  X - min 0 max  THEN ;
  
! :M OverwriteTextAtXY: ( a n -- )
!         dup CheckTextBuffer   \ one line at a time
!         BEGIN 10 skip dup>r  2dup 2dup 13 scan nip -  AdjustCount
!         dup>r  OverwriteLineAtXY: self  r@ 2r> -   \ chars inserted, chars remaining
!         WHILE  CR: self  /string  1 /string
          REPEAT  3drop
          SCP
--- 776,784 ----
  : AdjustCount ( n -- n )   wrap IF  wrap 0< IF  VisibleCols: self  ELSE  wrap  THEN  X - min 0 max  THEN ;
  
! :M OverwriteTextAtXY: ( a n -- )   \ one line at a time
!         dup CheckTextBuffer
!         BEGIN  10 skip  dup>r  2dup 2dup 13 scan nip -  AdjustCount
!             dup>r  OverwriteLineAtXY: self  r@ 2r> -   \ chars inserted, chars remaining
!         WHILE  CR: self  /string  13 skip
          REPEAT  3drop
          SCP

[Win32forth-cvs] win32forth/src/lib MultiTaskingClass.f,1.1,1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory vz-cvs-4.sog:/tmp/cvs-serv5472

Modified Files:
	MultiTaskingClass.f 
Log Message:
Jos Added the classes LockObject and sTask and a lock-demo.

Index: MultiTaskingClass.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/MultiTaskingClass.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** MultiTaskingClass.f	6 Jun 2012 14:40:51 -0000	1.1
--- MultiTaskingClass.f	23 Sep 2012 13:45:15 -0000	1.2
***************
*** 1,4 ****
! anew MultiTaskingClass.f   \ June 4th, 2012, for XP or better. See the demos at the end for its use.
! 
  
  \ *D doc\classes\
--- 1,3 ----
! anew MultiTaskingClass.f   \ For XP or better. See the demos at the end for its use.
  
  \ *D doc\classes\
***************
*** 13,22 ****
  \ ** Breaking up is possible at the definition level or at the program level by the 2 classes \biTask\d and \bwTask\d. \n
  \ ** Then the pieces are submitted and simultaneously executed in a number of tasks. \n
! \ ** The tasks are clustered in an object for easy access.
  
  \ *P Objects defined with \biTask\d can be used as soon as ONE definition should be executed in a parallel way
  \ ** and the definition uses a do...loop. \n
! \ ** The method \iParallel:\d divides, distributes and submits for execution the specified cfa over a number of tasks. \n
! \ ** \iParallel:\d takes in account the number of hardware threads, so all these threads wil be used during execution. \n
  \ ** A started task can pickup its range for the do...loop part by using the method \iGetTaskRange:\d \n
  \ ** The initialization of the objects defined with iTask is automatic. \n
--- 12,20 ----
  \ ** Breaking up is possible at the definition level or at the program level by the 2 classes \biTask\d and \bwTask\d. \n
  \ ** Then the pieces are submitted and simultaneously executed in a number of tasks. \n
! \ ** Tasks are clustered in an object for easy access.
  
  \ *P Objects defined with \biTask\d can be used as soon as ONE definition should be executed in a parallel way
  \ ** and the definition uses a do...loop. \n
! \ ** The method \iParallel:\d  divides, distributes and submits for execution the specified cfa over a number of tasks. \n
  \ ** A started task can pickup its range for the do...loop part by using the method \iGetTaskRange:\d \n
  \ ** The initialization of the objects defined with iTask is automatic. \n
***************
*** 43,48 ****
  \ 07-03-2012 Added Putrange: GetTaskRange: SubmitTasks: UseOneThreadOnly:
  \                  UseALLThreads: and &Timers for each task in the object iTask
! \ 04-06-2012 Moved the task-block out of the dictionary for the taskobjects and
! \            added cells+@ cells+! #ActiveTasks: and the waitobject wTask including a demo for wTask.
  \            Removed the tasks in a chain. The object wTask does this better and easier.
  \            ExitTask is now handled by the objects. Remove ExitTask from your code when it is still there.
--- 41,48 ----
  \ 07-03-2012 Added Putrange: GetTaskRange: SubmitTasks: UseOneThreadOnly:
  \                  UseALLThreads: and &Timers for each task in the object iTask
! \ 29-05-2012 Moved the task-block out of the dictionary for the taskobjects and
! \            added cells+@ cells+! waitobject wTask and a demo for wTask.
! \            A wTask allows you to submit one or more words as a task by passing its CFA
! \            to the task object.
  \            Removed the tasks in a chain. The object wTask does this better and easier.
  \            ExitTask is now handled by the objects. Remove ExitTask from your code when it is still there.
***************
*** 52,55 ****
--- 52,58 ----
  \            in a submitted task without having to change the submitted definition.
  \            Renamed MultiTask.f to MultiTaskingClass.f
+ \ 23-9-2012  Added a lock-demo and the classes LockObject and sTask.
+ \            The methods SubmitTask: and Parallel: are now protected by a lock to prevent a crash when they
+ \            are used by a re-entry at the same time.
  
  
***************
*** 64,67 ****
--- 67,71 ----
  
  
+ winver winxp < [if] cr cr .( MultiTaskingClass.f needs at least Windows XP.) cr abort [then]
  
  needs task.f
***************
*** 146,151 ****
  \ : test 10 0 #do . ; cr  see test cr test abort
  
  
! :Class WaitObject    <Super Object
  \ *G Handles the waiting of one or more handles.
  
--- 150,223 ----
  \ : test 10 0 #do . ; cr  see test cr test abort
  
+ : .cr ( n - ) . cr ;
  
! 
! :Class LockObject    <Super Object
! \ *G To excute words that are not allowed to run simultaneously by several tasks.
! \ ** The Initialization is automatic.
! 
! Record: critical_section
!     int  LockCount
!     int  RecursionCount
!     int  OwningThread
!     int  LockSemaphore
!     int  SpinCount
! ;Record
! 
! 
! :M .Lock:          ( -- )
!  cr .time ."  Lock:" cr
!     ." IDLockCount: "    LockCount      .cr \ thread ID that owns this critical section.
!     ." RecursionCount: " RecursionCount .cr \ the number of times that the owning thread has acquired this critical section
!     ." OwningThread: "   OwningThread   .cr \ identifier for the thread that currently holds the critical section
!     ." LockSemaphore: "  LockSemaphore  .cr \ handle used to signal the operating system that the critical section is now free
!     ." SpinCount: "      SpinCount      .cr \ the spin count for the critical section object. Might be 0, but must be allocated
!  ;M
! 
! :M TryLock:       ( -- fl )
! \ *G Attempts to enter a critical section without blocking. If the call is successful,
! \ ** the calling thread takes ownership of the critical section
! \ ** increments the lock count and return true. \n
!     critical_section  call TryEnterCriticalSection 0<> ;M
! 
! :M Lock:          ( -- )
! \ *G If another thread owns the lock wait until it's free,
! \ ** then if the lock is free claim it for this thread,
! \ ** then increment the lock count.
!     critical_section call EnterCriticalSection drop 1 ms \ 1 ms is needed for a proper lock.
!  ;M                                                      \ Do not use WaitForSingleObject here
! 
! :M Unlock:        ( -- )
! \ *G Decrement the lock count and free the lock if the resultant count is zero.
!    critical_section call LeaveCriticalSection drop
!  ;M
! 
! :M MakeLock:   ( -- )
! \ *G Initialize the criticalSection. Is an automatic operation.
!     0 critical_section call InitializeCriticalSectionAndSpinCount drop  \ Needs XP or better
!   ;M
! 
! :M LockExecute: ( cfa - )
! \ *G Locks, executes and unlocks the specified cfa.
! \ ** When more than 1 task try to use LockExecute: of the same object
! \ ** the next task will be executed after the previous task is ready.
!     Lock: Self   execute    UnLock: Self ;M
! 
! :M DeleteLock: ( -- )
! \ *G deletes the critical section.
!    critical_section call DeleteCriticalSection drop
!   ;M
! 
! :M ClassInit:  ( -- )
! \ *G Initializes the object.
!     ClassInit: Super
!     MakeLock: Self
!   ;M
! 
! ;Class
! 
! 
! 
! :Class WaitObject    <Super LockObject
  \ *G Handles the waiting of one or more handles.
  
***************
*** 189,192 ****
--- 261,265 ----
    ;M
  
+ 
  ;Class
  
***************
*** 211,215 ****
  \ *| &StkParams | -- An array in the user area to pass parameters to a task.           |
  
- 
  :Class TaskPrimitives    <Super WaitObject
  \ *G Contains the general definitions for a task object.
--- 284,287 ----
***************
*** 618,622 ****
  \ ** The debugger can not be used in a task. \n
  \ ** See Single: for debugging.
!      -rot SetParallelItems: Self StartTasks: Self
    ;M
  
--- 690,696 ----
  \ ** The debugger can not be used in a task. \n
  \ ** See Single: for debugging.
!    Lock: Self           \ To prevent a crash when multiple tasks try to use Parallel a task at the same time
!    -rot SetParallelItems: Self StartTasks: Self
!    UnLock: Self
    ;M
  
***************
*** 641,644 ****
--- 715,719 ----
  
  
+ 
  :Class wTasks    <Super TaskPrimitives
  \ *G To run a number of tasks concurrently that can not be indexed. \n
***************
*** 661,664 ****
--- 736,740 ----
  int Specified#Tasks \ internal use
  
+ 
  :M MallocTasksArrays: ( -- )
      &Taskblocks 0=      \ Only executed when not done or when ReleaseTasksArrays: is executed
***************
*** 697,701 ****
      dup  WAIT_FAILED = if getlastwinerr then \ note the error
      WAIT_OBJECT_0 +                       \ ( event - cfa IDindex )
!     dup>r UseTaskBlockAgain r@ CreateTask \ Create a suspended new task in the same taskblock
      r@ SaveWaitHandle                     \ Save the waithandle in the free position
      r> ResumeTask: Self                   \ Run the new task
--- 773,777 ----
      dup  WAIT_FAILED = if getlastwinerr then \ note the error
      WAIT_OBJECT_0 +                       \ ( event - cfa IDindex )
!     dup>r UseTaskBlockAgain r@ CreateTask \ Create a suspended new task in the same free taskblock
      r@ SaveWaitHandle                     \ Save the waithandle in the free position
      r> ResumeTask: Self                   \ Run the new task
***************
*** 718,722 ****
    ;M
  
! : AddOneTask ( cfa -- )
  \ *G Submits the specified cfa in a new task and returns.
      #wait-hndls   dup>r                      \ ( cfa - cfa IDindex )
--- 794,798 ----
    ;M
  
! :M AddOneTask: ( cfa -- )
  \ *G Submits the specified cfa in a new task and returns.
      #wait-hndls   dup>r                      \ ( cfa - cfa IDindex )
***************
*** 724,738 ****
      r@ CreateTask r@  SaveWaitHandle  r> ResumeTask: Self
      1 +to #wait-hndls
!  ;
  
  :M SubmitTask: ( cfa -- )
  \ *G Submits the specified cfa in a new task and return after that task could be submitted.
!     #Tasks  #wait-hndls  <=           \ When there is no hardware thread free anymore, then
!         if    WaitForOnetask: Self    \ wait for one task, create a new thread and use the same task-block again.
!         else  AddOneTask              \ Add a new thread and run.
          then
    ;M
  
- 
  :M Execute: ( cfa -- )
  \ *G Executes the definition of the specified cfa in the main task.  \n
--- 800,815 ----
      r@ CreateTask r@  SaveWaitHandle  r> ResumeTask: Self
      1 +to #wait-hndls
!  ;M
  
  :M SubmitTask: ( cfa -- )
  \ *G Submits the specified cfa in a new task and return after that task could be submitted.
!    Lock: Self                         \ To prevent a crash when multiple tasks try to submit a task at the same time
!     #Tasks  #wait-hndls <=            \ When there is no hardware thread free anymore, then
!         if    WaitForOnetask: Self    \ wait for one task, create a new thread and use the same free task-block again.
!         else  AddOneTask: Self        \ Add a new thread and run.
          then
+     unLock: Self
    ;M
  
  :M Execute: ( cfa -- )
  \ *G Executes the definition of the specified cfa in the main task.  \n
***************
*** 769,773 ****
  
  
!   (( \  Disable or delete this line for a demo of indexed tasks in an OBJECT
  
  0e fvalue ft0
--- 846,872 ----
  
  
! :Class sTask    <Super wTasks
! \ *G Nearly the same as wTasks
! \ ** Differences:
! \ ** 1.) It will only use 1 task concurrently.
! \ ** 2.) The initialization of the objects defined with sTask is automatic.
! 
! :M SubmitTask: ( cfa -- )
!    Lock: Self                    \ Prevent multiple tasks running the same cfa at the same time.
!    &Taskblocks 0=
!      if  1 Start: Super          \ Using ONE task only.
!      then
!    #Tasks  #wait-hndls  <=       \ When there is no hardware thread free anymore, then
!      if    WaitForOnetask: Self  \ wait for one task, create a new thread and use the same free task-block again.
!      else  AddOneTask: Self      \ Add a new thread and run.
!      then
!    UnLock: Self
!   ;M
! 
! ;Class
! 
! \ --- Demo and test section ---
! 
!  ((   \  Disable or delete this line for a demo of indexed tasks in an OBJECT
  
  0e fvalue ft0
***************
*** 782,785 ****
--- 881,885 ----
  value-ft0 ft0 f>s 3 * value #counts    \ To get a runtime for about 8 - 20 seconds
  
+ 
   iTasks myTasks
  
***************
*** 864,870 ****
    ;
  
- 
  range-test abort \ ))
  
    (( \ Disable or delete this line for the SubmitTest.
  \ Made to test and to prove that the use of more tasks can be faster.
--- 964,970 ----
    ;
  
  range-test abort \ ))
  
+ 
    (( \ Disable or delete this line for the SubmitTest.
  \ Made to test and to prove that the use of more tasks can be faster.
***************
*** 944,948 ****
   SubmitTest  ExecuteTest abort \s ))
  
- 
  (( On my iCore7:
  
--- 1044,1047 ----
***************
*** 962,968 ****
  Total counted: 500.000E6
  counts / second: 204.666E6
! Using Execute: ( No threads at all )
  
-  ))
  \s
  \ *Z
--- 1061,1111 ----
  Total counted: 500.000E6
  counts / second: 204.666E6
! Using Execute: ( No threads at all )  ))
! 
! 
! 
!   (( \ Disable or delete this line for the LockTest.
! 
! 0e fvalue ft0
! 
! : value-ft0
!     ms@ 0e fto ft0
!        begin  200e ft0 f+ fto ft0
!               ms@ over 400 + >
!        until drop  ;
! 
! TIMER-RESET
! value-ft0 ft0 f>s  value #counts    \ To get a runtime for about 2 seconds
! 
! 
! sTask SeqTask
! iTasks ParallelTasks
! 
! : ProtectedWord ( - )              \ Increments a value at PAD
!   TIMER-RESET
!     Below  0 pad !   #counts  0
!       do   1 pad +!
!       loop
!   cr GetTaskParam . .ELAPSED       \ show task ID and the elapsed time
!   ;
! 
! : Parallel-tasks ( - )             \ Increments a value at PAD parallel in a number of tasks.
!    Below  0 pad !   20 0
!       do   1 pad +!
!       loop  beep                           \ They will be ready at nearly the same time.
!    ['] ProtectedWord LockExecute: SeqTask  \ LockExecute: takes care for executing the ProtectedWord
!  ;                                         \ one by one and not all simultaneously.
! \ Note: When SubmitTask: SeqTask is used in stead of LockExecute: SeqTask
! \ the execution will be in a new task using only ONE task at the time.
! 
! : TestLock
!   cr cr ." ID task with their elapsed time."
!   17 0  ['] Parallel-tasks  Parallel: ParallelTasks
!  ;
! 
! 
! TestLock abort \s ))
! 
  
  \s
  \ *Z

[Win32forth-cvs] win32forth/src paths.f,1.38,1.39

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory vz-cvs-4.sog:/tmp/cvs-serv6125

Modified Files:
	paths.f 
Log Message:
Jos: Now it handles also the case when $current-dir! fails

Index: paths.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/paths.f,v
retrieving revision 1.38
retrieving revision 1.39
diff -C2 -d -r1.38 -r1.39
*** paths.f	20 Aug 2011 16:05:27 -0000	1.38
--- paths.f	19 Sep 2012 15:27:08 -0000	1.39
***************
*** 136,140 ****
  
  EXTERNAL
- 
  : full-path     { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 }
  \ *G Find the file \i a1,n1 \d in the path \i path \d and return the full path.
--- 136,139 ----
***************
*** 169,172 ****
--- 168,172 ----
                                   else true \ try next path...
                                   then
+                             else true \ $current-dir! failed. try next path...
                              then
                         else nip

[Win32forth-cvs] win32forth/Help/html class-controls.htm,1.3,1.4

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/Help/html
In directory vz-cvs-4.sog:/tmp/cvs-serv17875

Modified Files:
	class-controls.htm 
Log Message:
Updated docs.

Index: class-controls.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/class-controls.htm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** class-controls.htm	18 Nov 2011 14:17:01 -0000	1.3
--- class-controls.htm	14 Aug 2012 14:20:10 -0000	1.4
***************
*** 473,479 ****
  </p><p><b><code>:M SetSelection: ( n -- )
  </code></b><br>Select a string in the list of a combo box.
  </p><p><b><code>:M GetSelectedString: ( -- addr cnt )
! </code></b><br>Get the selected from the combo box.
! Note: The string is returned in the global <i>&nbsp;NEW$ </i>.
  </p><p><b><code>:M Setfont: &nbsp;&nbsp;&nbsp;&nbsp;( handle -- )
  </code></b><br>Set the font in the control.
--- 473,488 ----
  </p><p><b><code>:M SetSelection: ( n -- )
  </code></b><br>Select a string in the list of a combo box.
+ </p><p><b><code>:M GetSelection: ( -- n )
+ </code></b><br>Retrieve the index of the currently selected item, if any.
+ </p><p>The return value is the zero-based index of the currently selected item. If there is no
+ selection, the return value is CB_ERR.
+ </p><p><b><code>:M GetString: &nbsp;&nbsp;&nbsp;( index -- addr n )
+ </code></b><br>Retrieve a string from the combo box.
+ </p><p>The return value is the address and length of the string.
+ If <i>&nbsp;n </i>&nbsp;does not specify a valid index, the length is CB_ERR.
  </p><p><b><code>:M GetSelectedString: ( -- addr cnt )
! </code></b><br>Retrieve the currently selected string from the combo box.
! Note: The string is returned in a dynamicly allocated buffer of medium persistance. If a
! permenant copy is needed it should be moved.
  </p><p><b><code>:M Setfont: &nbsp;&nbsp;&nbsp;&nbsp;( handle -- )
  </code></b><br>Set the font in the control.
***************
*** 600,608 ****
  </p><p><b><code>:M GetString: &nbsp;&nbsp;&nbsp;( index -- addr n )
  </code></b><br>Retrieve a string from the list box.
! </p><p>The return value is the length of the string, in chars, excluding the terminating null character.
! If <i>&nbsp;n </i>&nbsp;does not specify a valid index, the return value is LB_ERR.
  </p><p><b><code>:M GetSelectedString: ( -- addr cnt )
  </code></b><br>Retrieve the currently selected string from the list box.
! Note: The string is returned in the global <i>&nbsp;NEW$ </i>.
  </p><p><b><code>:M GetCount: &nbsp;&nbsp;&nbsp;( -- n )
  </code></b><br>Retrieve the number of items in the list box.
--- 609,618 ----
  </p><p><b><code>:M GetString: &nbsp;&nbsp;&nbsp;( index -- addr n )
  </code></b><br>Retrieve a string from the list box.
! </p><p>The return value is the address and length of the string.
! If <i>&nbsp;n </i>&nbsp;does not specify a valid index, the length is LB_ERR.
  </p><p><b><code>:M GetSelectedString: ( -- addr cnt )
  </code></b><br>Retrieve the currently selected string from the list box.
! Note: The string is returned in a dynamicly allocated buffer of medium persistance. If a
! permenant copy is needed it should be moved.
  </p><p><b><code>:M GetCount: &nbsp;&nbsp;&nbsp;( -- n )
  </code></b><br>Retrieve the number of items in the list box.

[Win32forth-cvs] win32forth/Help/hdb HelpCls.tv, 1.14, 1.15 HelpWrd.hdb, 1.20, 1.21 HelpWrd.ndx, 1.20, 1.21 HelpWrd.tv, 1.19, 1.20 HelpWrd.txt, 1.20, 1.21

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/Help/hdb
In directory vz-cvs-4.sog:/tmp/cvs-serv17806

Modified Files:
	HelpCls.tv HelpWrd.hdb HelpWrd.ndx HelpWrd.tv HelpWrd.txt 
Log Message:
Updated help files

Index: HelpCls.tv
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpCls.tv,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** HelpCls.tv	26 Feb 2012 20:01:35 -0000	1.14
--- HelpCls.tv	14 Aug 2012 14:18:05 -0000	1.15
***************
*** 1,2291 ****
! 0 tvn| CLASSROOT| tvd| 5530|
  1 tvn| -methods-| tvd| 0|
! -2 tvn| CLASSINIT:| tvd| 5531|
! -2 tvn| ~:| tvd| 5532|
! -2 tvn| ADDR:| tvd| 5533|
! -2 tvn| PRINT:| tvd| 5534|
! 1 tvn| OBJECT| tvd| 5535|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| GET:| tvd| 5536|
! -3 tvn| PUT:| tvd| 5537|
[...4552 lines suppressed...]
! -4 tvn| FIELDNAME:| tvd| 8587|
! -4 tvn| GETINT:| tvd| 8588|
! -4 tvn| GETDOUBLE:| tvd| 8589|
! -4 tvn| GETFLOAT:| tvd| 8590|
! -4 tvn| GETSTR:| tvd| 8591|
! -4 tvn| GETBLOB:| tvd| 8592|
! -4 tvn| ISNULL?:| tvd| 8593|
! -4 tvn| NEXTROW:| tvd| 8594|
! -4 tvn| (BIND):| tvd| 8595|
! -4 tvn| BINDINT:| tvd| 8596|
! -4 tvn| BINDDOUBLE:| tvd| 8597|
! -4 tvn| BINDFLOAT:| tvd| 8598|
! -4 tvn| BINDSTR:| tvd| 8599|
! -4 tvn| BINDBLOB:| tvd| 8600|
! 1 tvn| STRING| tvd| 8607|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| GET:| tvd| 8608|
! -3 tvn| PUT:| tvd| 8609|
! -3 tvn| ADD:| tvd| 8610|
! -3 tvn| APPEND:| tvd| 8611|

Index: HelpWrd.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.txt,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** HelpWrd.txt	3 Mar 2012 09:15:13 -0000	1.20
--- HelpWrd.txt	14 Aug 2012 14:18:05 -0000	1.21
***************
*** 1447,1452 ****
  CREATE USERCONFIG$ 
  BYTES &PS 
- : (CLASSINIT) ( x y width height -- ) 
  : (CLASSINIT) ( -- ) 
  : (CLASSINIT) ( n1 -- ) 
  CONSTANT 1/1 
--- 1447,1452 ----
  CREATE USERCONFIG$ 
  BYTES &PS 
  : (CLASSINIT) ( -- ) 
[...1445 lines suppressed...]
  :M ONWMCOMMAND: ( hwnd msg wparam lparam -- hwnd msg wparam lparam ) 
--- 14635,14638 ----
***************
*** 14745,14751 ****
  INT STYLE 
  : SYSTEM-FIXED-FONT ( -- ) 
- SYNONYM TEMPRECT wrect 
- SYNONYM TEMPRECT wrect 
- SYNONYM TEMPRECT wrect 
  CALLBACK THEWNDPROC 
  INT TRACK-FUNC 
--- 14750,14753 ----
***************
*** 14769,14773 ****
  \ User windows should override the WindowTitle: method to
  \ set the window caption. Default is "Window".
- RECTANGLE WINRECT 
  :M WM_CHAR ( h m w l -- res ) 
  \ normal & control chars
--- 14771,14774 ----

Index: HelpWrd.hdb
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.hdb,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
Binary files /tmp/cvsCkhYz9 and /tmp/cvsPWt8e3 differ

Index: HelpWrd.tv
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.tv,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** HelpWrd.tv	3 Mar 2012 09:15:13 -0000	1.19
--- HelpWrd.tv	14 Aug 2012 14:18:05 -0000	1.20
***************
*** 1,5278 ****
  0 tvn| Words| tvd| 0|
! 1 tvn| CLASSROOT| tvd| 5530|
  2 tvn| -methods-| tvd| 0|
! -3 tvn| CLASSINIT:| tvd| 5531|
! -3 tvn| ~:| tvd| 5532|
! -3 tvn| ADDR:| tvd| 5533|
! -3 tvn| PRINT:| tvd| 5534|
! 2 tvn| OBJECT| tvd| 5535|
  3 tvn| -methods-| tvd| 0|
! -4 tvn| GET:| tvd| 5536|
[...26023 lines suppressed...]
! 2 tvn| \+| tvd| 5345|
! 2 tvn| \-| tvd| 5346|
! 2 tvn| \IN-SYSTEM-OK| tvd| 5351|
! 2 tvn| \S| tvd| 5400|
! 2 tvn| ]MACRO| tvd| 5237|
! 2 tvn| __STDCALL| tvd| 5228|
! 2 tvn| {| tvd| 5423|
! 2 tvn| {:| tvd| 5422|
! 2 tvn| |IF| tvd| 4923|
! 2 tvn| |OF| tvd| 4922|
  1 tvn| Deprecated| tvd| 0|
! 2 tvn| .DIR->FILE-NAME| tvd| 5075|
! 2 tvn| >BOLD| tvd| 4136|
! 2 tvn| >NORM| tvd| 4135|
! 2 tvn| ABS>REL| tvd| 5371|
! 2 tvn| REL>ABS| tvd| 5372|
! 2 tvn| TASK-SLEEP| tvd| 2597|
! 2 tvn| _PRINT-DIR-FILES| tvd| 5073|
  1 tvn| Vocabularies| tvd| 0|
  2 tvn| Application space| tvd| 0|

Index: HelpWrd.ndx
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/hdb/HelpWrd.ndx,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
Binary files /tmp/cvsj4zPH6 and /tmp/cvsFTOW42 differ

[Win32forth-cvs] win32forth/src/lib ListBox.f,1.4,1.5

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory vz-cvs-4.sog:/tmp/cvs-serv17622

Modified Files:
	ListBox.f 
Log Message:
Minor mod

Index: ListBox.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ListBox.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** ListBox.f	14 Aug 2012 13:27:22 -0000	1.4
--- ListBox.f	14 Aug 2012 14:10:09 -0000	1.5
***************
*** 81,85 ****
  \ *P The return value is the address and length of the string.
  \ ** If \i n \d does not specify a valid index, the length is CB_ERR.
!                 new$ dup rot CB_GETTEXT SendMessage:Self  ;M
  
  :M GetSelectedString: ( -- addr cnt )
--- 81,85 ----
  \ *P The return value is the address and length of the string.
  \ ** If \i n \d does not specify a valid index, the length is CB_ERR.
!                 new$ dup rot CB_GETLBTEXT SendMessage:Self  ;M
  
  :M GetSelectedString: ( -- addr cnt )

[Win32forth-cvs] win32forth/src/lib ListBox.f,1.3,1.4

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory vz-cvs-4.sog:/tmp/cvs-serv15927

Modified Files:
	ListBox.f 
Log Message:
Added GetSelction: and GetString: methods to ComboBox control.

Index: ListBox.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ListBox.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** ListBox.f	29 Aug 2006 08:52:25 -0000	1.3
--- ListBox.f	14 Aug 2012 13:27:22 -0000	1.4
***************
*** 71,80 ****
                  0 swap CB_SETCURSEL SendMessage:SelfDrop ;M
  
  :M GetSelectedString: ( -- addr cnt )
! \ *G Get the selected from the combo box.
! \ ** Note: The string is returned in the global \i NEW$ \d.
!                 0 0 CB_GETCURSEL SendMessage:Self
!                 new$ dup rot CB_GETLBTEXT SendMessage:Self
!                 ;M
  
  :M Setfont:     ( handle -- )
--- 71,91 ----
                  0 swap CB_SETCURSEL SendMessage:SelfDrop ;M
  
+ :M GetSelection: ( -- n )
+ \ *G Retrieve the index of the currently selected item, if any.
+ \ *P The return value is the zero-based index of the currently selected item. If there is no
+ \ ** selection, the return value is CB_ERR.
+                 0 0 CB_GETCURSEL SendMessage:Self ;M
+ 
+ :M GetString:    ( index -- addr n )
+ \ *G Retrieve a string from the combo box.
+ \ *P The return value is the address and length of the string.
+ \ ** If \i n \d does not specify a valid index, the length is CB_ERR.
+                 new$ dup rot CB_GETTEXT SendMessage:Self  ;M
+ 
  :M GetSelectedString: ( -- addr cnt )
! \ *G Retrieve the currently selected string from the combo box.
! \ ** Note: The string is returned in a dynamicly allocated buffer of medium persistance. If a
! \ ** permenant copy is needed it should be moved.
!                 GetSelection: self GetString: self ;M
  
  :M Setfont:     ( handle -- )
***************
*** 234,244 ****
  :M GetString:    ( index -- addr n )
  \ *G Retrieve a string from the list box.
! \ *P The return value is the length of the string, in chars, excluding the terminating null character.
! \ ** If \i n \d does not specify a valid index, the return value is LB_ERR.
                  new$ dup rot LB_GETTEXT SendMessage:Self  ;M
  
  :M GetSelectedString: ( -- addr cnt )
  \ *G Retrieve the currently selected string from the list box.
! \ ** Note: The string is returned in the global \i NEW$ \d.
                  GetSelection: self GetString: self ;M
  
--- 245,256 ----
  :M GetString:    ( index -- addr n )
  \ *G Retrieve a string from the list box.
! \ *P The return value is the address and length of the string.
! \ ** If \i n \d does not specify a valid index, the length is LB_ERR.
                  new$ dup rot LB_GETTEXT SendMessage:Self  ;M
  
  :M GetSelectedString: ( -- addr cnt )
  \ *G Retrieve the currently selected string from the list box.
! \ ** Note: The string is returned in a dynamicly allocated buffer of medium persistance. If a
! \ ** permenant copy is needed it should be moved.
                  GetSelection: self GetString: self ;M
  

[Win32forth-cvs] win32forth/Help/html class-Mdi.htm, 1.1, 1.2 class-control.htm, 1.1, 1.2 class-dialog.htm, 1.1, 1.2 class-generic.htm, 1.2, 1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/Help/html
In directory vz-cvs-4.sog:/tmp/cvs-serv14076

Modified Files:
	class-Mdi.htm class-control.htm class-dialog.htm 
	class-generic.htm 
Log Message:
Updated documentation

Index: class-generic.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/class-generic.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** class-generic.htm	3 Mar 2012 09:15:14 -0000	1.2
--- class-generic.htm	18 Jul 2012 12:47:28 -0000	1.3
***************
*** 160,163 ****
--- 160,167 ----
  X Specifies the new position of the left side of the window, in client coordinates. <br />
  Y Specifies the new position of the top of the window, in client coordinates.
+ </p><p><b><code>:M GetWindowRect: ( -- left top right bottom )
+ </code></b><br>The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window.
+ The dimensions are given in screen coordinates that are relative to the upper-left corner
+ of the screen.
  </p><p><b><code>:M SetMenu: &nbsp;&nbsp;&nbsp;&nbsp;( MenuHandle -- )
  </code></b><br>The SetMenu function assigns a new menu to the window.
***************
*** 620,636 ****
  </p><p><b><code>;CLASS
  </code></b><br>End of generic-window class
- </p><a name="DIALOG&CONTROL"></a>
- <h2>Generic class for Dialog- and Control-Window objects.
- </h2><p><b><code>|CLASS DIALOG&amp;CONTROL &lt;SUPER Generic-Window
- </code></b><br>Base class for all dialog and control objects.
- </p><p>Since DIALOG&amp;CONTROL is a generic class it should not be used to create
- any instances.
- </p><p><b><code>:M Classinit: &nbsp;&nbsp;( -- )
- </code></b><br>Initialise the class.
- </p><p><b><code>:M GetWindowRect: ( -- left top right bottom )
- </code></b><br>The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window.
- The dimensions are given in screen coordinates that are relative to the upper-left corner
- of the screen.
- </p><p><b><code>;CLASS
- </code></b><br>End of DIALOG&amp;CONTROL class
  </p></body></html>
--- 624,626 ----

Index: class-control.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/class-control.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** class-control.htm	17 Nov 2011 21:57:09 -0000	1.1
--- class-control.htm	18 Jul 2012 12:47:28 -0000	1.2
***************
*** 12,16 ****
  </h1><a name="Control"></a>
  <h2>Generic Control class
! </h2><p><b><code>:Class Control &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;Super Dialog&amp;Control
  </code></b><br>Generic control class. <br />
  Since Control is a generic class it should not be used to create
--- 12,16 ----
  </h1><a name="Control"></a>
  <h2>Generic Control class
! </h2><p><b><code>:Class Control &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;Super Generic-Window
  </code></b><br>Generic control class. <br />
  Since Control is a generic class it should not be used to create

Index: class-dialog.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/class-dialog.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** class-dialog.htm	17 Nov 2011 21:57:09 -0000	1.1
--- class-dialog.htm	18 Jul 2012 12:47:28 -0000	1.2
***************
*** 56,60 ****
  </p><a name="Dialog"></a>
  <h2>Dialog Class
! </h2><p><b><code>:CLASS Dialog &nbsp;&nbsp;&lt;SUPER Dialog&amp;Control
  </code></b><br>Dialog class. <br />
  To use this class you have to create a ressource file (*.res) which must contain
--- 56,60 ----
  </p><a name="Dialog"></a>
  <h2>Dialog Class
! </h2><p><b><code>:CLASS Dialog &nbsp;&nbsp;&lt;SUPER Generic-Window
  </code></b><br>Dialog class. <br />
  To use this class you have to create a ressource file (*.res) which must contain

Index: class-Mdi.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/Help/html/class-Mdi.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** class-Mdi.htm	17 Nov 2011 21:57:09 -0000	1.1
--- class-Mdi.htm	18 Jul 2012 12:47:28 -0000	1.2
***************
*** 205,212 ****
  \&nbsp;\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! 200 value (NewID)
! : NewID ( &lt;name&gt; -- ) &nbsp;&nbsp;defined
  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;IF &nbsp;drop
! &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ELSE &nbsp;count &quot;header &nbsp;(NewID) &nbsp;dup 1+ to (NewID) &nbsp;DOCON , ,
  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;THEN ;
  
--- 205,212 ----
  \&nbsp;\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! : NewID ( &lt;name&gt; -- )
! &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;defined
  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;IF &nbsp;drop
! &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ELSE NextID swap count ['] constant execute-parsing
  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;THEN ;
  

[Win32forth-cvs] win32forth/demos WINSER.F,1.6,1.7

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/demos
In directory vz-cvs-4.sog:/tmp/cvs-serv13383

Modified Files:
	WINSER.F 
Log Message:
Added comment about use of higher number com ports.

Index: WINSER.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/demos/WINSER.F,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** WINSER.F	15 Feb 2012 19:37:06 -0000	1.6
--- WINSER.F	18 Jul 2012 12:34:27 -0000	1.7
***************
*** 82,86 ****
                  Call SetCommTimeouts drop ;
  
! : ComOpen       ( z1 -- cHndl ) \ Open Com port for z" COM1", or z" COM2"
                  >R
                  NULL                            \ no template
--- 82,87 ----
                  Call SetCommTimeouts drop ;
  
! : ComOpen       ( z1 -- cHndl ) \ Open Com port for z" COM1", or z" COM2" etc. If port is higher than 9 then it
!                 \ must be in the form z" \\.\COM10" to work correctly.
                  >R
                  NULL                            \ no template

[Win32forth-cvs] win32forth/src CONTROL.F, 1.12, 1.13 Dialog.f, 1.6, 1.7 GENERIC.F, 1.26, 1.27 Window.f, 1.26, 1.27

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory vz-cvs-4.sog:/tmp/cvs-serv20140

Modified Files:
	CONTROL.F Dialog.f GENERIC.F Window.f 
Log Message:
Removed temporary class dialog&control

Index: Window.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Window.f,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** Window.f	14 Sep 2011 13:35:08 -0000	1.26
--- Window.f	9 Jun 2012 18:45:47 -0000	1.27
***************
*** 73,84 ****
                          \ left it here in order not to break too much code (Sonntag, Juni 04 2006 dbu).
        int hWndParent    \ handle of the parent window (added Sonntag, Juni 04 2006 dbu)
!       int mydialoglink
  
  \ The following is for backward compatibility. Use WinRect for new code since it will
  \ be early bound whereas wRect will be latebound.
! int wRect
! Rectangle WinRect
  synonym WndRect  wrect
- synonym TempRect wrect
  
  :M ClassInit:   ( -- )
--- 73,82 ----
                          \ left it here in order not to break too much code (Sonntag, Juni 04 2006 dbu).
        int hWndParent    \ handle of the parent window (added Sonntag, Juni 04 2006 dbu)
! \      int mydialoglink
  
  \ The following is for backward compatibility. Use WinRect for new code since it will
  \ be early bound whereas wRect will be latebound.
! 
  synonym WndRect  wrect
  
  :M ClassInit:   ( -- )
***************
*** 103,116 ****
                  ['] noop to track-func
                  WindowClassName MAXSTRING erase \ clear the class name
!                 addr: WinRect to wRect
                  ;M
  
  \ Temporarily moved here to overcome problem with offset of ints
! : +DialogList  ( -- )           \ link into dialog list
!         (dialoglock) Dialog-link link,
!         self , Dialog-link @ (dialogunlock) to mydialoglink ;
! 
! : -DialogList ( -- )            \ Unlink from dialog list
!         (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ;
  
  \ -----------------------------------------------------------------
--- 101,114 ----
                  ['] noop to track-func
                  WindowClassName MAXSTRING erase \ clear the class name
! \                addr: WinRect to wRect
                  ;M
  
  \ Temporarily moved here to overcome problem with offset of ints
! \ : +DialogList  ( -- )           \ link into dialog list
! \         (dialoglock) Dialog-link link,
! \         self , Dialog-link @ (dialogunlock) to mydialoglink ;
! \
! \ : -DialogList ( -- )            \ Unlink from dialog list
! \         (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ;
  
  \ -----------------------------------------------------------------

Index: Dialog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Dialog.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Dialog.f	17 May 2007 11:10:22 -0000	1.6
--- Dialog.f	9 Jun 2012 18:45:47 -0000	1.7
***************
*** 80,84 ****
  \ *W <a name="Dialog"></a>
  \ *S Dialog Class
! :CLASS Dialog   <SUPER Dialog&Control
  \ *G Dialog class. \n
  \ ** To use this class you have to create a ressource file (*.res) which must contain
--- 80,84 ----
  \ *W <a name="Dialog"></a>
  \ *S Dialog Class
! :CLASS Dialog   <SUPER Generic-Window
  \ *G Dialog class. \n
  \ ** To use this class you have to create a ressource file (*.res) which must contain

Index: CONTROL.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/CONTROL.F,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** CONTROL.F	21 Jul 2011 18:26:21 -0000	1.12
--- CONTROL.F	9 Jun 2012 18:45:47 -0000	1.13
***************
*** 80,84 ****
  \ *W <a name="Control"></a>
  \ *S Generic Control class
! :Class Control          <Super Dialog&Control
  \ *G Generic control class. \n
  \ ** Since Control is a generic class it should not be used to create
--- 80,84 ----
  \ *W <a name="Control"></a>
  \ *S Generic Control class
! :Class Control          <Super Generic-Window
  \ *G Generic control class. \n
  \ ** Since Control is a generic class it should not be used to create

Index: GENERIC.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/GENERIC.F,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** GENERIC.F	3 Mar 2012 09:15:14 -0000	1.26
--- GENERIC.F	9 Jun 2012 18:45:47 -0000	1.27
***************
*** 112,115 ****
--- 112,126 ----
  \ *G handle to Win32 window object
  
+ int mydialoglink
+ 
+ \ The following is for backward compatibility. Use WinRect for new code since it will
+ \ be early bound whereas wRect will be latebound.
+ 
+ Rectangle WinRect
+ 
+ int wRect
+ 
+ synonym tempRect wRect
+ 
  \ -----------------------------------------------------------------
  \ -----------------------------------------------------------------
***************
*** 157,160 ****
--- 168,173 ----
                  0 to hWnd turnkeyed? 0=  \ only dynamic windows can be used in a
  \in-system-ok   if link-window then      \ turnkeyed application so skip linking
+                 0 to mydialoglink       \ added Sonntag, Juni 04 2006 dbu
+                 addr: WinRect to wRect
                  ;M
  
***************
*** 277,291 ****
                  ;M
  
- ((
  :M GetWindowRect: ( -- left top right bottom )
                  hWnd
!                 if      EraseRect: WinRect
!                         AddrOf: WinRect hWnd Call GetWindowRect ?win-error
!                         Left: WinRect  Top: WinRect
!                         Right: WinRect Bottom: WinRect
!                 else    0 0 0 0
!                 then
!                 ;M
! ))
  
  :M SetMenu:     ( MenuHandle -- )
--- 290,304 ----
                  ;M
  
  :M GetWindowRect: ( -- left top right bottom )
+ \ *G The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window.
+ \ ** The dimensions are given in screen coordinates that are relative to the upper-left corner
+ \ ** of the screen.
                  hWnd
!                 if   EraseRect: WinRect
!                      AddrOf: WinRect hWnd Call GetWindowRect ?win-error
!                      Left: WinRect  Top: WinRect
!                      Right: WinRect Bottom: WinRect
!                 else 0 0 0 0
!                 then ;M
  
  :M SetMenu:     ( MenuHandle -- )
***************
*** 604,608 ****
                  1 -rot WM_SETFONT swap SendDlgItemMessage: self ;M
  
- ((
  \ The following definitions are for handling Dialog messages and have been moved
  \ here rather than have multiple copies of the code in different descendants
--- 617,620 ----
***************
*** 613,617 ****
  : -DialogList ( -- )            \ Unlink from dialog list
          (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ;
! ))
  : DoDialogMsg { pMsg flag -- pMsg f | pMsg FALSE }
          (dialoglock)
--- 625,629 ----
  : -DialogList ( -- )            \ Unlink from dialog list
          (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ;
! 
  : DoDialogMsg { pMsg flag -- pMsg f | pMsg FALSE }
          (dialoglock)
***************
*** 643,693 ****
  pre-save-image-chain chain-add zero-image-windows
  
- \ *W <a name="DIALOG&CONTROL"></a>
- \ *S Generic class for Dialog- and Control-Window objects.
- |CLASS DIALOG&CONTROL <SUPER Generic-Window
- \ *G Base class for all dialog and control objects.
- \ *P Since DIALOG&CONTROL is a generic class it should not be used to create
- \ ** any instances.
- 
- in-application
- 
- int mydialoglink
- 
- \ The following is for backward compatibility. Use WinRect for new code since it will
- \ be early bound whereas wRect will be latebound.
- 
- int wRect
- Rectangle WinRect
- synonym tempRect wRect         \ Can't be made a colon def - [cdo-2008May13]
- 
- :M Classinit:   ( -- )
- \ *G Initialise the class.
-                 ClassInit: super
-                 0 to mydialoglink       \ added Sonntag, Juni 04 2006 dbu
-                 addr: WinRect to wRect
-                 ;M
- 
- :M GetWindowRect: ( -- left top right bottom )
- \ *G The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window.
- \ ** The dimensions are given in screen coordinates that are relative to the upper-left corner
- \ ** of the screen.
-                 hWnd
-                 if   EraseRect: WinRect
-                      AddrOf: WinRect hWnd Call GetWindowRect ?win-error
-                      Left: WinRect  Top: WinRect
-                      Right: WinRect Bottom: WinRect
-                 else 0 0 0 0
-                 then ;M
- 
- \ Temporarily moved here to overcome problem with offset of ints in Window.f
- : +DialogList  ( -- )           \ link into dialog list
-         (dialoglock) Dialog-link link,
-         self , Dialog-link @ (dialogunlock) to mydialoglink ;
- 
- : -DialogList ( -- )            \ Unlink from dialog list
-         (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ;
- 
- ;CLASS
- \ *G End of DIALOG&CONTROL class
- 
  \ *Z
--- 655,657 ----

[Win32forth-cvs] win32forth/src/lib Security.f,1.1,1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory vz-cvs-4.sog:/tmp/cvs-serv32293

Modified Files:
	Security.f 
Log Message:
Jos Adapted for windows7

Index: Security.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/Security.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Security.f	10 Jun 2006 17:58:13 -0000	1.1
--- Security.f	6 Jun 2012 16:24:33 -0000	1.2
***************
*** 86,93 ****
  12 constant TokenSessionId
  
  : GetTokenInformation ( type TokenHandle - buffer-with-info buffer-size )
!    temp$ 100 erase
!    2>r pad maxstring temp$ 2r> call GetTokenInformation ?win-error
!    temp$ 4 + pad @ ;
  
  : reset_last_error     ( - )  0 call SetLastError drop ;     \ *W95
--- 86,97 ----
  12 constant TokenSessionId
  
+ 
+ 500 constant /large$
+ /large$ create large$ allot
+ 
  : GetTokenInformation ( type TokenHandle - buffer-with-info buffer-size )
!    large$ /large$ erase
!    2>r pad /large$ large$ 2r> call GetTokenInformation ?win-error
!    large$ 4 + pad @ ;
  
  : reset_last_error     ( - )  0 call SetLastError drop ;     \ *W95
***************
*** 127,131 ****
     &token_privilege luaa 2!
     0 temp$ ! temp$
!    pad 
     400
     &token_privilege   false
--- 131,135 ----
     &token_privilege luaa 2!
     0 temp$ ! temp$
!    pad
     400
     &token_privilege   false

[Win32forth-cvs] win32forth/src/lib MultiTaskingClass.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory vz-cvs-4.sog:/tmp/cvs-serv22148

Added Files:
	MultiTaskingClass.f 
Log Message:
Jos: The experimental fase is over. I think it would be a nice extension for Win32Forth. Feel free to improve or extend it.

--- NEW FILE: MultiTaskingClass.f ---
anew MultiTaskingClass.f   \ June 4th, 2012, for XP or better. See the demos at the end for its use.


\ *D doc\classes\
\ *! MultiTaskingClass
\ *T MultiTaskingClass -- For clustered tasks in objects.

\ *S Abstract

\ *P CPU's with multiple cores can execute a program faster than cpu's with a single core. \n
\ ** This is done by breaking up a program in smaller pieces and than execute all pieces simultaneously. \n
\ ** In multiTaskingClass.f this idea is supported as follows: \n
\ ** Breaking up is possible at the definition level or at the program level by the 2 classes \biTask\d and \bwTask\d. \n
\ ** Then the pieces are submitted and simultaneously executed in a number of tasks. \n
\ ** The tasks are clustered in an object for easy access.

\ *P Objects defined with \biTask\d can be used as soon as ONE definition should be executed in a parallel way
\ ** and the definition uses a do...loop. \n
\ ** The method \iParallel:\d divides, distributes and submits for execution the specified cfa over a number of tasks. \n
\ ** \iParallel:\d takes in account the number of hardware threads, so all these threads wil be used during execution. \n
\ ** A started task can pickup its range for the do...loop part by using the method \iGetTaskRange:\d \n
\ ** The initialization of the objects defined with iTask is automatic. \n
\ ** It is possible to change the number of simultaneous tasks before they run.

\ *P Objects defined with \bwTask\d can be used to execute concurrently one or more different definitions. \n
\ ** These objects must be initialized with the method \iStart:\d \n
\ ** The method \iStart:\d takes the number of simultaneous tasks as a parameter. \n
\ ** It does not start any task. \n
\ ** Use the method \iSubmitTask:\d for starting a definition as a task. \n
\ ** When a new task is submitted and the maximum number of simultaneous tasks is reached the following will happen: \n
\ ** 1) The system will wait till one or more tasks are complete. \n
\ ** 2) Then it will submit the task. \n
\ ** At this moment the system is limited to 63 simultaneous tasks for each taskobject
\ ** that is defined with wTask or iTask.

\ *P Tasks of both classes will get their parameters at the start on the stack
\ ** as soon as the method \iTo&Task:\d is used just before the task is submitted. \n
\ ** MultiTaskingClass.f uses preemptive multitasking system of windows. No need to use pause. \n

\ History:
\ To handle tasks in an object.
\ 16-07-2011 Added WaitFor and iTasks
\ 07-03-2012 Added Putrange: GetTaskRange: SubmitTasks: UseOneThreadOnly:
\                  UseALLThreads: and &Timers for each task in the object iTask
\ 04-06-2012 Moved the task-block out of the dictionary for the taskobjects and
\            added cells+@ cells+! #ActiveTasks: and the waitobject wTask including a demo for wTask.
\            Removed the tasks in a chain. The object wTask does this better and easier.
\            ExitTask is now handled by the objects. Remove ExitTask from your code when it is still there.
\            Added task>cfa and task>&StkParams to the task-block
\            Now maximal 8 parameters can be passed to a task without much overhead. (Can be changed)
\            All in all it means that many definitions are now able to run
\            in a submitted task without having to change the submitted definition.
\            Renamed MultiTask.f to MultiTaskingClass.f



  (( Disable or delete this line for generating a glossary

cr cr .( Generating Glossary )

needs help\HelpDexh.f  DEX MultiTaskingClass.f

cr cr .( Glossary MultiTaskingClass.f generated )  cr 2 pause-seconds bye  ))



needs task.f

\ *S Glossary

code cells+@  ( a1 n1 -- n ) \
\ *G Multiply n1 by the cell size and add the result to address a1
\ ** then fetch the value from that address.
                pop     eax
                lea     ebx, 0 [ebx*4] [eax]
                mov     ebx, 0 [ebx]
                next    c;

code cells+!  ( n a1 n1 -- )
\ *G Multiply n1 by the cell size and add the result to address a1
\ ** then store the value n to that address.
                pop     eax
                lea     ebx, 0 [ebx*4] [eax]
                pop     [ebx]
                pop     ebx
                next    c;

0 proc GetCurrentThread
2 proc SetThreadPriority
0 proc GetCurrentThread
2 proc SetThreadPriority

256 value stacksize

internal

0 value ValuespMainTask  \ Only to be used to see if a word is running in a subtask
: GetValueSpMainTask ( - UpMainTask )  ValuespMainTask ;
: SetValueSpMainTask ( - )             sp0 to ValuespMainTask ;

initialization-chain chain-add SetValueSpMainTask
SetValueSpMainTask

external

: MainTask? ( - flag )
\ *G The main task is the task in which the program initial starts. \n
\ ** MainTask? returns true when it runs in the main task.
    GetValueSpMainTask sp0 = ;

previous

: GetTaskParam ( - IDindex )
\ *G Each task get an index. GetTaskParam returns that index.
\ ** GetTaskParam in a task can be used to target a value in an array.
    MainTask?   if    0    else  tcb @ task>parm  @   then ;

: #Hardware-threads ( - #Hardware-threads )
\ *G  Returns the number of hardware threads found in the CPU.
    ( sizeof system_info)  36 LOCALALLOC dup
    ( relative dwNumberOfProcessors) 20  + swap
    call GetSystemInfo drop @
  ;

: SetPriority ( Prio - )
\ *G Changes the priority of the task.
    GetCurrentThread SetThreadPriority drop ;

: below       ( -- )
\ *G Lowers the the priority of the task in order to keep the main task responsive to the mouse etc.
    THREAD_PRIORITY_BELOW_NORMAL SetPriority ;

winerrmsg on

: #do  \ Compiletime: ( <name> -- )  Runtime: ( limit start - )
\ *G To construct:     do  i  cfa   loop \n
\ ** EG: \n
\ ** : test  10 0   #do . ; \n
\ ** Will be compiled as: \n
\ ** : TEST  10 0    DO  I . LOOP    ; \n
    s" do  i " evaluate
           ' compile,  \   Runtime expects of the compiled cfa: ( index -  )
    s" loop " evaluate
  ; immediate

\ : test 10 0 #do . ; cr  see test cr test abort


:Class WaitObject    <Super Object
\ *G Handles the waiting of one or more handles.

\ ** Settings in the WaitObject :
\ *L
\ *| Name:        | Use:                                                     |
\ *| &wait-hndls  | -- Cells to hold task the handles for the wait function. |
\ *| #wait-hndls  | -- The Number of used &wait-hndls.                       |
\ *| taskwaits    | -- The number of handles not ready.                      |

    int &wait-hndls     \ cells to hold task handles for wait function.
    int #wait-hndls     \ Number of used &wait-hndls.
    int taskwaits       \ The number of handles not ready

: WaitForMultipleObjects { ms wait array count -- res }
\ *G Waits till one or more handles are ready and deals with messages.

\ ** Parameters:
\ *L
\ *| Name: | Use:                                                                        |
\ *| ms    | -- The time-out interval time in milliseconds to test if a handle is ready. |
\ *| wait  | -- When to return.                                                          |
\ *| array | -- An array of object handles.                                              |
\ *| count | -- The number of object handles in the array.                               |
\ *| res   | -- The event that caused the defintion to return.                           |
    begin   QS_ALLINPUT ms wait array count call MsgWaitForMultipleObjects
            dup WAIT_OBJECT_0 count + =
    while   drop winpause
    repeat
 ;

:M GetTaskwaits: ( - taskwaits )
\ *G Returns the number of handles still waiting.
    taskwaits ;M

:M MallocWaitHndls: ( #wait-hndls -- )
\ *G Allocates the array for the object handles. 63 is the maximum.
    dup MAXIMUM_WAIT_OBJECTS >= abort" Too many wait handles. 63 is the maximum."
    dup to  #wait-hndls
    cells MALLOC to &wait-hndls       \ cells to hold object handles for the wait function
  ;M

;Class


7 cells constant MinimumSizeTaskblock    \ Minimum size of a task block
8 constant /StkParams                    \ The maximum number of parameters to pass to a Task
/StkParams 2 + cells newuser &StkParams  \ To pass parameters to a task.
                                         \ The first cell is resevered for a long count

: Reset&StkParams ( - )
\ *G Sets the long count of &StkParams to 0.
     0 &StkParams ! ;

initialization-chain chain-add Reset&StkParams
Reset&StkParams

\ *P General parameters for all tasks:
\ *L
\ *| Name:      | Use:                                                                 |
\ *| MinimumSizeTaskblock | -- Minimum size of a task block. Default is 7 cells.       |
\ *| /StkParams | -- The maximum number of parameters to pass to a Task. Default is 8. |
\ *| &StkParams | -- An array in the user area to pass parameters to a task.           |


:Class TaskPrimitives    <Super WaitObject
\ *G Contains the general definitions for a task object.

    int #Tasks          \ The maximum number of simultaneously tasks in use in the object.
    int /Taskblock      \ The size of one Task-block.
    int &Taskblocks     \ The taskblock array.
    int OnlyOneThread   \ A flag used to force to use 1 thread only for testing
    int &Timers         \ An array of elapsed &Timers

\ ** Settings in the objects defined with TaskPrimitives:
\ *L
\ *| Name:           | Use: |
\ *| #Tasks          | -- The maximum number of simultaneously tasks in use in the object.      |
\ *| /Taskblock      | -- The size of one Task-block.                                           |
\ *| &Taskblocks     | -- The taskblock array.                                                  |
\ *| OnlyOneThread   | -- A flag used to force to use 1 thread only for testing.                |
\ *| &Timers         | -- An array of elapsed &Timers                                           |

: GetTaskblock     ( IDindex - taskblock )
\ *G Returns the adres of the taskblock array for its index.
    s" /Taskblock  * &Taskblocks + " EVALUATE ; IMMEDIATE

: task>cfa         ( tcb - task>cfa )
\ *G Returns the address of the CFA to be executed from the taskblock.
    5 cells+ ;

: task>&StkParams  ( tcb - task>&StkParams )
\ *G Returns the address of the parameters for a task. The first cell contains its count.
    6 cells+ ; \ pointer to &Task

: ExitTask         ( - )
\ *G To exit a task. \n
\ ** ExitTask releases the except-Buffer and calls ExitThread.
    MainTask? not   if  GetTaskParam exit-task   then  ;

:M To&Task:  ( ... n  --  )
\ *G To pass maximal 8 parameters to a task through &StkParams.
    dup &StkParams  !  &StkParams  dup @ 1+ cells+ swap dup /StkParams >
    abort" Too many parameters for the task. " 0
       do     1 cells- dup>r ! r>
       loop
     drop
  ;M

:M Take&StkParams: { &Adr --  CountTo&Task... }
\ *G Puts the parameters from &StkParams on the stack in the running task.
    &Adr @ 0
       do &Adr i 1+ cells+ @
       loop
    0 &Adr ! \ Reset the count
  ;M

: ExecuteTaskExit  ( -- )
\ *G Will run first in any task.
\ ** ExecuteTaskExit takes the parameters, puts them on the stack, execute the task and exits the task.
    tcb @ dup>r
    task>&StkParams @ dup @ 0>    \ Look for parameters
      if    Take&StkParams: Self  \ Takes the parameters from &StkParams on the stack
      else  drop
      then
    r> task>cfa @ execute    \ execute the cfa
    exittask                 \ exit the task
  ; \ Exit the task when ready

: WhenTasksInRange   ( #Tasks  - #Tasks )
\ *G Continuous when the #Tasks is smaller then MAXIMUM_WAIT_OBJECTS.
    dup MAXIMUM_WAIT_OBJECTS
    >= abort" Too many simultaneously tasks. 63 is the maximum."
 ;

:M GetTaskcount:  ( -- #Tasks )
\ *G Returns the maximum number of simultaneously tasks in use.
    #Tasks ;M

:M Max#Tasks:     ( -- #Tasks )
\ *G When the maximum number of hardware threads is less than 64
\ ** it returns the number of hardware threads. \n
\ ** Else it returns 63. \n
\ ** It returns 2 for older cpu's. Can be overwritten
    #Hardware-threads 2 max  maximum_wait_objects 1- min
  ;M

:M Make-iTask:   ( cfa IDindex -- )
\ *G Makes one task and stores the task ID
\ ** and the cfa in the taskblock
    ['] ExecuteTaskExit over GetTaskblock dup>r !
    r@ task>parm !
    &StkParams r@ task>&StkParams !
    r> task>cfa !
  ;M

: CreateTask    ( IDindex -- )
\ *G Creates the task for windows using its taskblock.
    GetTaskblock  create-task  drop  ;

: SaveWaitHandle ( IDindex -- )
\ *G Save the taskhandle in the wait-handle array.
    dup GetTaskblock task>handle @    \ get the taskhandle
    &wait-hndls rot cells+!           \ save the wait handle
 ;

: TaskIndex          ( - #Tasks 0 )
\ *G Returns 0 and the maximum number of simultaneously tasks in use by the object.
    #Tasks 1 max 0 ;

: SaveWaitHandles    ( -- )
\ *G Save the taskhandles, in use in the object, in the wait-handle array.
    #wait-hndls 0 #do SaveWaitHandle  ;

: CreateTasks        ( -- )
\ *G Creates the tasks, in use in the object, for windows using their taskblock.
     TaskIndex  #do CreateTask  ;  \ In a suspended state

:M SuspendTask:      ( IDindex -- )
\ *G Suspend the task with the specified ID.
    GetTaskblock  suspend-task drop ;M

:M ResumeTask:       ( IDindex -- )
\ *G Resumes the task with the specified ID.
    GetTaskblock  resume-task  drop ;M

:M SuspendTasks:     ( -- )
\ *G Suspend all active tasks in use by the object.
    TaskIndex  do  i SuspendTask: Self loop ;M

:M ResumeTasks:      ( -- )
\ *G Resume all active tasks in use in the object by the object.
    TaskIndex  do  i ResumeTask: Self  loop ;M

:M UseOneThreadOnly: ( -- )
\ *G Overwrite the number of simultaneously tasks in use by the object.
\ ** Use it before submitting a task.
    true to OnlyOneThread  ;M

:M UseALLThreads:    ( -- )
\ *G To overwrite UseOneThreadOnly:. Is default.
    false to OnlyOneThread ;M

:M GetTaskblockSize: ( - Size )
\ *G Returns the taskblock size.
    /Taskblock  ;M


:M #ActiveTasks:  { \ lpExitCode } ( - #ActiveTasks )
\ *G Returns the number active tasks in the object.
    0 &Taskblocks 0<>
        if TaskIndex
             do  i GetTaskblock task>handle @ dup 0<>
                 if 0 swap call WaitForSingleObject WAIT_TIMEOUT =
                    if   1+
                    then
                 else drop
                 then
             loop
        then
  ;M

:M SetTaskblockSize:  ( NewSize - )
\ *G Sets a new size for the task block.
    #ActiveTasks: Self abort" Active tasks detected. Can't resize /StkParamsblock."
    MinimumSizeTaskblock over > abort" The minimal taskblock size is 7 CELLS."
    to /Taskblock
  ;M

: make-tasks   ( cfa -- )
\ *G Makes all the tasks in use by the object and create their taskblocks.
    TaskIndex
      do    dup i Make-iTask: Self
      loop
    drop
   ;

: Init-Tasks ( cfa -- )
\ *G Initializes all the tasks. Start Nothing.
    make-tasks   CreateTasks  SaveWaitHandles ;

:M ClassInit:  ( -- )
\ *G Initializes the object.
    ClassInit: super
    0 to &Taskblocks
    MinimumSizeTaskblock SetTaskblockSize: Self
    false to OnlyOneThread
  ;M

;Class


:Class iTasks    <Super TaskPrimitives
\ *G For a number of tasks that run ONE definition parallel at the same time. \n
\ ** In this class all tasks are indexed and handeld in one go.  \n
\ ** ALL tasks should handle their own data.  \n
\ ** The Task-blocks are allocated in the heap.  \n
\ ** When all tasks are completed the allocated memory is NOT
\ ** released and can be used again. \n
\ ** The number of tasks can also be overwritten when there are notasks active. \n
\ ** Each task can get its index by using GetTaskParam. \n
\ ** GetTaskParam can be used to target a value in an array.

    int &Ranges                \ Pointer to an array of allocated Ranges.
    2 cells bytes TotalRange

\ *P Settings in objects defined with iTasks also include:
\ *L
\ *| Name:      | Use: |
\ *| &Ranges    | --- Pointer to an array of allocated ranges in the object.    |
\ *| TotalRange | --- 2 cells containing the total of all ranges in the object. |

: >range    ( TaskParam - adr )     2 cells  * &Ranges + ;

:M GetRange: ( TaskParam -- High Low )
\ *G Returns the range to be used in a do...loop in one task in use by the object.
    #Tasks 1 >
       if    >range dup>r  @ r> cell+ @
       else  drop TotalRange 2@
       then
  ;M

:M ResetTimer:    ( - )
\ *G Resets a timer in a task by using its IDindex.
    ms@ &Timers GetTaskParam cells+! ;M

:M StopTaskTimer: ( - )
\ *G Stops a timer in a task by using its IDindex.
    ms@ &Timers GetTaskParam cells+ dup>r @  - r> ! ;M

:M Reset&Timers:  ( - )
\ *G Reset all timers of the tasks in use by the object.
    ms@ #Tasks 0   do   dup &Timers i cells+!   loop  drop ;M

:M GetTaskRange:  ( -- High Low )
\ *G Returns the range to be used in a do...loop of the task.
    GetTaskParam GetRange: Self  ;M

:M Putrange:      ( High Low IDindex -- )
\ *G Saves the range of a task.
    >range dup>r  cell+ ! r> ! ;M

:M .&Timers:      ( TaskParam - )
\ *G Show all times. Use in in the main-task when the tasks are completed in the object.
    cr ." &Timers:" #Tasks 1 max 0
        do  &Timers i cells+@ cr i  .
            [ 24 60 * 60 * 1000 * ] literal mod
            1000 /mod
              60 /mod
              60 /mod 2 .#" type ." :"
                      2 .#" type ." :"
                      2 .#" type ." ."
                      3 .#" type
       loop
  ;M

: CloseTaskHandle  ( IDindex -- )
\ *G Close a task handle using the ID of the task.
    GetTaskblock  task>handle dup>r @  call CloseHandle drop 0 r> !
 ;

: ResetTaskHandle  ( IDindex -- )
\ *G Sets a task handle to 0 using the ID of the task.
     GetTaskblock task>handle 0 swap !
 ;

: cr-dup.        ( n - n )
\ *G Show n on a new line in the concole.
    cr dup . ;

: .range         ( IDindex - )
\ *G Show the assigned range of a task using the ID of the task.
     cr-dup. GetRange: Self  swap . .  ;

: .WaitHndl      ( IDindex - )
\ *G Show the waithandle of a task using the ID of the task.
    cr-dup. &wait-hndls swap cells+ ? ;

: .TaskHndl      ( IDindex - )
\ *G Show the task handle of a task using the ID of the task.
    cr-dup. GetTaskblock task>handle ? ;

:M .&Ranges:         ( -- )
\ *G Show all the ranges of the tasks in use by the object.
    TaskIndex #do .range cr  ;M

:M .TaskHndls:       ( -- )
\ *G Show all the taskhandles of the tasks in use by the object.
    TaskIndex #do .TaskHndl cr ;M

:M .WaitHndls:       ( -- )
\ *G Show all the wait handles of the tasks in use by the object.
    #wait-hndls 0 #do .WaitHndl cr ;M

:M CloseTaskHandles: ( -- )
\ *G Close and reset all the taskhandles of the tasks in use by the object.
    TaskIndex #do CloseTaskHandle ;M

:M ResetTaskHandles: ( -- )
\ *G Sets all the taskhandles of the tasks in use by the object to 0.
    TaskIndex #do ResetTaskHandle ;M

:M Set&Ranges:  { High low -- }
\ *G Set all the ranges of the tasks in use by the object.
    High low - #Tasks dup>r  / r> 0
         do      High dup>r over - dup  to High r> swap i Putrange: Self
        loop
    low #Tasks 1- >range cell+ ! drop
  ;M

:M MallocTasksArrays: ( -- )
\ *G Allocates various arrays for the tasks in use by the object. \n
\ ** In an iTask object this is automaticly done.
    &Taskblocks 0=      \ Only executed when not done or when ReleaseTasksArrays: is executed
        if  #Tasks 1 max dup>r /Taskblock  * malloc to &Taskblocks \ Each task gets a taskblock
            r@ cells     MALLOC to &Timers  \ Pointer to the &Timers
            r@ cells 2 * MALLOC to &Ranges  \ Pointer to the defined &Ranges for each task. Map: High low
            r> MallocWaitHndls: Self        \ Allocates handles for wait function
        then
  ;M

:M ReleaseTasksArrays:    ( -- )
\ *G Releases various arrays for the tasks in use by the object.
    #ActiveTasks: Self  abort" Active tasks detected. Can't release memory."
    0 to #Tasks
    &Ranges     release 0 to &Ranges       \ Release &Ranges
    &wait-hndls release 0 to &wait-hndls   \ Release &wait-hndls
    &Taskblocks release 0 to &Taskblocks   \ Release &Taskblocks
  ;M

: RunTask       ( IDindex -- )
\ *G Runs a task using its ID.
    GetTaskblock   run-task drop  ;

: RunTasks      ( -- )
\ *G Runs all tasks in use by the object.
    TaskIndex  #do RunTask     ;

:M StopTask:     ( IDindex -- )
\ *G Stops a task using its ID.
    GetTaskblock  stop-task  drop           ;M

:M StopTasks:    ( -- )
\ *G Stop all tasks in use by the object.
    TaskIndex  do  i StopTask: Self    loop ;M


:M PutTaskcount: ( #Tasks -- )
\ *G Changes the number of simultaneous tasks that can be used by the object. \n
\ ** Can only be done when there are no active tasks.
    &Taskblocks 0<>
       if    ReleaseTasksArrays: Self
       then
    to #Tasks MallocTasksArrays: Self
  ;M


:M WaitForAlltasks: ( - )
\ *G Wait till all tasks in use by the object are completed.
    #wait-hndls  to taskwaits
        begin
          taskwaits
        while
          INFINITE false &wait-hndls          \ wait for 1 or more tasks to end
          taskwaits  WaitForMultipleObjects   \ wait on handles list
          dup WAIT_FAILED = if getlastwinerr then \ note the error
          WAIT_OBJECT_0 +                     \ ( event - IDindex )
          >r -1 +to taskwaits                 \ 1 task fewer to wait for, clean up the list
          &wait-hndls r@ cells+@ call CloseHandle drop   \ close the old taskhandle while the other tasks still run
          &wait-hndls taskwaits cells+@       \ get last handle in list
          &wait-hndls r> cells+!              \ store in signaled event ptr
        repeat
     ResetTaskHandles: Self                   \ Set all taskhandles in the taskblocks to 0
\   cr ." All tasks completed"
  ;M

:M SetParallelItems: ( limit IndexLow - )
\ *G Distributes the ranges for all tasks in use by the object.
    2dup TotalRange 2!
    Max#Tasks: Self 2 pick min  OnlyOneThread
       if     drop 1        \  Force 1 thread when OnlyOneThread is true
       then   PutTaskcount: Self
    MallocTasksArrays: Self \ Allocates the tasks, &wait-hndls and &Ranges when not done
    Set&Ranges: Self
  ;M

:M SubmitTasks: ( cfa -- )
\ *G Submits all tasks in use by the object and returns direct.   \n
\ ** Each task will execute the specified cfa and get its range.  \n
\ ** \bNOTE:\d SetParallelItems: must be executed before SubmitTasks:
    MallocTasksArrays: Self    \ Allocates the tasks, &wait-hndls and &Ranges when not done
    Init-Tasks Reset&Timers: Self ResumeTasks: Self
  ;M

:M StartTasks: ( cfa -- )
\ *G Starts all tasks in use by the object and wait till they are completed. \n
\ ** Each task will execute the specified cfa and get another range. \n
\ ** \bNOTE:\d SetParallelItems: must be executed before StartTasks:
    SubmitTasks: Self         \ Start all threads and return direct.
    WaitForAlltasks: Self     \ THEN WAIT till all the started threads are completed.
  ;M

:M Parallel: ( limit IndexLow cfa -- )
\ *G Executes the specified cfa in a number of tasks. \n
\ ** The number of tasks depend on the number of hardware threads and
\ ** the specified range in limit and IndexLow. \n
\ ** Parallel: returns when all the tasks in the object are completed. \n
\ ** Each task can get its range by using GetTaskRange: \n
\ ** Each range can be passed to a do..loop or #do \n
\ ** The debugger can not be used in a task. \n
\ ** See Single: for debugging.
     -rot SetParallelItems: Self StartTasks: Self
  ;M

:M Single: ( limit IndexLow cfa -- )
\ *G Executes the definition of the specified cfa in the main task.
\ ** The executed definition can get its range by using GetTaskRange:
\ ** Made for debugging while running in the maintask.
    MainTask?
       if    MallocTasksArrays: Self
             -rot TotalRange 2! >r
             &StkParams dup @ 0>
                 if   Take&StkParams: Self
                 else drop
                 then
             ms@ &Timers !
             r> execute
       else  s" Single: Must start from the main-task" ErrorBox
       then
  ;M

;Class


:Class wTasks    <Super TaskPrimitives
\ *G To run a number of tasks concurrently that can not be indexed. \n
\ ** Each task may run a different definition. \n
\ ** By default it can run a number of simultaneously tasks that will be limited
\ ** by the number of specified simultaneous tasks with a maximum of 63 in ONE object. \n
\ ** When all the simultaneous tasks are used wTask will wait till ONE task is ready. \n
\ ** Then it will use the free taskblock again and start the new task for the submit command. \n
\ ** Of course you can override the maximum number of tasks that run simultaneously. \n
\ ** by using PutTaskcount:. This must be done when no task runs. \n
\ ** Taskblocks are allocated in the heap. \n
\ ** When all tasks are completed the allocated memory is NOT released
\ ** and can be used again. \n
\ ** ALL tasks should handle their own data. \n
\ ** Each task also get an index before they start. \n
\ ** Use GetTaskParam in the task to get it on the stack. \n
\ ** GetTaskParam can be used to target a value in an array for passing parameters. \n
\ ** Note: Start: must be started \bBEFORE\d a task is submitted.

int Specified#Tasks \ internal use

:M MallocTasksArrays: ( -- )
    &Taskblocks 0=      \ Only executed when not done or when ReleaseTasksArrays: is executed
         if  #Tasks 1 max dup>r /Taskblock * malloc to &Taskblocks \ Each task get a taskblock
             pad to &Timers                 \ No &Timers yet
             r@ MallocWaitHndls: Self       \ Allocates handles for wait function
             r> to Specified#Tasks          \ Remember the #tasks
         then
  ;M

:M ReleaseTasksArrays:    ( -- )
    #ActiveTasks: Self  abort" Active tasks detected. Can't release memory."
    &Taskblocks release 0 to &Taskblocks
    &wait-hndls release 0 to &wait-hndls  \ Release &wait-hndls
  ;M

:M UseALLThreads:    ( - ) false to OnlyOneThread  Specified#Tasks to #Tasks ;M
:M UseOneThreadOnly: ( - ) true to OnlyOneThread 1 to #Tasks ;M

:M PutTaskcount:  ( #Tasks  - )
    WhenTasksInRange ReleaseTasksArrays: Self
    to #Tasks  MallocTasksArrays: Self  0 to #wait-hndls
  ;M

: UseTaskBlockAgain ( cfa IDindex -- )
\ *G Closes the old thread handle and save new cfa in taskblock.
    GetTaskblock dup task>handle @ call CloseHandle drop !
 ;

:M WaitForOnetask: ( cfa - )
\ *G Waits for one or more tasks to be completed.
\ ** Then it will run the specified cfa in a new task and return.
    #wait-hndls  to taskwaits
    INFINITE false &wait-hndls            \ wait for just one of the tasks
    taskwaits  WaitForMultipleObjects     \ wait on handles list
    dup  WAIT_FAILED = if getlastwinerr then \ note the error
    WAIT_OBJECT_0 +                       \ ( event - cfa IDindex )
    dup>r UseTaskBlockAgain r@ CreateTask \ Create a suspended new task in the same taskblock
    r@ SaveWaitHandle                     \ Save the waithandle in the free position
    r> ResumeTask: Self                   \ Run the new task
  ;M

:M WaitForAlltasks: ( - )                     \ Needed when to check that all submitted are ready
    #wait-hndls to taskwaits
        begin
          taskwaits
        while
          INFINITE false &wait-hndls          \ wait for 1 or more tasks to end
          taskwaits  WaitForMultipleObjects   \ wait on handles list
          dup WAIT_FAILED = if getlastwinerr then \ note the error
          WAIT_OBJECT_0 +                     \ ( event - IDindex )
          >r   -1 +to taskwaits            \ 1 task fewer to wait for, clean up the list
          &wait-hndls taskwaits cells+@       \ get last wait handle in list
          &wait-hndls r> cells+!              \ store in signaled event ptr
        repeat
\   cr ." All tasks completed"
  ;M

: AddOneTask ( cfa -- )
\ *G Submits the specified cfa in a new task and returns.
    #wait-hndls   dup>r                      \ ( cfa - cfa IDindex )
    Make-iTask: Self
    r@ CreateTask r@  SaveWaitHandle  r> ResumeTask: Self
    1 +to #wait-hndls
 ;

:M SubmitTask: ( cfa -- )
\ *G Submits the specified cfa in a new task and return after that task could be submitted.
    #Tasks  #wait-hndls  <=           \ When there is no hardware thread free anymore, then
        if    WaitForOnetask: Self    \ wait for one task, create a new thread and use the same task-block again.
        else  AddOneTask              \ Add a new thread and run.
        then
  ;M


:M Execute: ( cfa -- )
\ *G Executes the definition of the specified cfa in the main task.  \n
\ ** The executed definition can get its range by using GetTaskRange:  \n
\ ** Made for debugging while running in the maintask.  \n
    MainTask?
       if  >r &StkParams  dup @ 0>
              if   Take&StkParams: Self
              else drop
              then
           r> execute
       else  s" Execute: Must start from the main-task" ErrorBox
       then
  ;M

:M Start: ( #Tasks -- )     \ Used to initialize the object.
    to #Tasks
    false to OnlyOneThread \ #Tasks is the maximum number of tasks that may run simultaneously.
    0 to &Taskblocks
    0 to taskwaits
    MallocTasksArrays: Self \ Allocates the tasks and &wait-hndls when not done
    0 to #wait-hndls
  ;M


:M SetTaskblockSize:  ( NewSize - )
    SetTaskblockSize:  Super
    ReleaseTasksArrays: Self
    MallocTasksArrays:  Self
    0 to #wait-hndls
  ;M

;Class


  (( \  Disable or delete this line for a demo of indexed tasks in an OBJECT

0e fvalue ft0

: value-ft0
    ms@ 0e fto ft0
       begin  200e ft0 f+ fto ft0
              ms@ over 400 + >
       until drop  ;

TIMER-RESET
value-ft0 ft0 f>s 3 * value #counts    \ To get a runtime for about 8 - 20 seconds

 iTasks myTasks

: my-task ( - )              \ Increments a value at PAD
    Below  0 pad !   #counts 0
      do   1 pad +!
      loop
 ;

: .Analyse#Counts  ( - )
    cr ." All tasks ended."
    MS@ START-TIME - space .ELAPSED space
    cr ." Total counts: " #counts s>f GetTaskcount: myTasks s>f f* fdup e.
    s>f  1000e  f/
    cr ." counts / second: " f/ FE.
 ;

: find-elapsed-time   ( #tasks -- )
    >r cr cr ." Main task is waiting for " r@  . ." task" r@ 1 >
        if     ." s"
        then
    r> PutTaskcount: myTasks    \ Set the number of tasks to be used
    ['] my-task TIMER-RESET  StartTasks: myTasks  \ start the tasks
    .Analyse#Counts
 ;

 #Hardware-threads 2/ 1- value incr-loop

: find-elapsed-times  ( -- )
    1 find-elapsed-time
    Max#Tasks: myTasks dup>r 2/ 2 max find-elapsed-time
    #Hardware-threads 2 >
      if   r@  1- find-elapsed-time
           r@     find-elapsed-time
      then
    r> dup 2/ 1 max + MAXIMUM_WAIT_OBJECTS 1 - min find-elapsed-time
 ;

: .elapsed-results
    cls
    ." ImpactThreads: Finding the overall speed for" cr  ." parallel running counters using "
    #Hardware-threads . ." hardware threads."
    cr ." Wait till the end of the demo..."
    find-elapsed-times
    cr ." End of demo."
 ;

  .elapsed-results  abort \s ))

  (( \ Disable or delete this line for the Range test.

 iTasks myTasks

create results #Hardware-threads 2 max cells allot

: my-range-task  ( index n1 n2 n3 - ) { \ index }
    3drop                                \ Delete n1 n2 n3 passes by To&Task: myTasks
    GetTaskParam dup to index 1+ 10 * ms \ Each task will get an other wait-time.
    Below   index results index cells+!  \ Will be overwritten
    GetTaskRange: myTasks                \ Get the range for the do -- loop  for the running task
       do    i results index cells+!
       loop
    StopTaskTimer: myTasks
  ;

\ Just ONE line is needed to distribute data and execute a word in a parallel way
\ using all the hardware threads.

: range-test ( -- ) \ Setting the number of tasks automatically by using the word Parallel:
\   UseOneThreadOnly: myTasks  \ Optional for testing. Note: You can not use the debugger outside the main-task
    10 20 30 3 To&Task: myTasks                 \ To test that parameters can be passed
    170 0  ['] my-Range-task  Parallel: myTasks \ Start a number of tasks using all hardware threads when possible.
\   170 0  ['] my-Range-task  single: myTasks   \ single: instead of Parallel: for debugging

    cr cr ." Task ID's and &Ranges:"          .&Ranges: myTasks
          ." Number of used tasks: "          myTasks.#Tasks .
    cr    ." Indexes in the array results: "  myTasks.#Tasks 1 max 0
       do    results i cells+ ?
       loop
    .&Timers: myTasks
    ReleaseTasksArrays: myTasks                \ Release the allocated task arrays when ready
  ;


range-test abort \ ))

  (( \ Disable or delete this line for the SubmitTest.
\ Made to test and to prove that the use of more tasks can be faster.

    wTasks myTasks                 \ Make the object myTasks.
Max#Tasks: myTasks Start: myTasks  \ Initialize the object myTasks.
Max#Tasks: myTasks value #counters

\   5 dup PutTaskcount: myTasks to #counters \ An optional test.

#counters floats malloc value counters

 500000 value #loops
 1000 value #Restarts

: TestTask ( n1 n2 n3 - )
    3drop          \ Just to prove that passing parameters from an other task works
    below 0 pad ! #loops 0
      do   1 pad +!
      loop
    pad @ s>f counters  GetTaskParam floats +  f+!
 ;

: clr-counters ( - )
    #counters 0
        do   0e0 counters i floats + f!
        loop ;

: Total-counters  ( - f: Total )
    0e0 #counters  0
        do   counters i floats + f@ f+
        loop
  ;

: PromptTime ( - ) cr ." -- " .time time-buf 14 + w@ ." ."  3 .#" type ."  -- " ;

: .ActiveTasks ( - )
    PromptTime #ActiveTasks: myTasks
    ." The number of tasks that still run is: " . cr
 ;

: SubmitTest ( - )
    cls cr PromptTime ." SubmitTest started for " #loops s>f fe. ." in #loops in TestTask..."
\   UseOneThreadOnly: myTasks          \ Optional choise
\   15 cells SetTaskblockSize: myTasks \ Optional choise
    clr-counters   TIMER-RESET
    #Restarts dup>r 0
       do  10 20 30 3 To&Task: myTasks  \ Pass 3 parameters to the task to be submitted
           ['] TestTask SubmitTask: myTasks
       loop
    .ActiveTasks
    WaitForAlltasks: myTasks \  Needed to make sure that all tasks are ready
    MS@ START-TIME - .ELAPSED  space
    PromptTime ." All tasks are ready."
    ['] beep SubmitTask: myTasks 100 ms
    cr r@ . ." treads were used."

    cr ." Total counted: "
    Total-counters  fdup FE.      s>f 1000e  f/ f/ cr ." counts / second: " FE.
    cr ." The maximal number of simultaneous tasks was: " myTasks.#Tasks r> min .
    .ActiveTasks
 ;

: ExecuteTest ( - )
    cr ." ExecuteTest started for " #loops s>f fe. ." in #loops in TestTask..."
    clr-counters cr  TIMER-RESET
    #Restarts  dup 0
       do    10 20 30 3 To&Task: myTasks
             ['] TestTask Execute: myTasks
       loop
    MS@ START-TIME - .ELAPSED  swap space
    cr . ." restarts used." cr ." Total counted: "
    Total-counters  fdup FE. s>f 1000e  f/ f/ cr ." counts / second: " FE.
    cr ." Using Execute: ( No threads at all )"
 ;

 SubmitTest  ExecuteTest abort \s ))


(( On my iCore7:

-- 18:11:55.612 -- SubmitTest started for 500.000E3 in #loops in TestTask...
-- 18:11:56.246 -- The number of tasks that still run is: 6
Elapsed time: 00:00:00.635
-- 18:11:56.250 -- All tasks are ready.
1000 treads were used.
Total counted: 500.000E6
counts / second: 787.402E6
The maximal number of simultaneous tasks was: 8
-- 18:11:56.354 -- The number of tasks that still run is: 0

ExecuteTest started for 500.000E3 in #loops in TestTask...
Elapsed time: 00:00:02.443
1000 restarts used.
Total counted: 500.000E6
counts / second: 204.666E6
Using Execute: ( No threads at all )

 ))
\s
\ *Z

[Win32forth-cvs] win32forth/apps/PictureViewer PVMenu.f,1.2,1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/PictureViewer
In directory vz-cvs-4.sog:/tmp/cvs-serv15576/PictureViewer

Modified Files:
	PVMenu.f 
Log Message:
Minor mods

Index: PVMenu.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/PictureViewer/PVMenu.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** PVMenu.f	28 Aug 2008 01:39:50 -0000	1.2
--- PVMenu.f	8 May 2012 20:57:38 -0000	1.3
***************
*** 13,17 ****
          defined
          IF  drop
!         ELSE  count "header NextID DOCON , ,
          THEN ;
  
--- 13,17 ----
          defined
          IF  drop
!         ELSE NextID swap count ['] constant execute-parsing
          THEN ;
  

[Win32forth-cvs] win32forth/demos MDIDialogExample.f, 1.1, 1.2 MDIExample.f, 1.8, 1.9

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth/demos
In directory vz-cvs-4.sog:/tmp/cvs-serv7556

Modified Files:
	MDIDialogExample.f MDIExample.f 
Log Message:
Minor mods

Index: MDIExample.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/demos/MDIExample.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** MDIExample.f	10 Aug 2011 15:58:18 -0000	1.8
--- MDIExample.f	8 May 2012 20:42:52 -0000	1.9
***************
*** 66,73 ****
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! 200 value (NewID)
! : NewID ( <name> -- )   defined
          IF  drop
!         ELSE  count "header  (NewID)  dup 1+ to (NewID)  DOCON , ,
          THEN ;
  
--- 66,73 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! : NewID ( <name> -- )
!         defined
          IF  drop
!         ELSE NextID swap count ['] constant execute-parsing
          THEN ;
  

Index: MDIDialogExample.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/demos/MDIDialogExample.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** MDIDialogExample.f	21 Dec 2004 00:18:52 -0000	1.1
--- MDIDialogExample.f	8 May 2012 20:42:52 -0000	1.2
***************
*** 37,44 ****
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! 200 value (NewID)
! : NewID ( <name> -- )   defined
          IF  drop
!         ELSE  count "header  (NewID)  dup 1+ to (NewID)  DOCON , ,
          THEN ;
  
--- 37,44 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! : NewID ( <name> -- )
!         defined
          IF  drop
!         ELSE NextID swap count ['] constant execute-parsing
          THEN ;
  
***************
*** 287,289 ****
  
  
! go
\ No newline at end of file
--- 287,289 ----
  
  
! go