Menu
▾
▴
win32forth-cvs — CVS Commit List
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(70) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(38) |
Feb
(4) |
Mar
(11) |
Apr
(49) |
May
(81) |
Jun
(65) |
Jul
(36) |
Aug
(57) |
Sep
(63) |
Oct
(57) |
Nov
(49) |
Dec
(41) |
| 2006 |
Jan
(75) |
Feb
(80) |
Mar
(10) |
Apr
(13) |
May
(100) |
Jun
(100) |
Jul
(77) |
Aug
(87) |
Sep
(80) |
Oct
(124) |
Nov
(39) |
Dec
(41) |
| 2007 |
Jan
(20) |
Feb
(32) |
Mar
(32) |
Apr
(43) |
May
(146) |
Jun
(40) |
Jul
(49) |
Aug
(33) |
Sep
(25) |
Oct
(19) |
Nov
(11) |
Dec
(8) |
| 2008 |
Jan
(4) |
Feb
(11) |
Mar
(31) |
Apr
(40) |
May
(34) |
Jun
(24) |
Jul
(39) |
Aug
(104) |
Sep
(27) |
Oct
(35) |
Nov
(34) |
Dec
(97) |
| 2009 |
Jan
(75) |
Feb
(29) |
Mar
(45) |
Apr
(76) |
May
(121) |
Jun
(103) |
Jul
(67) |
Aug
(28) |
Sep
(22) |
Oct
(39) |
Nov
(9) |
Dec
(15) |
| 2010 |
Jan
(7) |
Feb
(39) |
Mar
(40) |
Apr
(57) |
May
(67) |
Jun
(69) |
Jul
(49) |
Aug
(68) |
Sep
(22) |
Oct
(7) |
Nov
(2) |
Dec
(10) |
| 2011 |
Jan
|
Feb
|
Mar
(10) |
Apr
(4) |
May
(6) |
Jun
(10) |
Jul
(16) |
Aug
(23) |
Sep
(9) |
Oct
|
Nov
(28) |
Dec
(3) |
| 2012 |
Jan
(11) |
Feb
(10) |
Mar
(1) |
Apr
|
May
(4) |
Jun
(3) |
Jul
(3) |
Aug
(4) |
Sep
(2) |
Oct
|
Nov
|
Dec
(1) |
| 2013 |
Jan
|
Feb
(7) |
Mar
(30) |
Apr
(4) |
May
(4) |
Jun
(8) |
Jul
(10) |
Aug
(4) |
Sep
|
Oct
(2) |
Nov
(24) |
Dec
(13) |
| 2014 |
Jan
(7) |
Feb
(2) |
Mar
|
Apr
(1) |
May
(9) |
Jun
|
Jul
(3) |
Aug
(9) |
Sep
|
Oct
(2) |
Nov
|
Dec
(3) |
| 2015 |
Jan
(4) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
(1) |
Oct
(4) |
Nov
(7) |
Dec
(39) |
| 2016 |
Jan
(17) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(1) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
(2) |
| 2017 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(1) |
Jun
(2) |
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
|
Dec
(2) |
| 2018 |
Jan
|
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2019 |
Jan
|
Feb
|
Mar
(1) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2022 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
(1) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
| 2025 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
|
|
From: George H. <geo...@us...> - 2013-03-07 16:19:50
|
Update of /cvsroot/win32forth/win32forth/Help In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv18417 Modified Files: HelpBuildHDB.f HelpMain.f HelpScope.f 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: HelpScope.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/Help/HelpScope.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** HelpScope.f 26 Feb 2012 20:01:35 -0000 1.8 --- HelpScope.f 7 Mar 2013 16:19:15 -0000 1.9 *************** *** 173,176 **** --- 173,178 ---- SrcScope: src\exceptio.f \ windows exception handling + SrcScope: src\CreateProcess.f \ common code REQUIREd by w32fmsg.f and Shell.f + SrcScope: src\w32fMsgList.f \ load win32forth-specific messages list SrcScope: src\w32fMsg.f \ load win32forth-specific messages Index: HelpMain.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/Help/HelpMain.f,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** HelpMain.f 17 Jan 2012 21:07:46 -0000 1.12 --- HelpMain.f 7 Mar 2013 16:19:15 -0000 1.13 *************** *** 164,168 **** DFILE HelpFct.hdb DummyFilename \ Functionality table DFILE HelpWrd.hdb DummyFilename \ words database ! DFILE HelpWrd.ndx DummyFilename \ words index DFILE HelpWrd.txt DummyFilename \ words quick info DFILE HelpWrd.tv DummyFilename \ words treeview-structure-text-file --- 164,168 ---- DFILE HelpFct.hdb DummyFilename \ Functionality table DFILE HelpWrd.hdb DummyFilename \ words database ! DFILE HelpWrd.hdx DummyFilename \ words index DFILE HelpWrd.txt DummyFilename \ words quick info DFILE HelpWrd.tv DummyFilename \ words treeview-structure-text-file *************** *** 211,218 **** New$ &ForthDir count 2 pick place ! s" Help\hdb\HelpWrd.ndx" 2 pick +place ! count HelpWrd.ndx FileName! ! HelpWrd.ndx fopen or ! HelpWrd.ndx fclose drop New$ &ForthDir count 2 pick place --- 211,218 ---- New$ &ForthDir count 2 pick place ! s" Help\hdb\HelpWrd.hdx" 2 pick +place ! count HelpWrd.hdx FileName! ! HelpWrd.hdx fopen or ! HelpWrd.hdx fclose drop New$ &ForthDir count 2 pick place *************** *** 429,436 **** : ReadNdx ( -- status ) \ status: =0 ok \ fill array of record with file's contents ! helpWrd.ndx fopen \ open file if 2 exit then ! filecells 2 cells helpWrd.ndx ReadSeq \ get file header ! if helpWrd.ndx fClose drop 4 exit then filecell1 @ #Wrd ! filecell2 @ 1+ WordName diSize ! \ dirty trick to resize --- 429,436 ---- : ReadNdx ( -- status ) \ status: =0 ok \ fill array of record with file's contents ! HelpWrd.hdx fopen \ open file if 2 exit then ! filecells 2 cells HelpWrd.hdx ReadSeq \ get file header ! if HelpWrd.hdx fClose drop 4 exit then filecell1 @ #Wrd ! filecell2 @ 1+ WordName diSize ! \ dirty trick to resize *************** *** 442,451 **** HelpWrd[] valloc ! 0 helpWrd.ndx FSEEK \ load whole file ! if helpWrd.ndx fClose drop 4 exit then 0 HelpWrd[] vaddr HelpWrd[] SizeOf ! helpWrd.ndx READSEQ ! if helpWrd.ndx fClose drop 4 exit then ! helpWrd.ndx fClose drop 0 ; (( --- 442,451 ---- HelpWrd[] valloc ! 0 HelpWrd.hdx FSEEK \ load whole file ! if HelpWrd.hdx fClose drop 4 exit then 0 HelpWrd[] vaddr HelpWrd[] SizeOf ! HelpWrd.hdx READSEQ ! if HelpWrd.hdx fClose drop 4 exit then ! HelpWrd.hdx fClose drop 0 ; (( Index: HelpBuildHDB.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/Help/HelpBuildHDB.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** HelpBuildHDB.f 18 Nov 2011 11:43:54 -0000 1.5 --- HelpBuildHDB.f 7 Mar 2013 16:19:15 -0000 1.6 *************** *** 371,375 **** \ ------------------------------------------------------------------------------ cr .( ) ! cr .( Building main help database HelpWrd.hdb and index HelpWrd.ndx) cr .( ) \ ------------------------------------------------------------------------------ --- 371,375 ---- \ ------------------------------------------------------------------------------ cr .( ) ! cr .( Building main help database HelpWrd.hdb and index HelpWrd.hdx) cr .( ) \ ------------------------------------------------------------------------------ *************** *** 976,980 **** \ ------------------------------------------------------------------------------ ! cr .( A bit of housekeeping for HelpWrd.hdb and create HelpWrd.ndx from tWrdList...) \ ------------------------------------------------------------------------------ --- 976,980 ---- \ ------------------------------------------------------------------------------ ! cr .( A bit of housekeeping for HelpWrd.hdb and create HelpWrd.hdx from tWrdList...) \ ------------------------------------------------------------------------------ *************** *** 996,1000 **** ! cr .( Creating HelpWrd.ndx from tWrdList...) \ ------------------------------------------ --- 996,1000 ---- ! cr .( Creating HelpWrd.hdx from tWrdList...) \ ------------------------------------------ *************** *** 1046,1050 **** ! cr .( Sorting HelpWrd.ndx by ascending words...) cr .( [there may exist multiple keys, eg methods, same words in different vocs, etc]) \ ----------------------------------------------------------------------------- --- 1046,1050 ---- ! cr .( Sorting HelpWrd.hdx by ascending words...) cr .( [there may exist multiple keys, eg methods, same words in different vocs, etc]) \ ----------------------------------------------------------------------------- *************** *** 1070,1074 **** \ For now the WordExtra field contains (only for methods) the n0 of the record in \ HelpWrd.hdb of the method's parent. Here we replace this by the n0 of the record ! \ in HelpWrd.ndx itself. This must be done AFTER index sorting, so that n0records \ in index will remain unchanged from now on. --- 1070,1074 ---- \ For now the WordExtra field contains (only for methods) the n0 of the record in \ HelpWrd.hdb of the method's parent. Here we replace this by the n0 of the record ! \ in HelpWrd.hdx itself. This must be done AFTER index sorting, so that n0records \ in index will remain unchanged from now on. *************** *** 1112,1127 **** \ save index to file ! DFILE tHelpWrd.ndx DummyFilename \ file on disk NoStack New$ &ForthDir count 2 pick place \ set file name ! s" Help\hdb\HelpWrd.ndx" 2 pick +place ! count tHelpWrd.ndx FileName! ! \ tHelpWrd.ndx .filename ! tHelpWrd.ndx fforcecreate 0<> [IF] -1 abort" Couldn't create tHelpWrd.ndx" [THEN] ! tHelpWrd.ndx fopen 0<> [IF] -1 abort" Couldn't open tHelpWrd.ndx" [THEN] NoStack 0 tHelpWrd[] vaddr tHelpWrd[] SizeOf ! tHelpWrd.ndx WRITESEQ 0<> [IF] -1 abort" Write error in tHelpWrd.ndx" [THEN] ! tHelpWrd.ndx fClose drop --- 1112,1127 ---- \ save index to file ! DFILE tHelpWrd.hdx DummyFilename \ file on disk NoStack New$ &ForthDir count 2 pick place \ set file name ! s" Help\hdb\HelpWrd.hdx" 2 pick +place ! count tHelpWrd.hdx FileName! ! \ tHelpWrd.hdx .filename ! tHelpWrd.hdx fforcecreate 0<> [IF] -1 abort" Couldn't create tHelpWrd.hdx" [THEN] ! tHelpWrd.hdx fopen 0<> [IF] -1 abort" Couldn't open tHelpWrd.hdx" [THEN] NoStack 0 tHelpWrd[] vaddr tHelpWrd[] SizeOf ! tHelpWrd.hdx WRITESEQ 0<> [IF] -1 abort" Write error in tHelpWrd.hdx" [THEN] ! tHelpWrd.hdx fClose drop *************** *** 1444,1448 **** ! \ Check in HelScope.f the hidden vocabularies and files that you will retreive \ from the following search. : PreBuildFct ( -- ) --- 1444,1448 ---- ! \ Check in HelpScope.f the hidden vocabularies and files that you will retrieve \ from the following search. : PreBuildFct ( -- ) *************** *** 1501,1505 **** \ ------------------------------------------------------------------------------ ! \ HelpWrd.hdb and HelpWrd.ndx are now finished. \ We also have a little part of the tv-structure-text-file (for top down classes) \ Now, we have to create the whole tv-structure-text-file --- 1501,1505 ---- \ ------------------------------------------------------------------------------ ! \ HelpWrd.hdb and HelpWrd.hdx are now finished. \ We also have a little part of the tv-structure-text-file (for top down classes) \ Now, we have to create the whole tv-structure-text-file |
|
From: George H. <geo...@us...> - 2013-03-07 16:19:23
|
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 --- |
|
From: George H. <geo...@us...> - 2013-03-07 15:36:24
|
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 ---- |
|
From: George H. <geo...@us...> - 2013-03-07 15:29:05
|
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 |
|
From: George H. <geo...@us...> - 2013-03-05 20:46:04
|
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 |
|
From: Jos v.d.V. <jo...@us...> - 2013-02-21 01:09:59
|
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 ; |
|
From: Jos v.d.V. <jo...@us...> - 2013-02-21 01:05:37
|
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 ; |
|
From: Jos v.d.V. <jo...@us...> - 2013-02-20 22:10:17
|
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 ; ! |
|
From: Jos v.d.V. <jo...@us...> - 2013-02-20 21:56:33
|
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 ; |
|
From: George H. <geo...@us...> - 2013-02-14 20:05:50
|
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 ; |
|
From: George H. <geo...@us...> - 2013-02-14 19:25:22
|
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 |
|
From: George H. <geo...@us...> - 2013-02-14 19:07:45
|
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><name></td> <td>name to be parsed from input stream</td> ! <td><code>VARIABLE \ Comp: ( <name> -- ) Run name: ( -- addr )</code></td> </tr> <tr> --- 79,91 ---- </thead> <tbody> ! <tr> <td><name></td> <td>name to be parsed from input stream</td> ! <td><code>VARIABLE \ Comp: ( <name> -- ) Run time: ( -- addr )</code></td> ! </tr> ! <tr> ! <td>"name"</td> ! <td>name to be parsed from input stream</td> ! <td><code>VALUE \ Comp: ( "name" -- ) 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> |
|
From: Rod O. <rod...@us...> - 2012-12-24 16:16:47
|
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 |
|
From: Jos v.d.V. <jo...@us...> - 2012-09-23 13:45:18
|
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
|
|
From: Jos v.d.V. <jo...@us...> - 2012-09-19 15:27:11
|
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
|
|
From: George H. <geo...@us...> - 2012-08-14 14:20:13
|
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> NEW$ </i>. </p><p><b><code>:M Setfont: ( 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: ( 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> n </i> 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: ( handle -- ) </code></b><br>Set the font in the control. *************** *** 600,608 **** </p><p><b><code>:M GetString: ( 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> n </i> 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> NEW$ </i>. </p><p><b><code>:M GetCount: ( -- n ) </code></b><br>Retrieve the number of items in the list box. --- 609,618 ---- </p><p><b><code>:M GetString: ( 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> n </i> 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: ( -- n ) </code></b><br>Retrieve the number of items in the list box. |
|
From: George H. <geo...@us...> - 2012-08-14 14:18:09
|
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
|
|
From: George H. <geo...@us...> - 2012-08-14 14:10:11
|
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 ) |
|
From: George H. <geo...@us...> - 2012-08-14 13:27:24
|
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
|
|
From: George H. <geo...@us...> - 2012-07-18 12:47:30
|
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: ( 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&CONTROL <SUPER Generic-Window - </code></b><br>Base class for all dialog and control objects. - </p><p>Since DIALOG&CONTROL is a generic class it should not be used to create - any instances. - </p><p><b><code>:M Classinit: ( -- ) - </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&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 <Super Dialog&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 <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 <SUPER Dialog&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 <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 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! 200 value (NewID) ! : NewID ( <name> -- ) defined IF drop ! ELSE count "header (NewID) dup 1+ to (NewID) DOCON , , THEN ; --- 205,212 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! : NewID ( <name> -- ) ! defined IF drop ! ELSE NextID swap count ['] constant execute-parsing THEN ; |
|
From: George H. <geo...@us...> - 2012-07-18 12:34:29
|
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
|
|
From: George H. <geo...@us...> - 2012-06-09 18:45:50
|
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 ----
|
|
From: Jos v.d.V. <jo...@us...> - 2012-06-06 16:24:36
|
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
|
|
From: Jos v.d.V. <jo...@us...> - 2012-06-06 14:40:53
|
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
|
|
From: George H. <geo...@us...> - 2012-05-08 20:57:40
|
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 ;
|
1040 messages has been excluded from this view by a project administrator.
