Menu
▾
▴
[Win32forth-cvs] win32forth/apps/Chess TOOLSET.F,1.4,1.5
|
From: Jos v.d.V. <jo...@us...> - 2005-05-29 23:26:45
|
Update of /cvsroot/win32forth/win32forth/apps/Chess In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17048/win32forth/apps/Chess Modified Files: TOOLSET.F Log Message: Jos: Added: context>current and all-warnings-off Index: TOOLSET.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Chess/TOOLSET.F,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** TOOLSET.F 14 May 2005 11:40:20 -0000 1.4 --- TOOLSET.F 29 May 2005 23:26:32 -0000 1.5 *************** *** 1,3 **** ! (( May 27th, 2004 by J.v.d.Ven. ( http://home.planet.nl/~josv ) Needed compiler Win32forth version 4.2 build 0671. Objective: extend Win32forth with my old fashion tools from --- 1,3 ---- ! (( May 30th, 2005 by J.v.d.Ven. ( http://home.planet.nl/~josv ) Needed compiler Win32forth version 4.2 build 0671. Objective: extend Win32forth with my old fashion tools from *************** *** 7,25 **** Perhaps you will hate it. That's ok ! Modifications: in this version: ! ! \ Solved a bug in set-priority ! \ Additions are made at the end. ! )) ! Forth s" Win32Forth" environment? not [if] cr .( Needs Win32Forth version 4.2 build 0671 or better.) abort [then] drop ! INTERNAL WinLibrary WINMM.DLL EXTERNAL ! only forth definitions decimal anew toolset.f --- 7,23 ---- Perhaps you will hate it. That's ok ! Note: Needs Win32Forth 6.11.xx version. ! Modifications: in this version: ! Added: context>current and all-warnings-off ! \ Additions are made at the end. )) s" Win32Forth" environment? not [if] cr .( Needs Win32Forth version 4.2 build 0671 or better.) abort [then] drop ! INTERNAL WinLibrary WINMM.DLL EXTERNAL PREVIOUS ! decimal anew toolset.f *************** *** 31,38 **** 27 constant escape 34 constant quote synonym read r/o synonym write r/w synonym erase-screen cls synonym ?ms ms@ synonym d dir synonym >>> noop ! synonym PRIVATES noop synonym PRIVATE noop \ synonym Private: noop synonym Public: noop synonym DEPRIVE noop synonym ;P ; --- 29,41 ---- 27 constant escape 34 constant quote + : all-warnings-off ( -- ) dpr-warning-off sys-warning-off warning off ; + : all-warnings-on ( -- ) dpr-warning-on sys-warning-on warning on ; + + all-warnings-off + synonym read r/o synonym write r/w synonym erase-screen cls synonym ?ms ms@ synonym d dir synonym >>> noop ! synonym PRIVATES noop \ synonym Private: noop synonym Public: noop synonym DEPRIVE noop synonym ;P ; *************** *** 42,47 **** --- 45,58 ---- synonym -s r>drop synonym lo bye + defined &local nip not [IF] + synonym &local &of + [THEN] + ' \ alias ** + in-system + + in-application + : reversed ( - ) 16777215 1 fgbg! ; : normal ( - ) 1 -1 fgbg! ; *************** *** 50,54 **** : bin ( - ) 2 base ! ; : missing ( - ) abort" missing" ; ! : tp ( - ) .s key escape = if abort then cr ; : ftp ( - ) f.s key escape = if abort then cr ; : always ( flag - true ) drop true ; --- 61,65 ---- : bin ( - ) 2 base ! ; : missing ( - ) abort" missing" ; ! : tp ( - ) .s key escape = if abort then cr ; : ftp ( - ) f.s key escape = if abort then cr ; : always ( flag - true ) drop true ; *************** *** 91,96 **** MB_OK MB_ICONSTOP or MB_TASKMODAL or ! z" Error:" ! message$ 1+ NULL call MessageBox drop ; --- 102,107 ---- MB_OK MB_ICONSTOP or MB_TASKMODAL or ! z" Error:" ! message$ 1+ NULL call MessageBox drop ; *************** *** 135,139 **** : (ABORT") ( f -- ) \ _.rstack ! 2r@ at-word ! drop ((")) SWAP IF MSG ! THROW_ABORTQ THROW --- 146,150 ---- : (ABORT") ( f -- ) \ _.rstack ! 2r@ abs>rel at-word ! drop ((")) SWAP IF MSG ! THROW_ABORTQ THROW *************** *** 147,152 **** : test2 test ; ! test2 \ ! )) : here! ( n - ) here ! ; --- 158,162 ---- : test2 test ; ! test2 \ )) : here! ( n - ) here ! ; *************** *** 178,182 **** drop ; ! \ 1234 here ! here 10 cadump abort --- 188,192 ---- drop ; ! \ 1234 here ! here 10 cadump abort *************** *** 187,191 **** synonym local to \ NOTE define the local as value before using local - synonym fsqr fsqrt synonym pi fpi --- 197,200 ---- *************** *** 507,511 **** time-buf 2 + w! \ month time-buf 6 + w! \ day ! hld-max hld 0 time-buf r> LOCALE_SYSTEM_DEFAULT call GetDateFormat dup 0= abort" ldate failed" hld-count --- 516,520 ---- time-buf 2 + w! \ month time-buf 6 + w! \ day ! hld-max hld 0 time-buf r> LOCALE_SYSTEM_DEFAULT call GetDateFormat dup 0= abort" ldate failed" hld-count *************** *** 517,521 **** : ltime ( time-buf - adr count ) \ time-buf must be filled ! hld-max hld 0 time-buf TIME_FORCE24HOURFORMAT LOCALE_SYSTEM_DEFAULT call GetTimeFormat dup 0= abort" ltime failed" hld-count --- 526,530 ---- : ltime ( time-buf - adr count ) \ time-buf must be filled ! hld-max hld 0 time-buf TIME_FORCE24HOURFORMAT LOCALE_SYSTEM_DEFAULT call GetTimeFormat dup 0= abort" ltime failed" hld-count *************** *** 656,705 **** : empty_key_buf ( - ) key? if key drop then ; - : fchoose 100000 * random s>f 100000e f/ ; \ <n> --- <> F: <> --- <r> - \ : fvalue-to-string \ ( adr - ) fs: ( n - ) \ Borrowed from f. - \ >r 0 r@ c! \ Now it puts a float in a string - \ fdepth 0 <= - \ IF ." Empty " r> drop EXIT - \ THEN - \ precision 1 max set-precision - \ fexam 0x0200 and - \ IF fabs s" -" r@ +place - \ THEN - \ fdup f0.5 f< - \ IF s" ." r@ +place f1.0 f+ $ftemp - \ precision 1+ maxsig umin - \ represent - \ drop drop drop - \ $ftemp 1+ precision maxsig 1- umin - \ r@ +place s" " r@ +place - \ ELSE $ftemp precision represent 0= - \ IF drop drop $ftemp precision - \ r@ +place s" " r@ +place - \ ELSE drop dup precision < - \ IF dup 0= - \ IF drop s" ." r@ +place - \ $ftemp precision - \ r@ +place s" " r> +place EXIT - \ THEN - \ $ftemp over r@ +place s" ." r@ +place - \ $ftemp over + swap precision - \ swap - r@ +place s" " r@ +place - \ ELSE dup precision = - \ IF $ftemp swap r@ +place - \ s" . " r> +place - \ EXIT - \ THEN - \ $ftemp precision r@ +place r@ pad ! - \ precision - 0 - \ DO s" 0" pad @ +place - \ LOOP - \ s" . " r@ +place - \ THEN - \ THEN - \ THEN r> drop ; ! ' (f.) alias fvalue-to-string ! : string>float \ ( adr - f ) FS: ( - n ) \ Note: 0 on FS when f is false count >float dup not --- 665,675 ---- : empty_key_buf ( - ) key? if key drop then ; ! \ : fchoose 100000 * random s>f 100000e f/ ; ( <n> --- <> F: <> --- <r> ) ! \ 2024 .s abort ! ! synonym fvalue-to-string (F.) ! : string>float \ ( adr - f ) FS: ( - n ) \ Note: 0 on FS when f is false count >float dup not *************** *** 716,719 **** --- 686,690 ---- ; + \ 1.5e2 fvalue aa \ 10 string: Aa$ Aa$ string" foo" *************** *** 793,797 **** : screen-only ( - ) ! ['] _mtype is type ['] _emit is emit ['] crtab is cr ; : emit-to-file ( - ) --- 764,768 ---- : screen-only ( - ) ! ['] _mtype is type ['] _memit is emit ['] crtab is cr ; : emit-to-file ( - ) *************** *** 819,827 **** 0 \ last written time and date not needed 0 \ last access time not needed ! file-time-buf-created \ creation time needed r> call GetFileTime drop ! _systemtime \ where to put results ! file-time-buf \ file time/date to convert call FileTimeToSystemTime drop _systemtime ; --- 790,798 ---- 0 \ last written time and date not needed 0 \ last access time not needed ! file-time-buf-created \ creation time needed r> call GetFileTime drop ! _systemtime \ where to put results ! file-time-buf \ file time/date to convert call FileTimeToSystemTime drop _systemtime ; *************** *** 833,837 **** 0 value bufcnt 0 value buffer ! : init-buffer ( - ) 2024 DynAlloc to buffer ; init-buffer initialization-chain chain-add init-buffer --- 804,808 ---- 0 value bufcnt 0 value buffer ! : init-buffer ( - ) td 2024 DynAlloc to buffer ; init-buffer initialization-chain chain-add init-buffer *************** *** 889,906 **** : OpenProcessToken ( - token ) ! here TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY or call GetCurrentProcess call OpenProcessToken drop here @ ; : GetEnvironmentVariable ( zstr-EnvironmentVariable-name buffer n - adr n ) ! swap dup >r rot call GetEnvironmentVariable r> swap ; : SetEnvironmentVariable ( zstr-EnvironmentVariable-name buffer n - ) ! pad +place pad dup +null 1+ swap call SetEnvironmentVariable drop ; : DelEnvironmentVariable ( zstr-EnvironmentVariable-name - ) ! 0 pad ! pad swap call SetEnvironmentVariable drop ; --- 860,877 ---- : OpenProcessToken ( - token ) ! here TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY or call GetCurrentProcess call OpenProcessToken drop here @ ; : GetEnvironmentVariable ( zstr-EnvironmentVariable-name buffer n - adr n ) ! swap dup >r rot call GetEnvironmentVariable r> swap ; : SetEnvironmentVariable ( zstr-EnvironmentVariable-name buffer n - ) ! pad +place pad dup +null 1+ swap call SetEnvironmentVariable drop ; : DelEnvironmentVariable ( zstr-EnvironmentVariable-name - ) ! 0 pad ! pad swap call SetEnvironmentVariable drop ; *************** *** 910,923 **** z" TEST" DelEnvironmentVariable z" TEST" s" 2Hello" setEnvironmentVariable ! z" TEST" buffer 256 GetEnvironmentVariable cr dump abort ! )) : computername$! ( adr - ) \ March 30th, 2002 was GetComputerName ! 100 pad ! pad \ lpszName ! over 1+ \ lpdwbuffer call GetComputerName drop pad @ swap c! ; : username$! ( adr - ) \ March 30th, 2002 was GetUserName ! 100 pad! pad over 1+ call GetUserName drop pad@ 1- swap c! ; --- 881,893 ---- z" TEST" DelEnvironmentVariable z" TEST" s" 2Hello" setEnvironmentVariable ! z" TEST" buffer 256 GetEnvironmentVariable cr dump abort )) : computername$! ( adr - ) \ March 30th, 2002 was GetComputerName ! 100 pad ! pad \ lpszName ! over 1+ \ lpdwbuffer call GetComputerName drop pad @ swap c! ; : username$! ( adr - ) \ March 30th, 2002 was GetUserName ! 100 pad! pad over 1+ call GetUserName drop pad@ 1- swap c! ; *************** *** 939,943 **** title$ place title$ +NULL r> ! title$ 1+ message$ 1+ NULL call MessageBox ; --- 909,913 ---- title$ place title$ +NULL r> ! title$ 1+ message$ 1+ NULL call MessageBox ; *************** *** 961,965 **** 0 do i to-cell tmp-array loop ; ! : nrel>abs ( start end -- ...abs ) swap do i tmp-array loop ; (( DWORD lpAppName, // points to section name --- 931,935 ---- 0 do i to-cell tmp-array loop ; ! : n ( start end -- ...abs ) swap do i tmp-array loop ; (( DWORD lpAppName, // points to section name *************** *** 968,985 **** LPTSTR lpReturnedString, // points to destination buffer DWORD nSize, // size of destination buffer ! LPCTSTR lpFileName // points to initialization filename ! )) \ lpReturnedString will contain a counted string with a 0 at the end : GetPrivateProfileString ( lpAppName lpKeyName lpDefault lpReturnedString nSize lpFileName - ncopied ) ! 1+ 6 to-tmp-array 0 tmp-array 1 tmp-array 2 tmp-array dup >r 1+ ! 3 6 nrel>abs call GetPrivateProfileString r> c! ; : WritePrivateProfileString ( lpAppName lpKeyName lpString lpFileName - flag ) ! 1+ 4 to-tmp-array 0 4 nrel>abs call WritePrivateProfileString 0= abort" Failed to write profile string." ; - create profile$ 256 allot --- 938,953 ---- LPTSTR lpReturnedString, // points to destination buffer DWORD nSize, // size of destination buffer ! LPCTSTR lpFileName // points to initialization filename )) \ lpReturnedString will contain a counted string with a 0 at the end : GetPrivateProfileString ( lpAppName lpKeyName lpDefault lpReturnedString nSize lpFileName - ncopied ) ! 1+ 6 to-tmp-array 0 tmp-array 1 tmp-array 2 tmp-array dup >r 1+ ! 3 6 n call GetPrivateProfileString r> c! ; : WritePrivateProfileString ( lpAppName lpKeyName lpString lpFileName - flag ) ! 1+ 4 to-tmp-array 0 4 n call WritePrivateProfileString 0= abort" Failed to write profile string." ; create profile$ 256 allot *************** *** 1000,1005 **** test_WritePrivateProfileString ! test_GetPrivateProfileString profile$ .string \ ! )) : s>tmp$ ( n - adr ) s>d (d.) tmp$ place tmp$ dup 0terminated 1+ ; --- 968,972 ---- test_WritePrivateProfileString ! test_GetPrivateProfileString profile$ .string \ )) : s>tmp$ ( n - adr ) s>d (d.) tmp$ place tmp$ dup 0terminated 1+ ; *************** *** 1063,1070 **** : ndebug ( - ) \ shows the normal stack while debugging ! ['] .s-base is debug-.s ; previous previous \ August 21st, 2001 - 11:50 --- 1030,1038 ---- : ndebug ( - ) \ shows the normal stack while debugging ! ['] .s-base is debug-.s ; previous previous + \ August 21st, 2001 - 11:50 *************** *** 1140,1145 **** : test foo foo + . ; ! cr see test test \ ! )) --- 1108,1112 ---- : test foo foo + . ; ! cr see test test \ )) *************** *** 1190,1194 **** : sounds ( z"sound-file" - ) sounds_on/off ! if SND_FILENAME NULL rot call PlaySound then drop ; \ October 22nd, 2001 - 23:46 --- 1157,1161 ---- : sounds ( z"sound-file" - ) sounds_on/off ! if SND_FILENAME NULL rot call PlaySound then drop ; \ October 22nd, 2001 - 23:46 *************** *** 1196,1207 **** also hidden - \ The following 2 definitions allows access to the entire registry. - \ They are copied from registry.f with a few small changes. - variable disposition variable regkey variable regtype variable reglen ! named-new$ ReturnedKey$ \ sadr,slen = the registry section to get the key of --- 1163,1173 ---- also hidden variable disposition variable regkey variable regtype variable reglen ! ! \ The following 2 definitions allows access to the entire registry. ! \ They are copied from registry.f with a few small changes. \ sadr,slen = the registry section to get the key of *************** *** 1220,1224 **** NULL 0 ! key$ 1+ r> \ root-key Call RegCreateKeyEx --- 1186,1190 ---- NULL 0 ! key$ 1+ r> \ root-key Call RegCreateKeyEx *************** *** 1241,1249 **** then >r drop >r MAXCOUNTED reglen ! \ init max length of string ! reglen ! ReturnedKey$ 1+ ! regtype 0 ! r> r@ Call RegQueryValueEx --- 1207,1215 ---- then >r drop >r MAXCOUNTED reglen ! \ init max length of string ! reglen ! ReturnedKey$ 1+ ! regtype 0 ! r> r@ Call RegQueryValueEx *************** *** 1263,1268 **** \ ( w2k) GetRegistryEntry drop ? ." Mhz" cr ; ! test_reg$ \ ! )) \ November 3rd, 2001 - 21:19 added: u,. ?u,. ?u,.cr --- 1229,1233 ---- \ ( w2k) GetRegistryEntry drop ? ." Mhz" cr ; ! test_reg$ \ )) \ November 3rd, 2001 - 21:19 added: u,. ?u,. ?u,.cr *************** *** 1342,1347 **** ^ ^ REG PTR EBX --> <-- ECX ! ESP OFFSET 16 12 8 4 0 ! )) --- 1307,1311 ---- ^ ^ REG PTR EBX --> <-- ECX ! ESP OFFSET 16 12 8 4 0 )) *************** *** 1365,1383 **** next c; - - \ October 15th, 2002, "Lcc Wizard" Gave me a 2nip in assembler - - CODE 2nip ( n1 n2 n3 n4 -- n3 n4 ) \ 2swap 2drop - pop eax - mov 4 [esp], eax - pop eax - next c; - \ October 7th, 2002 - 10:12 ! : mkdir ( pSecurityAttributes z"path" - ior ) call CreateDirectory ; \ Empty the directory before using rd ! : rd ( z"path" - ior ) call RemoveDirectory ; : -string ( adr1 cnt1 adr2 cnt2 - adr1+cnt2 cnt1-cnt2 ) --- 1329,1338 ---- next c; \ October 7th, 2002 - 10:12 ! : mkdir ( pSecurityAttributes z"path" - ior ) call CreateDirectory ; \ Empty the directory before using rd ! : rd ( z"path" - ior ) call RemoveDirectory ; : -string ( adr1 cnt1 adr2 cnt2 - adr1+cnt2 cnt1-cnt2 ) *************** *** 1527,1531 **** [3] -1087358 3 -1 4293879938 45 53 74 ESt ok ! )) \ June 8th, 2003 --- 1482,1486 ---- [3] -1087358 3 -1 4293879938 45 53 74 ESt ok ! )) \ June 8th, 2003 *************** *** 1538,1542 **** &InfoRect 3 cells+ constant height ! : windowposition ( hWnd - ) &InfoRect swap Call GetWindowRect ?win-error ; 250 string: inifile$ --- 1493,1497 ---- &InfoRect 3 cells+ constant height ! : windowposition ( hWnd - ) &InfoRect swap Call GetWindowRect ?win-error ; 250 string: inifile$ *************** *** 1561,1565 **** [then] \s ! |
