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
|
Dec
|
|
From: George H. <geo...@us...> - 2006-09-25 11:44:37
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6187/win32forth/src/lib Modified Files: task.f Log Message: gah:Minor spelling corrections. Index: task.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/task.f,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** task.f 5 Aug 2006 12:30:52 -0000 1.11 --- task.f 25 Sep 2006 11:44:34 -0000 1.12 *************** *** 80,84 **** cfa-code BEGIN-TASK ( -- ) \ thread management. init a new thread/task ! push ebp \ save regs push ebx push edi --- 80,84 ---- cfa-code BEGIN-TASK ( -- ) \ thread management. init a new thread/task ! push ebp \ save regs push ebx push edi *************** *** 96,100 **** \ -------------------- Task Management -------------------- ! : (create-task) ( thread state -- flag ) \ create a task swap \ state addr dup task>stop off \ turn off stop flag --- 96,100 ---- \ -------------------- Task Management -------------------- ! : (create-task) ( thread state -- flag ) \ create a task swap \ state addr dup task>stop off \ turn off stop flag |
|
From: George H. <geo...@us...> - 2006-09-25 11:43:02
|
Update of /cvsroot/win32forth/win32forth/doc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5416/win32forth/doc Modified Files: Paths.htm p-index.htm Log Message: gah:Updated docs Index: p-index.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/p-index.htm,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** p-index.htm 21 Sep 2006 13:12:41 -0000 1.17 --- p-index.htm 25 Sep 2006 11:42:57 -0000 1.18 *************** *** 156,159 **** --- 156,160 ---- <li><a href="p-AcceleratorTables.htm">Accelerator tables</a></li> <li><a href="Paths.htm">Multiple search path support</a></li> + <li><a href="p-ansfile.htm">File and directory searching words</a></li> <li><a href="Unicode.htm">Unicode Strings (for use with FCOM)</a></li> <li><a href="p-relnotes.6.12.htm">Release Notes</a></li> Index: Paths.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/Paths.htm,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** Paths.htm 29 Aug 2006 10:31:46 -0000 1.6 --- Paths.htm 25 Sep 2006 11:42:57 -0000 1.7 *************** *** 1,6 **** ! <html> <head> ! <meta http-equiv="Content-Language" content="en-gb"> ! <meta name="GENERATOR" content="dexh00"> <meta name="ProgId" content="FrontPage.Editor.Document"> <meta http-equiv="Content-Type" content="text/html; charset=windows-1252"> --- 1,8 ---- ! <?xml version="1.0"?> ! <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" ! "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> ! <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> ! <meta name="GENERATOR" content="dexh v03"> <meta name="ProgId" content="FrontPage.Editor.Document"> <meta http-equiv="Content-Type" content="text/html; charset=windows-1252"> *************** *** 30,44 **** </p><pre><b><a name="5">: .dir ( -- ) </a></b></pre><p>Print the current directory. ! </p><pre><b><a name="6">: chdir ( -<optional_new_directory>- ) </a></b></pre><p>Set the current directory. ! </p><pre><b><a name="7">: path: ( - ) </a></b></pre><p>Defines a directory search path. <br /> The first 2 cells are used too handle a search path. <br /> The next 260 bytes are reserved for a counted string of a path. <br /> ! followed by 0. <br /> ! In runtime it returns adres of the counted string of a path ! </p><pre><b><a name="8">: path-source ( path - 2variable_path-source ) </a></b></pre><p>Path-source points to a substring in a path. <br /> ! Path-source returns this adress. </p><pre><b><a name="9">path: path-ptr deprecated </a></b></pre><p>The old functionality had the bad habbit to pass a pointer through a --- 32,46 ---- </p><pre><b><a name="5">: .dir ( -- ) </a></b></pre><p>Print the current directory. ! </p><pre><b><a name="6">: chdir ( -<optional_new_directory>- -- ) </a></b></pre><p>Set the current directory. ! </p><pre><b><a name="7">: path: ( -- ) </a></b></pre><p>Defines a directory search path. <br /> The first 2 cells are used too handle a search path. <br /> The next 260 bytes are reserved for a counted string of a path. <br /> ! followed by null. <br /> ! At runtime it returns address of the counted string of a path ! </p><pre><b><a name="8">: path-source ( path -- 2variable_path-source ) </a></b></pre><p>Path-source points to a substring in a path. <br /> ! Path-source returns this address. </p><pre><b><a name="9">path: path-ptr deprecated </a></b></pre><p>The old functionality had the bad habbit to pass a pointer through a *************** *** 66,71 **** </p><pre><b><a name="18">: .fpath ( -- ) </a></b></pre><p>Display the Forth directory search path list. ! </p><pre><b><a name="19">: volume-indication? ( adr - flag ) ! </a></b></pre><p>True when the counted string at adr starts with x: or \name </p><pre><b><a name="20">: full-path { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 } </a></b></pre><p>Find file a1,n1 in a path and return the full path. <br /> --- 68,73 ---- </p><pre><b><a name="18">: .fpath ( -- ) </a></b></pre><p>Display the Forth directory search path list. ! </p><pre><b><a name="19">: volume-indication? ( addr -- flag ) ! </a></b></pre><p>True when the counted string at addr starts with x: or \name </p><pre><b><a name="20">: full-path { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 } </a></b></pre><p>Find file a1,n1 in a path and return the full path. <br /> *************** *** 103,108 **** </p><pre><b><a name="34">synonym Require needs </a></b></pre><p>Forth 200X name for needs. ! </p><pre><b><a name="35">: "file-clip" { adr len limit \ temp$ pre -- 'adr 'len } ! </a></b></pre><p>Clip filename to limit. </p><hr><p>Document $Id$</p> </body></html> --- 105,113 ---- </p><pre><b><a name="34">synonym Require needs </a></b></pre><p>Forth 200X name for needs. ! </p><pre><b><a name="35">: "file-clip" { addr len limit | temp$ pre -- addr len2 } ! </a></b></pre><p>Clip filename to limit. If limit is less than 20 then the filename is clipped to ! 20. len2=len if len < limit or len < 20. len2 = 20 if limit < 20. len2 = limt ! otherwise. The string (if clipped) contains ... in the middle to indicate that# ! it has been clipped. </p><hr><p>Document $Id$</p> </body></html> |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:42:09
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13537/src Modified Files: extend.f primutil.f Added Files: ANSFILE.F Log Message: AnsFile.f added Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** primutil.f 23 Sep 2006 15:49:12 -0000 1.3 --- primutil.f 24 Sep 2006 08:42:06 -0000 1.4 *************** *** 200,207 **** r> to sys-warning? throw ; immediate ! \s \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own \ primutil.f and hopefully merged everything correctly but can't test @ work so any \ other corrections will have to wait til mon 23/9/6 gah. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 200,208 ---- r> to sys-warning? throw ; immediate ! \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own \ primutil.f and hopefully merged everything correctly but can't test @ work so any \ other corrections will have to wait til mon 23/9/6 gah. + \ It's seem's to work for me, so I have added ansfile.f to the CVS (Sonntag, September 24 2006 dbu) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- NEW FILE: ANSFILE.F --- \ $Id: ANSFILE.F,v 1.1 2006/09/24 08:42:06 dbu_de Exp $ \ *P These words are extensions to the ANSI file words for finding files. \ The ANSI words are defined in the kernel. \ \ The words defined in this file follow the draft proposed AMERICAN \ NATIONAL Standard for Information System - Programing Language - Forth \ - June 30, 1993 \ \ ** If ior = 0, operation is O.K.; Otherwse, it is a failure. \ ansfile.f beta 2.0A 2002/08/31 arm windows ANS file words \ ansfile.f beta 2.9G 2002/09/24 arm release for testing \ ansfile.f beta 3.3D 2002/10/08 arm Consolidation \ made thread-safe Saturday, August 07 2004 - 0:15 gah cr .( Loading ANSI File Wordset...) only forth also definitions 5 PROC GetDiskFreeSpace 2 PROC FindFirstFile 2 PROC FindNextFile 1 PROC FindClose 3 PROC FileTimeToDosDateTime 4 PROC GetFileTime 2 PROC FileTimeToSystemTime cell newuser _hdl-search ( -- addr ) \ *G Variable holding handle. _hdl-search off cell newuser #files \ number of files found cell newuser total-file-bytes \ total bytes in files found 11 cells max-path + 14 + nostack1 newuser _win32-find-data \ struct FindFileFirst or \ FindNextFile Functions \ 0 , \ dwFile Attributees \ 0 , 0 , \ ftCreationTime - FILETIME - \ \ (struct) dwLowDateTime \ \ dwHighDateTime \ 0 , 0 , \ ftLastAccessTime - FILETIME \ 0 , 0 , \ ftLastWriteTime - FILETIME \ 0 , \ nFileSizeHigh \ 0 , \ nFileSizeLowh \ 0 , \ dwReserved0 \ 0 , \ dwReserved1 \ MAX-PATH allot \ cFileName[MAX_PATH] \ 14 allot \ cAlternateFileNane[14] 2 newuser ptr-DOS-date \ ptr to 16 bit DOS date 2 newuser ptr-DOS-time \ ptr to 16 bit DOS time 16 Constant sizeof(_systemTime) 0 newuser _systemtime \ *G Structure FileTimeToSystemTime \ ** function; this struc is same as time-buf in kernel.tom 2 newuser wYear 2 newuser wMonth 2 newuser wDayOfWeek 2 newuser wDay 2 newuser wHour 2 newuser wMinute 2 newuser wSecond 2 newuser wMilliseconds : get-fspace { zroot \ clus freclus b/sec s/clus -- as bs cs ds } \ *G Get a drive's free space, cluster and sector information \ ** "zroot" is the root directory spec zString for the desired drive in the \ ** format z" x:\", where x can be a, b, c, d or e etc... &of clus \ lpClusters - bs &of freclus \ lpFreeClusters - as &of b/sec \ loBytesPerSector - ds &of s/clus \ lpSectorsPerCluster - cs zroot \ lpszRootPathName call GetDiskFreeSpace if freclus clus \ as bs - s/clus b/sec \ as bs cs ds - else 0 0 0 0 \ 0 0 0 0 - for failure then ; : find-first-file ( addr1 len1 -- addr2 ior ) \ *G addr1 len1 is a string that specifies a valid directory or path \ ** and filename, which can contain wildcard characters (* and ?). \ ** This string must not exceed MAX_PATH characters. \ ** addr2 is the address of the _win32-find-data structure. \ ** ior is 0 for success in which case _hdl-search contains a valid handle. \ *P Find-First-File searches a directory for a file whose name matches the \ ** specified filename. Find-First-File examines subdirectory names as well as filenames. \ *P Find-First-File opens a search handle and returns information about the first \ ** file whose name matches the specified pattern. Once the search handle is established, you \ ** can use Find-Next-File to search for other files that match the same pattern. \ ** When the search handle is no longer needed, close it by using Find-Close. \ ** Find-First-File searches for files by name only; it cannot be used for attribute-based \ ** searches. max-path malloc dup>r ascii-z \ adrz - _win32-find-data \ lpffd - _WIN32_FIND_DATA swap \ lpszSourceFile call FindFirstFile \ a search handle(hdl if O.K. \ else INVALID_HANDLE_VALUE) _hdl-search ! \ store to the search handle _win32-find-data \ adrd - _hdl-search @ -1 = \ adrd ior - 0 = success r> release ; \ free buff : find-next-file ( -- addr ior ) \ *G Find-first-file word must be called \ ** before this word can be called due to the fact that _hdl-search is needed _win32-find-data \ lpffd - _WIN32_FIND_DATA _hdl-search @ \ hFindFile call FindNextFile \ ior - _win32-find-data \ ior adrd - swap 0= ; \ adrd ior - 0 = success : find-close ( -- ior ) \ *G Close the _hdl-search handle. _hdl-search @ call FindClose 0= ; \ ior - 0 = success internal : (DOSTime) ( n -- ) ptr-DOS-time ptr-DOS-date rot \ ptr's to 16 bit DOS time & date _win32-find-data swap cells+ call FileTimeToDosDateTime drop ; external : get-DOS-create-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 1 (DOSTime) ; : get-DOS-access-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 3 (DOSTime) ; : get-DOS-write-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 5 (DOSTime) ; : get-file-size ( -- size ) \ need to call find-first-file or find-next-file word \ before using this word _win32-find-data 8 cells+ @ ; : get-file-name ( -- adr; address for file name ) \ need to call find-first-file or find-next-file word \ before using this word _win32-find-data 11 cells+ ; : dir-attribute? ( - flag ) \ *G Returns true when a file is a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames _win32-find-data @ FILE_ATTRIBUTE_DIRECTORY and ; 2 cells newuser file-time-buf \ *G 2Variable to hold the FILETIME structure, which is a little endian (i.e. reversed order) \ ** 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601. : get-file-modified ( fileid -- system-time ) >r file-time-buf 2 cells erase \ pre-clear buffer file-time-buf \ address of where to put the file's \ last written time and date 0 \ last access time not needed 0 \ creation time not needed r> call GetFileTime drop _systemtime \ where to put results file-time-buf \ file time/date to convert call FileTimeToSystemTime drop _systemtime ; : filetime-to-systemtime ( cell# -- ; convert file time to system time ) \ need to call find-first-file or find-next-file word \ before using this word \ cell# is offset in number of cells to _win32-find-data \ 1 for creation time; 3 for access time; and 5 for write time \ normaly 5 should be used >r \ cell# -> rstack _systemtime \ struct FileTimeToSystemTime \ function _win32-find-data r> cells+ \ struct FILETIME for \ ftWriteTime call FileTimeToSystemTime drop ; ' zcount alias asciiz->asc-len ( adrz -- sadr slen ) : dir->file-name ( -- adr count ) \ *G Returns the adres and count of a file in a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames get-file-name zcount ; : ForAllFileNames { cfa } ( adr slen cfa -- ) \ *G Executes the CFA for each found file in a directory. \n \ ** A file specification adr slen may contain wildcards \n \ ** NOTE: Directory names are also considered to be a file-name. \n \ ** Directory names can be detected by dir-attribute? 0 #files ! \ reset # of files in dir find-first-file nip \ adrd ior - find first file 0 <> if exit then \ if file is not found, exit dir->file-name get-file-name 0> if cfa execute 1 #files +! else 2drop then begin find-next-file nip 0= \ ior - find next file while get-file-name 0> if 1 #files +! dir->file-name cfa execute then repeat find-close drop ; : ForAllFiles ( cfa -- ) \ *G Executes the CFA on ALL found files in a directory. \n \ ** NOTE: Directory names are also considered to be a file-name. \n \ ** Directory names can be detected by dir-attribute? \n s" *.*" rot ForAllFileNames ; IN-SYSTEM : .dir->file-name ( -- ;print file name in the dir ) _win32-find-data 11 cells+ \ adrz zcount \ adrz scan-len slen dup>r type \ adrz len ;print file name 12 r> - 0max spaces ; deprecated : .dir->file-size ( -- ) \ *G Print the size or directory indication of a file \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames dir-attribute? if ." dir " else get-file-size dup 12 u,.r space \ print nFileSizeLow total-file-bytes +! then ; : _print-dir-files ( adr slen -- ) 0 total-file-bytes ! 0 #files ! \ reset # of files in dir find-first-file nip \ adrd ior - find first file 0 <> if exit then \ if file is not found, exit cr .dir->file-size \ print the size of file .dir->file-name \ print the filename found 1 #files +! \ update file number BEGIN find-next-file nip 0= \ ior - find next file WHILE 1 #files +! \ update file number 25 ?cr .dir->file-size \ print the size of file .dir->file-name \ and the name of file start/stop REPEAT ; deprecated : .file-size-name ( adr len - ) \ *G Print the size or directory indication and the name of file. \ ** It also formats the line. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames 25 ?cr .dir->file-size dup>r type 12 r> - 0max spaces start/stop ; : print-dir-files ( adr slen -- ) \ W32F Files Extra \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. cr ." Directory of: " 2dup type cr 0 total-file-bytes ! \ reset total-file-bytes 0 #files ! \ reset # of files in dir ['] .file-size-name ['] ForAllFileNames catch IF 3drop \ discard abort results THEN cr #files @ . ." Files displayed, using " total-file-bytes @ 1 u,.r ." bytes of disk." ; : dir ( "name" -- ) \ W32F Files Extra \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. \n \ ** If "name" is missing or ends in \ search for all files that match *.* \n \ ** If "name" contains a relative path then it's relative to the current directory. \n \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n \ *P The pattern can contain the standard Windows wildcards. /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place THEN dup count + 1- c@ ':' = \ if just a drive, add \ IF s" \" pocket +place THEN dup count + 1- c@ '\' = \ if it ends in a \, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; : do-rename-afile { RenamePart1$ RenamePart2$ \ RenameTemp$ -- } \ rename one file MAXSTRING LocalAlloc: RenameTemp$ _win32-find-data 11 CELLS+ \ adrz zcount \ adrz -- adr len 2dup 2dup RenamePart1$ count caps-search IF 2dup 2>r nip - RenameTemp$ place \ leading part RenamePart2$ count RenameTemp$ +place 2r> RenamePart1$ c@ /string RenameTemp$ +place RenameTemp$ count rename-file ( adr1 len adr2 len -- ior=0=OK ) 0= IF 1 #files +! \ update file number THEN ELSE 4drop 2drop THEN ; : rename ( -<name1 part1 part2>- ) \ rename file or files { \ RenameFrom$ RenamePart1$ RenamePart2$ -- } MAXSTRING LocalAlloc: RenameFrom$ MAXSTRING LocalAlloc: RenamePart1$ MAXSTRING LocalAlloc: RenamePart2$ /parse-s$ count RenameFrom$ place /parse-s$ count RenamePart1$ place /parse-s$ count RenamePart2$ place RenameFrom$ c@ 0> RenamePart1$ c@ 0> and RenamePart2$ c@ 0> and 0= IF beep cr ." Usage:" cr ." RENAME <filespec> <oldsubstring> <newsubstring>" EXIT \ leave if no names specified THEN cr ." Rename Files: " RenameFrom$ count type ." from: " RenamePart1$ count type ." To: " RenamePart2$ count type 0 #files ! \ reset # of files in dir RenameFrom$ count find-first-file nip 0= \ adrd ior - find first file IF RenamePart1$ RenamePart2$ do-rename-afile BEGIN find-next-file nip 0= \ ior - find next file WHILE RenamePart1$ RenamePart2$ do-rename-afile REPEAT find-close drop cr #files @ . ." Files renamed" ELSE cr ." No matching files Found" \ if file is not found, exit THEN ; IN-APPLICATION module \ *Z Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** extend.f 23 Sep 2006 10:18:34 -0000 1.4 --- extend.f 24 Sep 2006 08:42:03 -0000 1.5 *************** *** 27,30 **** --- 27,31 ---- FLOAD src\console\keyboard.f \ function and special key constants FLOAD src\console\lineedit.f \ a line editor utility + FLOAD src\ansfile.f \ ansi file words .olly *************** *** 33,37 **** \s - \ FLOAD src\lineedit.f \ a line editor utility \ FLOAD src\primhash.f \ primitive hash functions for OOP later *** to be done *** --- 34,37 ---- *************** *** 55,60 **** \ FLOAD src\scrnctrl.f \ screen control words FLOAD src\registry.f \ Win32 Registry support - FLOAD src\ansfile.f \ ansi file words - FLOAD src\keyboard.f \ function and special key constants FLOAD src\mapfile.f \ Windows32 file into memory mapping words sys-FLOAD src\environ.f \ environment? support --- 55,58 ---- |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:32:42
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10017/src/console Modified Files: Console2.f Log Message: Removed some temp change because AS now work's as expected in the STC-Kernel. Index: Console2.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/console/Console2.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Console2.f 23 Sep 2006 10:18:34 -0000 1.1 --- Console2.f 24 Sep 2006 08:32:38 -0000 1.2 *************** *** 341,346 **** \ running under Windows95 and we are already the foreground window. 0 proc GetActiveWindow ! 1 proc SetActiveWindow ! 1 proc SetForegroundWindow 2 proc GetWindowThreadProcessId 3 proc AttachThreadInput --- 341,346 ---- \ running under Windows95 and we are already the foreground window. 0 proc GetActiveWindow ! 1 proc SetActiveWindow as SetActiveWindow ! 1 proc SetForegroundWindow as SetForegroundWindow 2 proc GetWindowThreadProcessId 3 proc AttachThreadInput *************** *** 356,362 **** then 3drop ; - : SetForegroundWindow call SetForegroundWindow ; \ temp - : SetActiveWindow call SetActiveWindow ; \ temp - : (SetForegroundWindow) ( hwnd -- ) \ w32f \ *G The SetForegroundWindow function puts the thread that created the specified window --- 356,359 ---- |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:32:42
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10017/src Modified Files: paths.f Log Message: Removed some temp change because AS now work's as expected in the STC-Kernel. Index: paths.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/paths.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** paths.f 23 Sep 2006 10:18:34 -0000 1.2 --- paths.f 24 Sep 2006 08:32:38 -0000 1.3 *************** *** 31,63 **** [endif] 1 PROC PathRemoveFileSpec as (call-prfs) 1 PROC PathRemoveExtension as (call-pre) ! \ Temp fix until AS work's within the STC-Kernel ! \ : ("path-func") ( a1 n1 xt -- a2 n2 ) \ execute path function ! \ -rot \ save the xt under the string ! \ over >r \ save original address ! \ MAX-PATH _localalloc \ allocate space on stack ! \ -z dup>r \ make a zstring ! \ swap execute drop \ call the function ! \ r> zcount \ count the chars ! \ _localfree ! \ nip r> swap \ use original address ! \ ; ! ! \ : "path-only" ( a1 n1 -- a2 n2 ) \ return path, minus final '\' ! \ ['] (call-prfs) ("path-func") ! \ ; ! \ ! \ : "minus-ext" ( a1 n1 -- a2 n2 ) \ remove the file extension ! \ ['] (call-pre) ("path-func") ! \ ; ! ! : "path-only" ( a1 n1 -- a2 n2 ) ! \ *G Return path, minus final '\' over >r \ save original address ! MAX_PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring ! call PathRemoveFileSpec drop \ call the function r> zcount \ count the chars _localfree --- 31,45 ---- [endif] + internal + 1 PROC PathRemoveFileSpec as (call-prfs) 1 PROC PathRemoveExtension as (call-pre) ! : ("path-func") ( a1 n1 xt -- a2 n2 ) \ execute path function ! -rot \ save the xt under the string over >r \ save original address ! MAX-PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring ! swap execute drop \ call the function r> zcount \ count the chars _localfree *************** *** 65,78 **** ; : "minus-ext" ( a1 n1 -- a2 n2 ) ! \ *G Remove the file extension ! over >r \ save original address ! MAX_PATH _localalloc \ allocate space on stack ! ascii-z dup>r \ make a zstring ! call PathRemoveExtension drop \ call the function ! r> zcount \ count the chars ! _localfree ! nip r> swap \ use original address ! ; : ".ext-only" ( a1 n1 -- a1 n1 ) --- 47,59 ---- ; + external + + : "path-only" ( a1 n1 -- a2 n2 ) + \ *G return path, minus final '\' + ['] (call-prfs) ("path-func") ; + : "minus-ext" ( a1 n1 -- a2 n2 ) ! \ *G remove the file extension ! ['] (call-pre) ("path-func") ; : ".ext-only" ( a1 n1 -- a1 n1 ) *************** *** 411,420 **** \ ** n2=0 means not in search path. dup>r reset-path-source ! begin r@ path-source 2@ nip 0> ! if r@ next-path" 4dup IsPathRelativeTo? not ! else over 0 false ! then ! while 2drop ! repeat 2nip r>drop ; --- 392,401 ---- \ ** n2=0 means not in search path. dup>r reset-path-source ! begin r@ path-source 2@ nip 0> ! if r@ next-path" 4dup IsPathRelativeTo? not ! else over 0 false ! then ! while 2drop ! repeat 2nip r>drop ; |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:29:36
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8651/src/console Modified Files: LINEEDIT.F Log Message: Fixed a bug in the LineEditor Index: LINEEDIT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/console/LINEEDIT.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** LINEEDIT.F 23 Sep 2006 10:18:34 -0000 1.1 --- LINEEDIT.F 24 Sep 2006 08:29:32 -0000 1.2 *************** *** 72,76 **** )) - \ only forth also definitions anew -lineedit.f --- 72,75 ---- *************** *** 78,82 **** INTERNAL \ internal words start here - EXTERNAL --- 77,80 ---- *************** *** 98,104 **** MAXCOUNTED constant maxedit ! create editbuf MAXSTRING allot \ our edit buffer, ! editbuf off \ 255 characters max ! 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates --- 96,102 ---- MAXCOUNTED constant maxedit ! create editbuf maxedit 2 + allot \ our edit buffer, 255 characters max ! editbuf maxedit 2 + erase ! 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates *************** *** 143,147 **** then insertmode ! if editbuf 1+ editpos + dup 1+ maxedit editpos - move editbuf c@ 1+ lenlimit min editbuf c! --- 141,146 ---- then insertmode ! if ! editbuf 1+ editpos + dup 1+ maxedit editpos - move editbuf c@ 1+ lenlimit min editbuf c! *************** *** 275,334 **** create control-tab ! ' noop , ! ' _le-lword , ! ' noop , ! ' _le-pgdn , ! ' _le-right , ! ' _le-up , ! ' _le-rword , ! ' _le-fdel , ! ' _le-bdel , ! ' _le-tab , ! ' _le-LF , ! ' noop , ! ' noop , ! ' _le-ret , ! ' noop , ! ' noop , ! ' noop , ! ' noop , ! ' _le-pgup , ! ' _le-left , ! ' _le-wdel , ! ' noop , ! ' _le-ins , ! ' noop , ! ' _le-down , ! ' _le-ldel , ! ' noop , ! ' _le-quit , ! ' noop , ! ' noop , ! ' noop , ! ' noop , : ?control ( --- ) \ handle control characters ! lchar bl < ! if false to autoclear \ no auto clear now ! ! \ temp changed: because EXEC: must be ported first ! (( ! lchar exec: ! \ 0 null 1 a 2 b 3 c 4 d 5 e 6 f ! noop _le-lword noop _le-pgdn _le-right _le-up _le-rword ! \ 7 g 8 h 9 i LF 11 k 12 l Enter ! _le-fdel _le-bdel _le-tab _le-LF noop noop _le-ret ! \ 14 n 15 o 16 p 17 q 18 r 19 s 20 t ! noop noop noop noop _le-pgup _le-left _le-wdel ! \ 21 u 22 v 23 w 24 x 25 y 26 z Esc ! noop _le-ins noop _le-down _le-ldel noop _le-quit ! \ 28 \ 29 ] 30 ^ 31 _ ! noop noop noop noop ! )) ! lchar cells control-tab + @ execute ! ! then ; ! ! : ?func ( --- ) \ handle function keys --- 274,290 ---- create control-tab ! ' noop , ' _le-lword , ' noop , ' _le-pgdn , ' _le-right , ! ' _le-up , ' _le-rword , ' _le-fdel , ' _le-bdel , ' _le-tab , ! ' _le-LF , ' noop , ' noop , ' _le-ret , ' noop , ! ' noop , ' noop , ' noop , ' _le-pgup , ' _le-left , ! ' _le-wdel , ' noop , ' _le-ins , ' noop , ' _le-down , ! ' _le-ldel , ' noop , ' _le-quit , ' noop , ' noop , ! ' noop , ' noop , : ?control ( --- ) \ handle control characters ! lchar bl < ! if false to autoclear \ no auto clear now ! lchar cells control-tab + @ execute ! then ; : ?func ( --- ) \ handle function keys *************** *** 388,392 **** to ledit-y to ledit-x \ save origin - false to insertmode _le-ins _le-ins false to ?ldone --- 344,347 ---- |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:18:29
|
Update of /cvsroot/win32forth/win32forth/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4456/src/console Modified Files: LINEEDIT.F Log Message: Changed APPLICATION to reset the Console I/O after creating the EXE-File. Index: LINEEDIT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/console/LINEEDIT.F,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** LINEEDIT.F 26 Feb 2006 08:15:40 -0000 1.6 --- LINEEDIT.F 24 Sep 2006 08:18:24 -0000 1.7 *************** *** 98,104 **** MAXCOUNTED constant maxedit ! create editbuf MAXSTRING allot \ our edit buffer, ! editbuf off \ 255 characters max ! 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates --- 98,104 ---- MAXCOUNTED constant maxedit ! create editbuf MAXSTRING 2 + allot \ our edit buffer, ! editbuf off \ 255 characters max ! 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates |
|
From: Dirk B. <db...@us...> - 2006-09-24 08:17:33
|
Update of /cvsroot/win32forth/win32forth/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4073/src/console Modified Files: NoConsole.f Log Message: Fixed a bug in the LineEditor Index: NoConsole.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/console/NoConsole.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** NoConsole.f 30 Jul 2006 08:59:25 -0000 1.5 --- NoConsole.f 24 Sep 2006 08:17:27 -0000 1.6 *************** *** 89,94 **** : ResetConsoleIO ( -- ) \ W32F console ! \ *G Reset of the Console I/O after saving turnkey applications that don't need ! \ ** the console window. Done automatically by TURNKEY. \ set all deferd words for the console window. --- 89,94 ---- : ResetConsoleIO ( -- ) \ W32F console ! \ *G Reset of the Console I/O after saving an application that don't need ! \ ** the console window. Done automatically by TURNKEY and APPLICATION. \ set all deferd words for the console window. *************** *** 135,144 **** ; warning @ checkstack warning off ! : turnkey ( xt -<prognam>- -- ) ['] turnkey catch ResetConsoleIO throw ; warning ! ! \+ VIMAGE also VIMAGE : NoConsoleInImage ( -- ) \ W32F console \ *G Tell Imageman that we don't need the w32fconsole.dll if possible. --- 135,154 ---- ; + \ We redifine TURNKEY and APPLICATION to reset the the + \ Console I/O after writeing the executable. So we can + \ see the error messages. warning @ checkstack warning off ! ! : turnkey ( xt -<prognam>- -- ) ['] turnkey catch ResetConsoleIO throw ; + + : application ( app-mem sys-mem xt -<prognam>- -- ) + ['] application catch ResetConsoleIO throw ; + warning ! ! ! \+ VIMAGE also VIMAGE ! : NoConsoleInImage ( -- ) \ W32F console \ *G Tell Imageman that we don't need the w32fconsole.dll if possible. *************** *** 146,150 **** \+ CONSOLE-DLL? false to CONSOLE-DLL? ; ! \+ VIMAGE previous in-application --- 156,160 ---- \+ CONSOLE-DLL? false to CONSOLE-DLL? ; ! \+ VIMAGE previous in-application |
|
From: George H. <geo...@us...> - 2006-09-23 15:49:16
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18612/win32forth-stc/src Modified Files: primutil.f Log Message: gah: Merged some words needed for loading ansfile.f (use ITC version) (untesteed til mon 25/9/6) to try out uncomment out the \\S Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** primutil.f 23 Sep 2006 10:18:34 -0000 1.2 --- primutil.f 23 Sep 2006 15:49:12 -0000 1.3 *************** *** 14,17 **** --- 14,18 ---- \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) \ Dirk Busch (dirk.yahoo @ schneider-busch.de) + \ George Hubert (georgeahubert at yahoo.co.uk) \ \ This program is free software; you can redistribute it and/or modify it *************** *** 45,48 **** --- 46,53 ---- : ANEW BL WORD DROP ; immediate \ *** to be done *** : IS-DEFAULT BL WORD 2DROP ; immediate \ *** to be done *** + : DPR-WARNING-ON ; immediate \ *** to be done *** + : DPR-WARNING-OFF ; immediate \ *** to be done *** + 0 value DPR-WARNING? \ null value *** to be done *** + : CHECKSTACK ; immediate \ *** to be done *** \ ------------------------------------------------------------------------ *************** *** 94,103 **** \ ------------------------------------------------------------------------ ! ' included alias "fload ! ' fload alias include ! ' requires alias needs ! ' dpl alias dp-location ! ' postpone alias compile defer enter-assembler ' noop is enter-assembler --- 99,110 ---- \ ------------------------------------------------------------------------ ! ' included alias "fload ! ' fload alias include ! ' requires alias needs ! ' dpl alias dp-location ! ' postpone alias compile ! ! ' maxbuffer alias max-path defer enter-assembler ' noop is enter-assembler *************** *** 192,193 **** --- 199,250 ---- ['] interpret catch r> to sys-warning? throw ; immediate + + \s + \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own + \ primutil.f and hopefully merged everything correctly but can't test @ work so any + \ other corrections will have to wait til mon 23/9/6 gah. + + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ Some case insensitive version of search and compare + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + \ enhanced caps-search for source string > 255 bytes + \ search for t-adr,t-len within string s-adr,s-len. f1=true if string was found + : CAPS-SEARCH ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) + \ *G Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2, + \ ** using a case-insensitive search. \n + \ ** If flag is true, a match was found at c-addr3 with u3 characters remaining. \n + \ ** If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1. + { s-adr s-len t-adr t-len \ t-buf t-str -- adr len flag } + MAXSTRING localalloc: t-str + s-len cell+ ALLOCATE 0= + IF to t-buf \ make a buffer big enough for s-adr + t-adr t-len t-str place + t-str count upper + s-adr t-buf s-len move + t-buf s-len upper + t-buf s-len t-str count search + IF nip \ discard found address + s-len swap - \ offset where string was found + s-adr s-len rot /string + \ location of found string in original buf + TRUE + ELSE 2drop + s-adr s-len FALSE + THEN + t-buf FREE drop + ELSE s-adr s-len FALSE \ failed, couldn't allocate buffer + THEN ; + + \ COMPARE compares two strings, ignoring case. The return value is: + \ + \ 0 = string1 = string2 + \ -1 = string1 < string2 + \ 1 = string1 > string2 + : CAPS-COMPARE { sa1 sn1 sa2 sn2 \ st1 st2 -- f1 } + MAXSTRING LocalAlloc: st1 + MAXSTRING LocalAlloc: st2 + sa1 sn1 st1 place st1 count upper + sa2 sn2 st2 place st2 count upper + st1 count st2 count compare ; + |
|
From: Dirk B. <db...@us...> - 2006-09-23 15:10:35
|
Update of /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3276/extsrc/w32fScintilla/src Modified Files: LexForth.cxx Log Message: - Fixed some bug's in the colorization support. gkernel.f now look's mutch better in the IDE. Index: LexForth.cxx =================================================================== RCS file: /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/src/LexForth.cxx,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** LexForth.cxx 23 Jan 2005 16:38:02 -0000 1.2 --- LexForth.cxx 23 Sep 2006 15:10:30 -0000 1.3 *************** *** 211,225 **** if( strcmp("\\S",buffer)==0 ) // comment till end of file { ! #ifndef _DEBUG ! styler.ColourTo(pos1, SCE_FORTH_COMMENT); ! styler.ColourTo(lengthDoc-1, SCE_FORTH_COMMENT); ! #endif ! break; // leave parser } else if( strcmp("\\",buffer)==0 || strcmp("//",buffer)==0 ) // comment till end of line { ! styler.ColourTo(pos1-1,SCE_FORTH_COMMENT); ! parse(1, false); ! styler.ColourTo(pos2,SCE_FORTH_COMMENT); } else if( strcmp("(",buffer)==0 || strcmp(".(",buffer)==0 ) // comment till ) --- 211,247 ---- if( strcmp("\\S",buffer)==0 ) // comment till end of file { ! char ch1 = styler.SafeGetCharAt(pos1-1); ! char ch2 = styler.SafeGetCharAt(pos1-2); ! char ch3 = styler.SafeGetCharAt(pos1-3); ! if( ch1 == ' ' && ch2 == ':' && is_eol(ch3) ) ! { ! styler.ColourTo(pos1, SCE_FORTH_DEFAULT); ! styler.ColourTo(pos2, SCE_FORTH_DEFAULT); ! cur_pos = pos2 + 1; ! } ! else ! { ! styler.ColourTo(pos1, SCE_FORTH_COMMENT); ! styler.ColourTo(lengthDoc-1, SCE_FORTH_COMMENT); ! break; // leave parser ! } } else if( strcmp("\\",buffer)==0 || strcmp("//",buffer)==0 ) // comment till end of line { ! char ch1 = styler.SafeGetCharAt(pos1-1); ! char ch2 = styler.SafeGetCharAt(pos1-2); ! char ch3 = styler.SafeGetCharAt(pos1-3); ! if( ch1 == ' ' && ch2 == ':' && is_eol(ch3) ) ! { ! styler.ColourTo(pos1, SCE_FORTH_ANS); ! styler.ColourTo(pos2, SCE_FORTH_ANS); ! cur_pos = pos2 + 1; ! } ! else ! { ! styler.ColourTo(pos1-1,SCE_FORTH_COMMENT); ! parse(1, false); ! styler.ColourTo(pos2,SCE_FORTH_COMMENT); ! } } else if( strcmp("(",buffer)==0 || strcmp(".(",buffer)==0 ) // comment till ) *************** *** 234,240 **** else if( strcmp("{",buffer)==0 ) // locals till } { ! styler.ColourTo(pos1,SCE_FORTH_LOCALS); ! parse('}', true); ! styler.ColourTo(pos2+1,SCE_FORTH_LOCALS); } else if( commentStart.InList(buffer) ) // multi line comments --- 256,274 ---- else if( strcmp("{",buffer)==0 ) // locals till } { ! char ch1 = styler.SafeGetCharAt(pos1-1); ! char ch2 = styler.SafeGetCharAt(pos1-2); ! char ch3 = styler.SafeGetCharAt(pos1-3); ! if( ch1 == ' ' && ch2 == ':' && is_eol(ch3) ) ! { ! styler.ColourTo(pos1, SCE_FORTH_DEFAULT); ! styler.ColourTo(pos2, SCE_FORTH_DEFAULT); ! cur_pos = pos2 + 1; ! } ! else ! { ! styler.ColourTo(pos1,SCE_FORTH_LOCALS); ! parse('}', true); ! styler.ColourTo(pos2+1,SCE_FORTH_LOCALS); ! } } else if( commentStart.InList(buffer) ) // multi line comments *************** *** 279,282 **** --- 313,317 ---- int iStart = pos1; + int iEnd = pos2; char ch1 = styler.SafeGetCharAt(pos1-1); *************** *** 302,308 **** { styler.ColourTo( iStart, SCE_FORTH_STRING ); ! styler.ColourTo( pos2+1, SCE_FORTH_STRING ); } } } //------------------------------------------------------------------------------------------- --- 337,350 ---- { styler.ColourTo( iStart, SCE_FORTH_STRING ); ! styler.ColourTo( iEnd, SCE_FORTH_STRING ); ! cur_pos = iEnd + 1; } } + else + { + if( parse(1, false) ) + styler.ColourTo( pos2 , SCE_FORTH_STRING ); + } + } //------------------------------------------------------------------------------------------- |
|
From: Dirk B. <db...@us...> - 2006-09-23 15:10:35
|
Update of /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/vcbuild In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3276/extsrc/w32fScintilla/vcbuild Modified Files: SciLexer.dsp Log Message: - Fixed some bug's in the colorization support. gkernel.f now look's mutch better in the IDE. Index: SciLexer.dsp =================================================================== RCS file: /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/vcbuild/SciLexer.dsp,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** SciLexer.dsp 3 Sep 2005 10:13:13 -0000 1.3 --- SciLexer.dsp 23 Sep 2006 15:10:30 -0000 1.4 *************** *** 1,23 **** # Microsoft Developer Studio Project File - Name="SciLexer" - Package Owner=<4> # Microsoft Developer Studio Generated Build File, Format Version 6.00 ! # ** NICHT BEARBEITEN ** # TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 CFG=SciLexer - Win32 Debug ! !MESSAGE Dies ist kein gültiges Makefile. Zum Erstellen dieses Projekts mit NMAKE ! !MESSAGE verwenden Sie den Befehl "Makefile exportieren" und führen Sie den Befehl !MESSAGE !MESSAGE NMAKE /f "SciLexer.mak". !MESSAGE ! !MESSAGE Sie können beim Ausführen von NMAKE eine Konfiguration angeben ! !MESSAGE durch Definieren des Makros CFG in der Befehlszeile. Zum Beispiel: !MESSAGE !MESSAGE NMAKE /f "SciLexer.mak" CFG="SciLexer - Win32 Debug" !MESSAGE ! !MESSAGE Für die Konfiguration stehen zur Auswahl: !MESSAGE ! !MESSAGE "SciLexer - Win32 Release" (basierend auf "Win32 (x86) Dynamic-Link Library") ! !MESSAGE "SciLexer - Win32 Debug" (basierend auf "Win32 (x86) Dynamic-Link Library") !MESSAGE --- 1,23 ---- # Microsoft Developer Studio Project File - Name="SciLexer" - Package Owner=<4> # Microsoft Developer Studio Generated Build File, Format Version 6.00 ! # ** DO NOT EDIT ** # TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 CFG=SciLexer - Win32 Debug ! !MESSAGE This is not a valid makefile. To build this project using NMAKE, ! !MESSAGE use the Export Makefile command and run !MESSAGE !MESSAGE NMAKE /f "SciLexer.mak". !MESSAGE ! !MESSAGE You can specify a configuration when running NMAKE ! !MESSAGE by defining the macro CFG on the command line. For example: !MESSAGE !MESSAGE NMAKE /f "SciLexer.mak" CFG="SciLexer - Win32 Debug" !MESSAGE ! !MESSAGE Possible choices for configuration are: !MESSAGE ! !MESSAGE "SciLexer - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") ! !MESSAGE "SciLexer - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") !MESSAGE *************** *** 44,48 **** # PROP Target_Dir "" # ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "SciLexer_EXPORTS" /Yu"stdafx.h" /FD /c ! # ADD CPP /nologo /MD /W3 /O1 /I "..\include" /I "..\src" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /FR /FD /c # SUBTRACT CPP /YX /Yc /Yu # ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 --- 44,48 ---- # PROP Target_Dir "" # ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "SciLexer_EXPORTS" /Yu"stdafx.h" /FD /c ! # ADD CPP /nologo /MD /W4 /O1 /I "..\include" /I "..\src" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "SCI_LEXER" /FR /FD /c # SUBTRACT CPP /YX /Yc /Yu # ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 |
|
From: Dirk B. <db...@us...> - 2006-09-23 15:10:33
|
Update of /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/win32 In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3276/extsrc/w32fScintilla/win32 Modified Files: ScintRes.aps ScintRes.rc ScintillaWin.cxx Log Message: - Fixed some bug's in the colorization support. gkernel.f now look's mutch better in the IDE. Index: ScintillaWin.cxx =================================================================== RCS file: /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/win32/ScintillaWin.cxx,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** ScintillaWin.cxx 3 Sep 2005 10:13:13 -0000 1.2 --- ScintillaWin.cxx 23 Sep 2006 15:10:30 -0000 1.3 *************** *** 924,927 **** --- 924,928 ---- break; + /* #ifdef SCI_LEXER case SCI_LOADLEXERLIBRARY: *************** *** 929,932 **** --- 930,934 ---- break; #endif + */ default: Index: ScintRes.rc =================================================================== RCS file: /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/win32/ScintRes.rc,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** ScintRes.rc 3 Sep 2005 10:13:13 -0000 1.3 --- ScintRes.rc 23 Sep 2006 15:10:30 -0000 1.4 *************** *** 17,21 **** ///////////////////////////////////////////////////////////////////////////// ! // Deutsch (Deutschland) resources #if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_DEU) --- 17,21 ---- ///////////////////////////////////////////////////////////////////////////// ! // German (Germany) resources #if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_DEU) *************** *** 32,37 **** VS_VERSION_INFO VERSIONINFO ! FILEVERSION 1,6,6,1 ! PRODUCTVERSION 1,6,6,1 FILEFLAGSMASK 0x3fL #ifdef _DEBUG --- 32,37 ---- VS_VERSION_INFO VERSIONINFO ! FILEVERSION 1,6,6,2 ! PRODUCTVERSION 1,6,6,2 FILEFLAGSMASK 0x3fL #ifdef _DEBUG *************** *** 51,62 **** VALUE "CompanyName", "Win32Forth developer team\0" VALUE "FileDescription", "Scintilla Source Editing Component\0" ! VALUE "FileVersion", "1, 6, 6, 1\0" VALUE "InternalName", "Scintilla\0" ! VALUE "LegalCopyright", "Copyright 1998-2005 by Neil Hodgson, 2004-2005 by Win32Forth developer team\0" VALUE "LegalTrademarks", "\0" VALUE "OriginalFilename", "w32fScintilla.dll\0" VALUE "PrivateBuild", "\0" VALUE "ProductName", "Win32Forth\0" ! VALUE "ProductVersion", "1, 6, 6, 1\0" VALUE "SpecialBuild", "\0" END --- 51,62 ---- VALUE "CompanyName", "Win32Forth developer team\0" VALUE "FileDescription", "Scintilla Source Editing Component\0" ! VALUE "FileVersion", "1, 6, 6, 2\0" VALUE "InternalName", "Scintilla\0" ! VALUE "LegalCopyright", "Copyright 1998-2005 by Neil Hodgson, 2004-2006 by Win32Forth developer team\0" VALUE "LegalTrademarks", "\0" VALUE "OriginalFilename", "w32fScintilla.dll\0" VALUE "PrivateBuild", "\0" VALUE "ProductName", "Win32Forth\0" ! VALUE "ProductVersion", "1, 6, 6, 2\0" VALUE "SpecialBuild", "\0" END *************** *** 106,110 **** #endif // APSTUDIO_INVOKED ! #endif // Deutsch (Deutschland) resources ///////////////////////////////////////////////////////////////////////////// --- 106,110 ---- #endif // APSTUDIO_INVOKED ! #endif // German (Germany) resources ///////////////////////////////////////////////////////////////////////////// Index: ScintRes.aps =================================================================== RCS file: /cvsroot/win32forth/win32forth-extsrc/extsrc/w32fScintilla/win32/ScintRes.aps,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 Binary files /tmp/cvsAoYaRD and /tmp/cvsO5laXl differ |
|
From: Dirk B. <db...@us...> - 2006-09-23 15:09:44
|
Update of /cvsroot/win32forth/win32forth In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv2856 Modified Files: w32fScintilla.dll Log Message: - Fixed some bug's in the colorization support. gkernel.f now look's mutch better in the IDE. Index: w32fScintilla.dll =================================================================== RCS file: /cvsroot/win32forth/win32forth/w32fScintilla.dll,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 Binary files /tmp/cvsTOPeCH and /tmp/cvsKJDAGO differ |
|
From: Dirk B. <db...@us...> - 2006-09-23 10:18:41
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19498/src/console Added Files: CONSOLE.F Console2.f KEYBOARD.F LINEEDIT.F Log Message: Proted the latest Console-code and the LineEditor. --- NEW FILE: Console2.f --- \ $Id: Console2.f,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ File: Console2.f \ Author: Dirk Busch \ Created: November 9th, 2003 - 10:32 dbu \ Updated: November 9th, 2003 - 10:32 dbu \ \ more Win32Forth Terminal I/O (Moved here from Primutil.f ) \ It couldn't be moved into Console.f because 'mouse-chain' must be defined \ before this. cr .( Loading... Console I/O Part 2) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ new definition of key to support minimal mouse down events \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value mousex 0 value mousey 0 value mouseflags (( MOUSEFLAGS info: 3 both buttons, currently assigned to abort 1 left button 9 control left button 13 control shift left mouse button 5 shift left mouse button 2 right button 14 control shift right mouse button 10 control right mouse button 6 shift right mouse button )) defer do-mabort 0 value mkstlin \ hold the status of the current marked console text 0 value mkstcol 0 value mkedlin 0 value mkedcol 0 value mkorlin 0 value mkorcol : mark-start ( -- ) \ set a new start of marked console text mousex charWH >r / to mkstcol mousey r> / getrowoff + to mkstlin mousex charWH >r / to mkedcol mousey r> / getrowoff + to mkedlin mkstlin to mkorlin mkstcol to mkorcol mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-end { \ lin col -- } \ set a new end of marked console text mousex charWH >r / to col mousey r> / getrowoff + to lin lin mkorlin = \ same line but earlier in line col mkorcol <= and lin mkorlin < or \ or on an earlier line if lin to mkstlin col to mkstcol mkorlin to mkedlin mkorcol to mkedcol else lin to mkedlin col to mkedcol mkorlin to mkstlin mkorcol to mkstcol then mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-all ( -- ) \ makr all console text 0 to mkstlin 0 to mkstcol 0 to mkedcol getxy nip getrowoff + 1+ to mkedlin mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-none ( -- ) \ clear the marking of any console text 0 to mkstlin 0 to mkstcol 0 to mkedcol 0 to mkedlin mkstlin mkstcol mkedlin mkedcol markconsole ; : marked? ( -- f1 ) \ return TRUE if any text is marked mkstlin mkedlin <> mkstcol mkedcol <> or ; : _do-mabort ( -- ) cr ." Aborted by Mouse!" abort ; ' _do-mabort is do-mabort : ?mouse_abort ( -- ) \ abort if both mouse buttons are down mouseflags 3 and 3 = if do-mabort then ; \ new-chain mouse-chain \ chain of things to do on mouse down mouse-chain chain-add ?mouse_abort defer auto_key ' noop is auto_key \ default to nothing defer auto_key? ' noop is auto_key? \ default to nothing : _mouse-click ( -- ) mouse-chain do-chain ; defer mouse-click ' _mouse-click is mouse-click : process-mouse ( ekey -- ) dup down_mask and \ if mouse is DOWN IF dup>r mouse_mask -1 xor and down_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x \ is mouse UP and DOWN mouseflags 3 and 1 = \ left mouse button IF r@ up_mask and \ both masks is a mousemove ?shift or IF mark-end ELSE mark-start THEN THEN mouseflags 3 and 2 = \ right mouse button IF mouse-click THEN THEN r>drop ELSE dup up_mask and \ is mouse UP IF mouse_mask -1 xor and up_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x mkstlin mkstcol mkedlin mkedcol d= \ pos NOT changed? IF mouse-click ELSE mark-end THEN THEN ELSE mouse_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x mouse-click THEN THEN THEN ; : _mkey ( -- c1 ) \ get a key from the keyboard, and handle mouse clicks auto_key BEGIN x_key dup mouse_mask and \ mouse operation IF process-mouse false THEN ?dup UNTIL ; : _mkey? ( -- c1 ) \ check for key from keyboard, and handle mouse clicks x_key? dup mouse_mask and if x_key drop \ discard waiting key process-mouse false then auto_key? ; : ?mabort ( -- ) \ give mouse a chance to recognize button press WINPAUSE ; : _mcls ( -- ) x_cls mark-none ; : _memit ( c1 -- ) \ allow mouse to abort EMIT ?mabort x_emit ; : _mtype ( a1 n1 -- ) \ allow mouse to abort TYPE ?mabort "CLIP" x_type ; : _mcol ( n1 -- ) x_col ; : _m?cr ( n1 -- ) x_?cr ; : _mcrtab ( -- ) x_crtab ; \ ------------------------------------------------------------------------------ \ ------------------------------------------------------------------------------ \ defer@ accept value defaultAccept ' accept defer@ value defaultAccept : _basic-forth-io ( -- ) \ reset to Forth IO words unhide-console sizestate 1 = \ if window is SIZE_MINIMIZED IF normal-console THEN ['] _mkey is key ['] _mkey? is key? defaultAccept is accept ['] _memit is emit ['] _mtype is type ['] _mcrtab is cr ['] _m?cr is ?cr ['] _mcls is cls ['] x_cls is page ['] x_gotoxy is gotoxy ['] x_getxy is getxy ['] x_getcolrow is getcolrow ['] _mcol is col focus-console tabing-off ; defer basic-forth-io ' _basic-forth-io is basic-forth-io forth-io-chain chain-add basic-forth-io : forth-io ( -- ) forth-io-chain do-chain ; forth-io \ set the default I/O words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ mouse typing \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : mxy>cxy ( x y -- cx cy ) \ convert from mouse xy to character xy charwh rot 2>r / 2r> swap / ; : char@screen ( x y -- c1 ) getmaxcolrow drop * + &the-screen + c@ ; : word@mouse" ( -- a1 n1 ) &the-screen mousex mousey mxy>cxy getrowoff + getmaxcolrow drop * + 2dup + c@ bl <> if 0 over ?do over i + c@ bl = if drop i leave \ found blank, leave loop then -1 +loop \ a1=screen, n1=offset to blank getmaxcolrow * swap /string \ -- a1,n1 of remaining screen bl skip \ remove leading blanks 2dup bl scan nip - \ return addr and length else + 0 then ; : word@mouse>keyboard ( -- ) \ send word at mouse to keyboard mouseflags double_mask and 0= ?exit \ double clicked mouse word@mouse" ?dup if "pushkeys bl pushkey \ push a space else drop then ; MOUSE-CHAIN CHAIN-ADD WORD@MOUSE>KEYBOARD : line@mouse" ( -- a1 n1 ) &the-screen mousex mousey mxy>cxy getrowoff + swap >r \ save x for later getmaxcolrow drop swap * + r> \ -- a1,n1 the line upto mouse -trailing ; \ remove trailing blanks : line@mouse>keyboard ( -- ) \ send the line at mouse to keyboard mouseflags 0xFF and 0x09 <> ?exit \ ctrl-left mouse button down \ along with the control key line@mouse" ?dup if "pushkeys 0x0D pushkey \ automatically press Enter else drop then ; MOUSE-CHAIN CHAIN-ADD LINE@MOUSE>KEYBOARD \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ allow the user to set the current display FONT \ doesn't work so it's deprecated \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ WINLIBRARY GDI32.DLL \ 1 proc GetDC \ 2 proc ReleaseDC \ 1 proc GetStockObject \ 2 proc SelectObject : set-font ( font_value -- ) \ conHndl call GetDC >r \ get and save the Device Control # \ call GetStockObject \ return the object information \ r@ call SelectObject drop \ selects the object \ r> conHndl call ReleaseDC drop ; DEPRECATED \ : _>bold ( -- ) \ OEM_FIXED_FONT set-font ; \ \ : _>norm ( -- ) \ ANSI_FIXED_FONT set-font ; \ \ ' _>bold is >bold \ ' _>norm is >norm \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ allow the user to hide the cursor \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Note: The Line Editor (in Lineedit.f) is using set-cursor which \ turn's on the cursor every time it's called. So a call to hide-cursor doesn't \ show any effect at all. 1 proc HideCaret : hide-cursor ( -- ) conHndl call HideCaret drop ; synonym cursor-off hide-cursor 1 proc ShowCaret : show-cursor ( -- ) conHndl call ShowCaret drop ; synonym cursor-on show-cursor \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : minimize-console ( -- ) SW_SHOWMINIMIZED conhndl call ShowWindow drop ; \ Make console the foreground window. Ignore error which will occur if we are \ running under Windows95 and we are already the foreground window. 0 proc GetActiveWindow 1 proc SetActiveWindow 1 proc SetForegroundWindow 2 proc GetWindowThreadProcessId 3 proc AttachThreadInput : (SetWindow) { hWnd proc \ hActiveThreadID hLocalThreadID -- } call GetActiveWindow dup hWnd = -if hWnd proc execute else swap call GetWindowThreadProcessId to hActiveThreadID 0 hWnd call GetWindowThreadProcessId to hLocalThreadID 1 hLocalThreadID hActiveThreadID Call AttachThreadInput hWnd proc execute 0 hLocalThreadID hActiveThreadID Call AttachThreadInput then 3drop ; : SetForegroundWindow call SetForegroundWindow ; \ temp : SetActiveWindow call SetActiveWindow ; \ temp : (SetForegroundWindow) ( hwnd -- ) \ w32f \ *G The SetForegroundWindow function puts the thread that created the specified window \ ** into the foreground and activates the window. Keyboard input is directed to the window, \ ** and various visual cues are changed for the user. The system assigns a slightly higher \ ** priority to the thread that created the foreground window than it does to other threads. \n \ ** The foreground window is the window at the top of the Z order. It is the window that the \ ** user is working with. In a preemptive multitasking environment, you should generally let the \ ** user control which window is the foreground window. }n \ ** Windows 98, Windows 2000: The system restricts which processes can set the foreground window. \ ** A process can set the foreground window only if one of the following conditions is true: \n \ ** The process is the foreground process. \n \ ** The process was started by the foreground process. \n \ ** The process received the last input event. \n \ ** There is no foreground process. \n \ ** The foreground process is being debugged. \n \ ** The foreground is not locked (see LockSetForegroundWindow). \n \ ** The foreground lock time-out has expired (see SPI_GETFOREGROUNDLOCKTIMEOUT in SystemParametersInfo). \n \ ** Windows 2000: No menus are active. \n \ ** With this change, an application cannot force a window to the foreground while the user is \ ** working with another window. Instead, SetForegroundWindow will activate the window (see SetActiveWindow) \ ** and call the FlashWindowEx function to notify the user. For more information, see Foreground and \ ** Background Windows. \n \ ** A process that can set the foreground window can enable another process to set the foreground window by \ ** calling the AllowSetForegroundWindow function. The process specified by dwProcessId loses the ability to \ ** set the foreground window the next time the user generates input, unless the input is directed at that \ ** process, or the next time a process calls AllowSetForegroundWindow, unless that process is specified. \n \ ** The foreground process can disable calls to SetForegroundWindow by calling the LockSetForegroundWindow function. ['] SetForegroundWindow (SetWindow) ; : (SetActiveWindow) ( hWnd -- ) \ *G The SetActiveWindow function activates a window. The window must be attached to the calling thread's message queue. \n \ ** The SetActiveWindow function activates a window, but not if the application is in the background. The window will be \ ** brought into the foreground (top of Z order) if its application is in the foreground when the system activates the window. \n \ ** If the window identified by the hWnd parameter was created by the calling thread, the active window status of the calling \ ** thread is set to hWnd. Otherwise, the active window status of the calling thread is set to NULL. \n \ ** By using the AttachThreadInput function, a thread can attach its input processing to another thread. \ ** This allows a thread to call SetActiveWindow to activate a window attached to another thread's message queue. ['] SetActiveWindow (SetWindow) ; : _foreground-console ( -- ) conhndl (SetForegroundWindow) ; : _activate-console ( -- ) conhndl (SetActiveWindow) ; defer foreground-console ( -- ) ' _foreground-console is foreground-console defer activate-console ( -- ) ' _activate-console is activate-console \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ fill in some deferred words default functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ' x_gotoxy is-default gotoxy ' x_getxy is-default getxy ' x_getcolrow is-default getcolrow --- NEW FILE: CONSOLE.F --- \ $Id: CONSOLE.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ File: Console.f \ Author: Dirk Busch \ Created: November 9th, 2003 - 10:32 dbu \ Updated: January 14th, 2004 - 13:09 dbu \ \ Win32Forth Terminal I/O (Moved here from Primutil.f ) cr .( Loading... Console I/O Part 1) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ get console window handle \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer conHndl ' _conHndl is conHndl \ so we can change it later \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Keyboard Mask Constant, MUST MATCH THOSE IN TERM.H !! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 65536 ( 0x10000 ) constant function_mask \ function key maks 131072 ( 0x20000 ) constant special_mask \ special keyboard key mask 262144 ( 0x40000 ) constant control_mask \ control key mask 524288 ( 0x80000 ) constant shift_mask \ shift key mask 1048576 ( 0x100000 ) constant alt_mask \ alt key mask 2097152 ( 0x200000 ) constant mouse_mask \ mouse operations 4194304 ( 0x400000 ) constant menu_mask \ menu operations 8192 ( 0x002000 ) constant proc_mask \ procedure base mask 16777216 ( 0x1000000 ) constant double_mask \ double click mask 33554432 ( 0x2000000 ) constant down_mask \ mouse down mask 67108864 ( 0x4000000 ) constant up_mask \ mouse up mask \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ sound stuff \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ VARIABLE TONE_FREQ 700 TONE_FREQ ! VARIABLE TONE_DURA 50 TONE_DURA ! 2 PROC Beep : TONE ( frequency duration-ms -- ) swap call Beep drop ; : BEEP! ( frequency duration-ms -- ) TONE_DURA ! TONE_FREQ ! ; : _BEEP ( -- ) tone_freq @ tone_dura @ tone ; defer beep ' _beep is beep \ default sound stuff synonym NOTE tone DEPRECATED \ use TONE instad \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ define some deferred words with their functions, and defaults \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer page ' cls is page \ the next two words are deprecated because changeing the \ console font doesn't realy work defer >bold DEPRECATED \ ' noop is >bold \ set bold font in console window defer >norm DEPRECATED \ ' noop is >norm \ set normal font in console window \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Some words that improve compatibility with existing F-PC code. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ synonym SP>COL COL DEPRECATED synonym AT-XY gotoxy \ ANS Version of gotoxy : cols ( -- n1 ) \ current screen columns getcolrow drop ; : rows ( -- n1 ) \ current screen rows getcolrow nip ; 0 value accept-cnt \ current count of chars accepted : _faccept ( a1 n1 -- n2 ) 0 swap 0 ?do drop i to accept-cnt \ save in case we need it key case 8 of i 1 < \ if input is empty if 0 \ do nothing but beep \ beep at user else 1- \ decrement address 1 -1 08 emit bl emit 08 emit then endof 27 of dup c@ emit 1+ 1 endof 13 of i leave endof dup emit 2dup swap c! \ place the character swap 1+ swap \ bump the address 1 swap \ loop increment endcase i 1+ swap \ incase loop completes +loop nip ; ' _faccept is accept \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Words that position on the screen \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 8 value tab-size 8 value left-margin 4 value right-margin 0 value tab-margin 5 value tabs-max 0 value tabing? \ are we tabing, default to no 0 value first-line? \ is this the first line of a paragraph -8 value indent \ indent/outdent spaces : wrap? ( n1 -- f1 ) \ return true if column n1 crosses into the \ right margin area getcolrow drop right-margin - > ; : tab-wrap? ( n1 -- f1 ) \ return true if column exceeds the maximum \ desired tabs, or crosses into the right \ margin area dup tabs-max tab-size * > swap wrap? or ; : TAB ( -- ) getxy drop tab-size / 1+ tab-size * col ; : 0TAB ( -- ) \ left margin goes to left edge of screen 0 to tab-margin ; : +TAB ( --- ) tab-size +to tab-margin tab-margin tab-wrap? IF 0tab THEN ; : -TAB ( --- ) tab-margin tab-size - 0 MAX DUP to tab-margin tab-size < IF tabs-max tab-size * to tab-margin THEN ; : FIRST-LINE ( -- ) \ set first line flag true to first-line? 0tab ; : TABING-ON ( -- ) true to tabing? ; : TABING-OFF ( -- ) false to tabing? ; synonym tabbing-off tabing-off synonym tabbing-on tabing-on : x_CRTAB ( -- ) x_cr \ fixed stack overflow bug November 15th, 2003 - 13:26 dbu tabing? 0= ?exit first-line? if left-margin indent + spaces false to first-line? else left-margin spaces tab-margin spaces then ; DEFER CRTAB ' x_CRTAB IS CRTAB : ?LINE ( n1 -- ) 0 max getxy drop + wrap? if cr then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Additional words for the console \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ WINLIBRARY W32FCONSOLE.DLL LIBRARY W32FCONSOLE.DLL 1 PROC k_fpushkey 2 PROC c_setfgbg 0 PROC c_getfg 0 PROC c_getbg 0 PROC c_thescreen 0 PROC c_charwh 2 PROC c_setcharwh 2 PROC c_resize 1 PROC c_setcursorheight 0 PROC c_getcursorheight 1 PROC c_wscroll 0 PROC c_rowoffset 0 PROC c_maxcolrow 2 PROC c_setmaxcolrow 1 PROC c_setfont : x_pushkey ( c1 -- ) \ push c1 into the keyboard input stream Call k_fpushkey drop ; : x_"pushkeys ( a1 n1 -- ) \ push the characters of string a1,n1 0max 127 min bounds ?do i c@ x_pushkey loop ; 1 PROC GetKeyState : x_shiftmask ( -- mask ) 0 17 ( VK_CONTROL ) Call GetKeyState 32768 and \ if control is down if control_mask or then \ then include control bit 16 ( VK_SHIFT ) Call GetKeyState 32768 and \ if shift is down if shift_mask or then ; \ then include shift bit : ?shift ( -- f1 ) \ return true if shift is down shiftmask shift_mask and 0<> ; : ?control ( -- f1 ) \ return true if control is down shiftmask control_mask and 0<> ; : x_cursorinview ( -- ) \ make sure cursor is visible in the window ; : x_fgbg! ( forground background -- ) Call c_setfgbg drop ; : x_fg@ ( -- foreground ) Call c_getfg ; : x_bg@ ( -- background ) Call c_getbg ; : x_&the-screen ( -- a1 ) \ get the forth relative address of the users \ console screen memory buffer Call c_thescreen ; : x_charWH ( -- width height ) \ get the width and height of the \ current console font Call c_charwh word-split swap ; 3 PROC InvalidateRect : ConsoleRepaint ( -- ) \ redraw console window 1 0 _conHndl call InvalidateRect drop ; : x_SetcharWH ( width height -- ) \ set the width and height of the Call c_setcharwh drop \ current console font ConsoleRepaint ; \ force repaint : x_setcolrow ( cols rows -- ) \ set the console size Call c_resize drop ; : SetConsoleFont ( hFont -- ) \ set the console font. If hFont is NULL the \ default font will be set. call c_setfont drop ConsoleRepaint ; \ force repaint \ Usage of SetConsoleFont: \ \ Font cFont \ 16 Height: cFont \ 8 Width: cFont \ s" Courier New" SetFaceName: cFont \ FW_NORMAL Weight: cFont \ Create: cFont \ Handle: cFont SetConsoleFont \ zHandle: cFont \ don't let Win32Forth destroy the font; the console does it !!! synonym set-consize setcolrow 4 PROC SetWindowPos : set-conpos ( x y -- ) \ set the console position 2>r ( SWP_NOSIZE ) 1 0 0 2r> ( HWND_TOP ) 0 _conHndl call SetWindowPos drop ; 1 PROC SetCursor 2 PROC LoadCursor : set-pointer ( pointer-identifier -- ) \ set the pointer shape 0 call LoadCursor call SetCursor drop ; : x_set-cursor ( cursor-height -- ) \ set the cursor height Call c_setcursorheight drop ; : x_get-cursor ( -- cursor-height ) \ get the cursor height Call c_getcursorheight ; \ Note: The cursor hight is used by the Line Editor (in Lineedit.f) to \ show the current insert/overstrike mode. So a direct call to \ set-cursor, big-cursor or norm-cursor doesn't show any efect at all. : big-cursor ( -- ) \ set a block cursor charWH nip set-cursor ; 2 value norm-height \ hold the norm cursor height : norm-cursor ( -- ) \ set a normal cursor norm-height set-cursor ; 0 value havemenu? : havemenu! ( flag -- ) to havemenu? ; 1 PROC GetDC : conDC ( -- dc ) \ get the console device context _conHndl call GetDC ; 0 value saveconx 0 value savecony 2 PROC ShowWindow : show-window ( n -- ) _conHndl call ShowWindow drop ; : hide-console ( -- ) saveconx ?exit getcolrow to savecony to saveconx ( SW_HIDE ) 0 show-window ; : unhide-console ( -- ) saveconx 0= ?exit ( SW_SHOW ) 5 show-window saveconx savecony setcolrow \ resize to original size 0 to saveconx 0 to savecony ; synonym show-console unhide-console : normal-console ( -- ) \ un-minimizes a minimized console window ( SW_NORMAL ) 1 show-window ; 1 PROC SetFocus : focus-console ( -- ) _conHndl call SetFocus drop ; : x_setrowoff ( n1 -- ) \ set the console row offset Call c_wscroll drop ; : x_getrowoff ( -- n1 ) \ get the current console row offset Call c_rowoffset ; : x_getmaxcolrow ( -- maxcols maxrows ) \ get maximum window columns Call c_maxcolrow word-split ; : x_setmaxcolrow ( maxcols maxrows -- ) \ set the saved screen area and clear 16384 min 20 max swap \ clip rows 256 min 26 max \ clip columns Call c_setmaxcolrow drop ; ' X_CURSORINVIEW IS CURSORINVIEW ' X_FGBG! IS FGBG! ' X_FG@ IS FG@ ' X_BG@ IS BG@ ' X_PUSHKEY IS PUSHKEY ' X_"PUSHKEYS IS "PUSHKEYS ' X_&THE-SCREEN IS &THE-SCREEN ' X_CHARWH IS CHARWH ' X_SETCHARWH IS SETCHARWH ' X_SHIFTMASK IS SHIFTMASK ' X_SETCOLROW IS SETCOLROW ' X_SET-CURSOR IS SET-CURSOR ' X_GET-CURSOR IS GET-CURSOR ' X_SETROWOFF IS SETROWOFF ' X_GETROWOFF IS GETROWOFF ' X_GETMAXCOLROW IS GETMAXCOLROW ' X_SETMAXCOLROW IS SETMAXCOLROW \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Facility extension words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ SYNONYM EKEY KEY ( -- u ) SYNONYM EKEY? KEY? ( -- flag ) : ekey>char ( u -- u false | char true ) \ returns TRUE if displayable character dup 0 255 between ; TRUE constant emit? ( -- flag ) \ return TRUE if its ok to emit a character \s \ arm removed 17/05/2005 23:36:13 \ All internal console I/O words have an x_ prefix now. \ The following words are deprecated. \ They are added for compatiblity to existing code only. SYNONYM _INIT-CONSOLE x_INIT-CONSOLE DEPRECATED SYNONYM _INIT-SCREEN x_INIT-SCREEN DEPRECATED SYNONYM _ACCEPT x_ACCEPT DEPRECATED SYNONYM _TYPE x_TYPE DEPRECATED SYNONYM _EMIT x_EMIT DEPRECATED SYNONYM _CR x_CR DEPRECATED SYNONYM _CLS x_CLS DEPRECATED SYNONYM _?CR x_?CR DEPRECATED SYNONYM _SIZESTATE x_SIZESTATE DEPRECATED SYNONYM _GOTOXY x_GOTOXY DEPRECATED SYNONYM _GETXY x_GETXY DEPRECATED SYNONYM _GETCOLROW x_GETCOLROW DEPRECATED SYNONYM _MARKCONSOLE x_MARKCONSOLE DEPRECATED SYNONYM _BYE k_BYE DEPRECATED --- NEW FILE: LINEEDIT.F --- \ $Id: LINEEDIT.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ LEDIT.SEQ Line Editor Utility by Tom Zimmer cr .( Loading Line Editor...) \ 07-18-95 SMuB replaced getxy and gotoxy calls with _legetxy, _legotoxy. \ These routines use buffer coordinates instead of screen coordinates \ since screen coordinates are volatile. (( Here is a relatively simple editor for editing one line strings. Support is provided for strings up to 255 characters in length, with full word and character operations using keypad or WordStar keys as follows: Ctrl-A Left word Ctrl-S Left character Ctrl-D Right character Ctrl-F Right word Ctrl-G Forward delete Ctrl-T Word delete Ctrl-Y Line delete or clear Left arrow Left character Ctrl-Left arrow Left word Right arrow Right character Ctrl-Right arrow Right word Home Beginning of line End End of line ESC Discard changes and leave Return/Enter Save changes and leave The parameters needed by LINEEDIT are as follows: lineeditor ( x y a1 n1 --- ) x = char pos on row, zero = left edge y = row number, zero = top line a1 = counted string n1 = edit limit length, maximum value = 80 Here is an example of a command that would edit a line of text in SAMPLEBUFFER, with a maximum length of 12 characters, at location row 10 column 5 on the screen. 5 10 samplebuffer 12 lineedit Two auto resetting flags can be used to control the behavior of the line editor in special ways. The STRIPING_BL'S boolean "VALUE" determines whether the line editor will strip trailing blanks from an edited string at the completion of the edit. this VALUE defaults to TRUE, do strip trailing blanks. false to STRIPPING_BL'S will prevent line edit from stripping spaces. The AUTOCLEAR boolean "VALUE" determines whether the line edit buffer will be automatically cleared if the first character you enter on starting an edit is a normal text char. This is used to ease the users life in the situation where you want to give them the option of re-using a string or easily entering a new one without having to delete the old string first. This VALUE defaults to FALSE, no autoclear. true to AUTOCLEAR will cause line edit to automatically clear the edit string if a letter if the first thing entered. )) \ only forth also definitions anew -lineedit.f in-application INTERNAL \ internal words start here EXTERNAL true value stripping_bl's \ are we stripping trailing blanks? false value autoclear \ automatically clear line if first true value insertmode \ insert/overwrite mode flag INTERNAL \ internal words start here variable saveflg \ are we saving the results 0 value ?ldone \ is line edit done? 0 value lchar \ recent line edit character 0 value ledit-x \ where we are editing X 0 value ledit-y \ where we are editing Y 0 value lenlimit \ line edit length limit defer ledbutton ' noop is ledbutton MAXCOUNTED constant maxedit create editbuf MAXSTRING allot \ our edit buffer, editbuf off \ 255 characters max 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates getxy getrowoff + invert ; : _legotoxy ( x y --- ) \ Goto screen or buffer coordinates dup 0< if \ if y is negative, go to buffer coordinates (x,~y) invert dup getrowoff dup rows + 1- between 0= if \ If the desired buffer y is not in the window, scroll it in dup rows - 1+ setrowoff then getrowoff - then gotoxy ; : lcalcx ( -- x ) \ calculate cursor x positon editpos COLS /mod drop ledit-x + ; : lcalcy ( -- y ) \ calculate cursor y positon editpos COLS / ledit-y - getrowoff 0= if 1- then ; \ rewritten for better line wraping \ Sonntag, Januar 16 2005 dbu : .lecursor ( --- ) \ show the cursor \+ accept-cnt editpos to accept-cnt lcalcx lcalcy _legotoxy ; : .leline ( --- ) \ redisplay edit line ledit-x ledit-y _legotoxy editbuf count type lenlimit ledit-x + COLS 1- min COL ; : __le-ldel ( -- ) \ Line delete 0 editbuf c! 0 to editpos ; : _lichar ( c1 -- ) autoclear \ should we clear the line on the if __le-ldel \ first character typed? false to autoclear then insertmode if editbuf 1+ editpos + dup 1+ maxedit editpos - move editbuf c@ 1+ lenlimit min editbuf c! then editbuf 1+ editpos + c! \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ lenlimit min ( COLS 1- min ) to editpos editpos editbuf c@ max editbuf c! ; : ?lechar ( --- ) \ handle normal keys, insert them lchar bl 0xFF between if lchar _lichar then ; : _le-home ( --- ) \ beginning of line 0 to editpos ; : _le-end ( --- ) \ End of line editbuf c@ to editpos ; : _le-right ( --- ) \ right a character \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ editbuf c@ min ( COLS 1- min ) to editpos ; : _le-left ( --- ) \ left a character editpos 1- 0MAX to editpos ; : _ledone ( --- ) \ flag edit is finished, save changes true to ?ldone saveflg on ; : _lequit ( false --- true ) \ flag edit is finished, discard chngs true to ?ldone \+ mark-none mark-none saveflg off ; defer _le-ret ' _ledone is _le-ret defer _le-tab ' _ledone is _le-tab defer _le-quit ' _lequit is _le-quit defer _le-LF ' noop is _le-LF defer _le-pgup ' noop is _le-pgup defer _le-pgdn ' noop is _le-pgdn defer _le-up ' noop is _le-up defer _le-down ' noop is _le-down defer _le-ldel ' __le-ldel is _le-ldel : _le-fdel ( --- ) \ Forward delete editpos 1+ editbuf c@ max editbuf c! editbuf 1+ editpos + dup 1+ swap maxedit editpos - move -1 editbuf c+! ; : >to=bl ( --- ) \ forward to a blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl = ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : >to<>bl ( --- ) \ forward to a non blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl <> ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : _le-rword ( --- ) \ Forward to next word >to=bl >to<>bl ; : <to=bl+1 ( --- ) \ back to char following BL editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl = ?leave -1 +to editpos -1 +loop ; : <to<>bl ( --- ) \ Back to non blank editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl <> ?leave -1 +to editpos loop ; : _le-lword ( --- ) \ back a word <to<>bl <to=bl+1 ; : _le-bdel ( --- ) \ back delete editpos editbuf c@ max editbuf c! editpos ( --- f1 ) _le-left ( --- f1 ) if insertmode \ if we are in insertmode if _le-fdel \ then delete the character else bl editbuf 1+ editpos + c! \ else change char to blank then else beep then ; : _le-wdel ( --- ) \ word delete begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl <> and while _le-fdel repeat begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl = and while _le-fdel repeat ; : strip_bl's ( --- ) \ strip blanks from editbuf editpos >r _le-end begin _le-left editbuf 1+ editpos + c@ bl = editpos 0<> and while _le-fdel repeat editbuf c@ r> min 0MAX to editpos editbuf c@ 1 = \ count=1 & char=blank editbuf 1+ c@ bl = and if 0 editbuf c! \ then reset buffer to empty then ; : _le-ins ( --- ) \ toggle insert mode insertmode 0= dup to insertmode if big-cursor else norm-cursor then ; : _le-any ( --- ) \ handle any character entry ; create control-tab ' noop , ' _le-lword , ' noop , ' _le-pgdn , ' _le-right , ' _le-up , ' _le-rword , ' _le-fdel , ' _le-bdel , ' _le-tab , ' _le-LF , ' noop , ' noop , ' _le-ret , ' noop , ' noop , ' noop , ' noop , ' _le-pgup , ' _le-left , ' _le-wdel , ' noop , ' _le-ins , ' noop , ' _le-down , ' _le-ldel , ' noop , ' _le-quit , ' noop , ' noop , ' noop , ' noop , : ?control ( --- ) \ handle control characters lchar bl < if false to autoclear \ no auto clear now \ temp changed: because EXEC: must be ported first (( lchar exec: \ 0 null 1 a 2 b 3 c 4 d 5 e 6 f noop _le-lword noop _le-pgdn _le-right _le-up _le-rword \ 7 g 8 h 9 i LF 11 k 12 l Enter _le-fdel _le-bdel _le-tab _le-LF noop noop _le-ret \ 14 n 15 o 16 p 17 q 18 r 19 s 20 t noop noop noop noop _le-pgup _le-left _le-wdel \ 21 u 22 v 23 w 24 x 25 y 26 z Esc noop _le-ins noop _le-down _le-ldel noop _le-quit \ 28 \ 29 ] 30 ^ 31 _ noop noop noop noop )) lchar cells control-tab + @ execute then ; : ?func ( --- ) \ handle function keys \ if function key bit is set lchar function_mask special_mask or and \ func or special lchar shift_mask and shift_mask = or \ or Shift mask lchar bl < or \ or control key if \ or other keypad key false to autoclear \ no auto clear now \ "ledit-chain" allows addingto or over-riding a function ckey at Forth commandline \ use CHAIN-ADD to add a function test, and CHAIN-ADD-BEFORE to over-ride an \ existing functionkey during commandline editing. lchar FALSE ledit-chain do-chain 0= if case k_home of _le-home endof \ Home k_up of _le-up endof \ Up arrow k_pgup of _le-PgUp endof \ PgDn k_left of _le-left endof \ Left arrow k_right of _le-right endof \ Right arrow k_end of _le-end endof \ End k_down of _le-down endof \ Down arrow k_pgdn of _le-PgDn endof \ PgDn k_insert of _le-ins endof \ Ins k_delete of _le-fdel endof \ Del k_left +k_control of _le-lword endof \ Ctrl Left arrow k_right +k_control of _le-rword endof \ Ctrl Right arrow endcase else drop \ already handled, discard key value 0 to lchar then then ; \ c1 = keyboard character \ f1 = true for done editing : _le-key ( c1 --- ) \ process a key to lchar ?lechar \ handle normal ascii ?func \ function characters ?control ; \ control chars \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length : <ledit> ( x y a1 n1 --- ) \ Edit line currently in EDITBUF. lenlimit >r get-cursor >r over c@ editpos min to editpos maxedit min to lenlimit \ save max edit length dup >r \ save source address editbuf over c@ lenlimit min 1+ move editbuf c@ lenlimit min editbuf c! dup 0< 0= \ SMuB if getrowoff + invert \ SMuB then \ SMuB to ledit-y to ledit-x \ save origin false to insertmode _le-ins _le-ins false to ?ldone begin .leline .lecursor key _le-key ?ldone until saveflg @ dup \ proper save exit if stripping_bl's \ do we want to strip blanks? if strip_bl's then true to stripping_bl's \ force it next time editbuf r@ over c@ lenlimit min 1+ move then r>drop r> set-cursor ( --- f1 ) r> to lenlimit false to autoclear ; \ no automatic line clear EXTERNAL \ externally available words start here \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length \ f1 = true for saved changes \ f1 = false for canceled with ESC : lineeditor ( x y a1 n1 --- f1 ) \ Edit line in a1 \ defer@ _le-quit >r ['] _lequit is _le-quit \ defer@ _le-LF >r ['] noop is _le-LF ['] _le-quit defer@ >r ['] _lequit is _le-quit ['] _le-LF defer@ >r ['] noop is _le-LF 0 to editpos <ledit> r> is _le-LF r> is _le-quit ; \ TEST TEST TEST \ create buf 200 allot \ 0 10 buf 100 lineeditor drop \ buf count type INTERNAL \ --------------------------------------------------------------------------- \ Line editor version of ACCEPT \ --------------------------------------------------------------------------- MAXSTRING constant b/accept \ each commandline is MAXSTRING bytes 31 constant n/accept \ save 31 previous command lines \ use 31 to make it fit in 8k bytes 0 value accept# 0 value accepted? \ temp changed: because POINTER.F must be ported first \ b/accept n/accept * Pointer prev-accept-buf create prev-accept-buf b/accept n/accept * allot : accept-init ( -- ) 0 to accept# prev-accept-buf b/accept n/accept * erase ; initialization-chain chain-add accept-init \ add to init chain accept-init create laccept-buf b/accept allot laccept-buf off : +accept# ( n1 -- ) accept# + n/accept mod to accept# ; : prev-accept-buf" ( -- a1 n1 ) \ Get the current line from the line editor buffer. prev-accept-buf accept# b/accept * + count ; : accept-lup? ( -- f ) \ Returns true if it's ok to move one line up in the line editor buffer. accept# 0> ; : accept-lup ( -- ) \ Move one line up in the line editor buffer. accept-lup? if false to accepted? -1 +accept# prev-accept-buf" editbuf place editbuf c@ to editpos else beep then ; : accept-ldown? ( -- f ) \ Returns true if it's ok to move one line down in the line editor buffer. 1 +accept# prev-accept-buf" nip 0> -1 +accept# ; : accept-ldown ( -- ) \ Move one line down in the line editor buffer. accept-ldown? if accepted? 0= if 1 +accept# then false to accepted? prev-accept-buf" editbuf place editbuf c@ to editpos else beep then ; : __laccept ( a1 n1 -- n2 ) \+ ED_READY 0 ED_READY editor-message \ notify editor we are ready ['] accept-lup is _le-up ['] accept-ldown is _le-down laccept-buf c@ \ backup current line if laccept-buf count prev-accept-buf accept# b/accept * + place 1 +accept# then true to accepted? swap >r >r _legetxy laccept-buf dup off r> lineeditor if laccept-buf count r@ swap move laccept-buf c@ _legetxy nip _legotoxy else editbuf off _legetxy nip 0 swap 2dup _legotoxy cols 1- COL _legotoxy 1 +accept# then r>drop laccept-buf c@ ; : _laccept ( a1 n1 -- n2 ) \ line editor version of ACCEPT \ defer@ _le-up >r \ defer@ _le-down >r ['] _le-up defer@ >r ['] _le-down defer@ >r ['] __laccept catch \ -- f1 r> is _le-down \ restore these functions r> is _le-up ( -- f1 ) throw ; ' _laccept is accept ' _laccept to defaultAccept \ make this the default handler MODULE \s variable samplebuffer 128 allot : sample ( --- ) s" Zimmer, Harold" samplebuffer place true to autoclear 10 04 samplebuffer 24 lineeditor drop cr samplebuffer count type ; --- NEW FILE: KEYBOARD.F --- \ $Id: KEYBOARD.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ KEYBOARD.F functon key constants by Tom Zimmer cr .( Loading Function Key Words...) in-system ' CONSTANT alias LITKEY in-application 0x1B litkey K_ESC 0x09 litkey K_TAB 0x08 litkey K_BACKSPACE 0x0D litkey K_CR 0x0A litkey K_LF in-system : fkey ( n1 -<name>- ) function_mask or constant ; in-application 0x01 fkey K_F1 0x02 fkey K_F2 0x03 fkey K_F3 0x04 fkey K_F4 0x05 fkey K_F5 0x06 fkey K_F6 0x07 fkey K_F7 0x08 fkey K_F8 0x09 fkey K_F9 0x10 fkey K_F10 0x11 fkey K_F11 0x12 fkey K_F12 in-system : splkey ( n2 -<name>- ) special_mask or constant ; in-application 0x00 splkey K_HOME 0x01 splkey K_END 0x02 splkey K_INSERT 0x03 splkey K_DELETE 0x04 splkey K_LEFT 0x05 splkey K_RIGHT 0x06 splkey K_UP 0x07 splkey K_DOWN 0x08 splkey K_SCROLL 0x09 splkey K_PAUSE 0x10 splkey K_PGUP 0x11 splkey K_PGDN : +K_SHIFT ( c1 -- c2 ) shift_mask or ; \ add in shift bit \ 07/18/95 08:56 tjz ALT keys are for Windows Use ONLY!" : +K_ALT ( c1 -- c2 ) alt_mask or ; \ add in the Alt bit : +K_CONTROL ( c1 -- c2 ) dup proc_mask 0x7FF or and upc 'A' 'Z' between if 0xFF1F and \ handle control letters else control_mask or \ add in control bit then ; \S The above words are used as shown in the following example: : key_test ( -- ) begin cr ." Press a key, Enter to stop: " key case k_f1 of ." F1" endof k_f2 of ." F2" endof k_f3 of ." F3" endof k_f4 of ." F4" endof k_f5 of ." F5" endof k_f6 of ." F6" endof k_f7 of ." F7" endof k_f8 of ." F8" endof k_f9 of ." F9" endof k_f10 of ." F10" endof k_f11 of ." F11" endof k_f12 of ." F12" endof k_f1 +k_control of ." Control F1" endof k_f2 +k_control of ." Control F1" endof k_f3 +k_control of ." Control F1" endof k_f4 +k_control of ." Control F1" endof k_f5 +k_control of ." Control F1" endof k_f6 +k_control of ." Control F1" endof k_f7 +k_control of ." Control F1" endof k_f8 +k_control of ." Control F1" endof k_f9 +k_control of ." Control F1" endof k_f10 +k_control of ." Control F10" endof k_f11 +k_control of ." Control F11" endof k_f12 +k_control of ." Control F12" endof k_f1 +k_shift of ." Shift F1" endof k_f2 +k_shift of ." Shift F1" endof k_f3 +k_shift of ." Shift F1" endof k_f4 +k_shift of ." Shift F1" endof k_f5 +k_shift of ." Shift F1" endof k_f6 +k_shift of ." Shift F1" endof k_f7 +k_shift of ." Shift F1" endof k_f8 +k_shift of ." Shift F1" endof k_f9 +k_shift of ." Shift F1" endof k_f10 +k_shift of ." Shift F10" endof k_f11 +k_shift of ." Shift F11" endof k_f12 +k_shift of ." Shift F12" endof 0x0D of ." Stopping" exit endof dup h. ." Unknown key" endcase ." pressed." again ; |
|
From: Dirk B. <db...@us...> - 2006-09-23 10:18:41
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19498/src Modified Files: callback.f exception.f extend.f paths.f primutil.f Removed Files: console.f lineedit.f Log Message: Proted the latest Console-code and the LineEditor. Index: exception.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/exception.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** exception.f 21 Sep 2006 16:26:33 -0000 1.1 --- exception.f 23 Sep 2006 10:18:34 -0000 1.2 *************** *** 7,17 **** arm 15/08/2005 22:56:45 First version 0.1 STC based kernel - ! ------------------------- End Change Block ----------------------------- ! Experimental: a fully optimising, STC based, ANS Forth compliant kernel ! Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) --- 7,17 ---- arm 15/08/2005 22:56:45 First version 0.1 STC based kernel ! ! ------------------------- End Change Block ----------------------------- ! Experimental: a fully optimising, STC based, ANS Forth compliant kernel ! Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) *************** *** 20,33 **** Free Software Foundation; either version 2 of the License, or <at your option> any later version. ! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! ------------------------------------------------------------------------ --- 20,33 ---- Free Software Foundation; either version 2 of the License, or <at your option> any later version. ! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! ------------------------------------------------------------------------ *************** *** 40,53 **** Exception Handling ------------------ ! Exeption handling now uses a process wide exception handler to trap all OS generated errors in Win32Forth. The sequence of events is as follows: ! 1. Exception handler set by call to SET-EXCEPT SET-EXCEPT points to a callbnack IN-EXCEPT that does most of the work. ! 2. Code executes, hits some error IN-EXCEPT gets called with 1 parameter. This points to two words: ! DWORD Exception Record DWORD Context Record --- 40,53 ---- Exception Handling ------------------ ! Exeption handling now uses a process wide exception handler to trap all OS generated errors in Win32Forth. The sequence of events is as follows: ! 1. Exception handler set by call to SET-EXCEPT SET-EXCEPT points to a callbnack IN-EXCEPT that does most of the work. ! 2. Code executes, hits some error IN-EXCEPT gets called with 1 parameter. This points to two words: ! DWORD Exception Record DWORD Context Record *************** *** 72,76 **** 9. Returns to OS to undertake the recovery. ! Trapping Memory Write Errors ---------------------------- --- 72,76 ---- 9. Returns to OS to undertake the recovery. ! Trapping Memory Write Errors ---------------------------- *************** *** 78,85 **** This code supports RESERVEing memory using VirtualAlloc, without COMMITting it first. ! First, reserve a range of a process's virtual address space. Reserving address space ! does not allocate any physical storage, but it prevents other allocation operations ! from using the specified range. Reserving pages prevents needless consumption of ! physical storage, while allowing a process to reserve a range of its address space into which a dynamic data structure can grow. Reserved but uncommitted memory will cause ACCESS VIOLATIONS if it is addressed. --- 78,85 ---- This code supports RESERVEing memory using VirtualAlloc, without COMMITting it first. ! First, reserve a range of a process's virtual address space. Reserving address space ! does not allocate any physical storage, but it prevents other allocation operations ! from using the specified range. Reserving pages prevents needless consumption of ! physical storage, while allowing a process to reserve a range of its address space into which a dynamic data structure can grow. Reserved but uncommitted memory will cause ACCESS VIOLATIONS if it is addressed. *************** *** 87,91 **** Once the memory is then committed, it is backed by swap pages and is mapped into the virtual address space. Now it can be used (written and read). ! The support provided here allows storage be reserved only. If a block of storage is reserved, and it is then written to, the exception handler traps the --- 87,91 ---- Once the memory is then committed, it is backed by swap pages and is mapped into the virtual address space. Now it can be used (written and read). ! The support provided here allows storage be reserved only. If a block of storage is reserved, and it is then written to, the exception handler traps the *************** *** 93,106 **** For instance: ! PAGE_NOACCESS MEM_RESERVE 0x400000 0 CALL VirtualAlloc CONSTANT LARGEAREA This reserves but does not consume memory resources. ! 10 LARGEAREA 0x4000 + ! This causes an exception, the memory is COMMITed as PAGE_EXECUTE_READWRITE. Only the page (4K) at LARGEAREA 0x4000 + requires swap and memory resources. ! Catching Errors --- 93,106 ---- For instance: ! PAGE_NOACCESS MEM_RESERVE 0x400000 0 CALL VirtualAlloc CONSTANT LARGEAREA This reserves but does not consume memory resources. ! 10 LARGEAREA 0x4000 + ! This causes an exception, the memory is COMMITed as PAGE_EXECUTE_READWRITE. Only the page (4K) at LARGEAREA 0x4000 + requires swap and memory resources. ! Catching Errors *************** *** 115,119 **** Here's some sample output: ! 0 @ \ fetch from absolute zero --- 115,119 ---- Here's some sample output: ! 0 @ \ fetch from absolute zero *************** *** 136,140 **** Invoking word CONSOLE-STATUSBAR-INTERPRET loaded from: ...SRC\CONSOLE\CONSOLESTATBAR.F at line: 92 fails at word _INTERPRET loaded from: SRC\FKERNEL.F at line: 4238 ! For TURNKEYed applications, only the registers are shown. --- 136,140 ---- Invoking word CONSOLE-STATUSBAR-INTERPRET loaded from: ...SRC\CONSOLE\CONSOLESTATBAR.F at line: 92 fails at word _INTERPRET loaded from: SRC\FKERNEL.F at line: 4238 ! For TURNKEYed applications, only the registers are shown. *************** *** 161,166 **** -1 CONSTANT EXCEPTION_CONTINUE_EXECUTION - : \IN-SYSTEM-OK ; immediate \ temporary - 9998 CONSTANT THROW_WINEXCEPT \ " Windows exception trapped" THROW_MSGS LINK, THROW_WINEXCEPT , ," Windows exception trapped" --- 161,164 ---- *************** *** 316,320 **** &except @ 0= if cr ." * No exception has occurred *" ! else except-io cr .version --- 314,318 ---- &except @ 0= if cr ." * No exception has occurred *" ! else except-io cr .version *************** *** 327,333 **** if ." WRITE" else ." READ" then ." violation" then ! context-buffer ! cr ." Registers:" cr dup eax ." eax" .exreg --- 325,331 ---- if ." WRITE" else ." READ" then ." violation" then ! context-buffer ! cr ." Registers:" cr dup eax ." eax" .exreg Index: callback.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/callback.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** callback.f 21 Sep 2006 16:26:33 -0000 1.1 --- callback.f 23 Sep 2006 10:18:34 -0000 1.2 *************** *** 12,16 **** \ When Windows calls back into user code, the address passed as one of the \ parameters to the call to windows is the address of a routine to handle ! \ the callback. We must save the caller's registers, and set up the new data \ stack. --- 12,16 ---- \ When Windows calls back into user code, the address passed as one of the \ parameters to the call to windows is the address of a routine to handle ! \ the callback. We must save the caller's registers, and set up the new data \ stack. *************** *** 24,35 **** \ of cells passed as parameters. Sets up the stacks to meet \ the internal requirements of Win32Forth. The word <ExternalName> ! \ is not callable directly from Forth, and is defined in a \ case-sensitive vocabulary; but call-proc can be used \ to test the word. See the example. ! \ Because of the way the callback restores registers on exit, the stack does \ not need to be clean on exit; the value on the top of the stack is taken as \ the return value. There is a limit of around 4K or 1024 parameters maximum ! \ on the stack (referenced by ebp), so be carefule that very deep nesting may \ well overrun the stack. --- 24,35 ---- \ of cells passed as parameters. Sets up the stacks to meet \ the internal requirements of Win32Forth. The word <ExternalName> ! \ is not callable directly from Forth, and is defined in a \ case-sensitive vocabulary; but call-proc can be used \ to test the word. See the example. ! \ Because of the way the callback restores registers on exit, the stack does \ not need to be clean on exit; the value on the top of the stack is taken as \ the return value. There is a limit of around 4K or 1024 parameters maximum ! \ on the stack (referenced by ebp), so be carefule that very deep nesting may \ well overrun the stack. *************** *** 98,102 **** call xt \ call the code n cb-exit ! ]macro r> set-current previous \ original definitions postpone ; ; \ back to compiler --- 98,102 ---- call xt \ call the code n cb-exit ! ]macro r> set-current previous \ original definitions postpone ; ; \ back to compiler *************** *** 108,111 **** --- 108,112 ---- -1 value WM_WIN32FORTH + library gdi32.dll 1 PROC TranslateMessage 1 PROC DispatchMessage Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** extend.f 23 Sep 2006 07:32:38 -0000 1.3 --- extend.f 23 Sep 2006 10:18:34 -0000 1.4 *************** *** 9,19 **** fload src\numconv.f \ general number conversions - : nostack1 ; immediate - sys-fload src\486asm.f \ jim's 486 assembler sys-fload src\asmmac.f \ jim's 486 macros sys-fload src\asmwin32.f \ next for win32forth ! fload src\console.f \ console i/o extracted from primutil.f sys-fload src\dotwords.f \ dot support words sys-fload src\imageman.f \ fsave, application & turnkey words --- 9,19 ---- fload src\numconv.f \ general number conversions sys-fload src\486asm.f \ jim's 486 assembler sys-fload src\asmmac.f \ jim's 486 macros sys-fload src\asmwin32.f \ next for win32forth ! fload src\console\console.f \ console i/o extracted from primutil.f ! fload src\console\console2.f \ console i/o extracted from primutil.f sys-fload src\dotwords.f \ dot support words + FLOAD src\paths.f \ multi path support words sys-fload src\imageman.f \ fsave, application & turnkey words *************** *** 25,31 **** FLOAD src\float.f \ floating point support ! : DEPRECATED ; immediate ! ! FLOAD src\paths.f \ multi path support words .olly --- 25,30 ---- FLOAD src\float.f \ floating point support ! FLOAD src\console\keyboard.f \ function and special key constants ! FLOAD src\console\lineedit.f \ a line editor utility .olly Index: paths.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/paths.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** paths.f 23 Sep 2006 07:32:38 -0000 1.1 --- paths.f 23 Sep 2006 10:18:34 -0000 1.2 *************** *** 8,12 **** cr .( Loading Path Functions...) ! \ anew -paths.f internal --- 8,12 ---- cr .( Loading Path Functions...) ! anew -paths.f internal *************** *** 473,479 **** loaded? 0= if postpone \ then ; ! : NEEDS ( -<name>- ) \ *G Conditionally load file "name" if not loaded. ! >in @ loaded? 0= if >in ! fload else drop then ; synonym Require needs --- 473,479 ---- loaded? 0= if postpone \ then ; ! \ : NEEDS ( -<name>- ) \ *G Conditionally load file "name" if not loaded. ! \ >in @ loaded? 0= if >in ! fload else drop then ; synonym Require needs --- lineedit.f DELETED --- --- console.f DELETED --- Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** primutil.f 21 Sep 2006 16:26:33 -0000 1.1 --- primutil.f 23 Sep 2006 10:18:34 -0000 1.2 *************** *** 5,15 **** \ arm 15/08/2005 22:56:45 \ First version 0.1 STC based kernel - \ \ ! \ \ ------------------------- End Change Block ----------------------------- ! \ \ Experimental: a fully optimising, STC based, ANS Forth compliant kernel ! \ \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) \ Dirk Busch (dirk.yahoo @ schneider-busch.de) --- 5,15 ---- \ arm 15/08/2005 22:56:45 \ First version 0.1 STC based kernel \ ! \ ! \ \ ------------------------- End Change Block ----------------------------- ! \ \ Experimental: a fully optimising, STC based, ANS Forth compliant kernel ! \ \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) \ Dirk Busch (dirk.yahoo @ schneider-busch.de) *************** *** 19,32 **** \ Free Software Foundation; either version 2 of the License, or <at your \ option> any later version. ! \ \ This program is distributed in the hope that it will be useful, but \ WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU \ General Public License for more details. ! \ \ You should have received a copy of the GNU General Public License along \ with this program; if not, write to the Free Software Foundation, Inc., \ 675 Mass Ave, Cambridge, MA 02139, USA. ! \ \ ------------------------------------------------------------------------ --- 19,32 ---- \ Free Software Foundation; either version 2 of the License, or <at your \ option> any later version. ! \ \ This program is distributed in the hope that it will be useful, but \ WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU \ General Public License for more details. ! \ \ You should have received a copy of the GNU General Public License along \ with this program; if not, write to the Free Software Foundation, Inc., \ 675 Mass Ave, Cambridge, MA 02139, USA. ! \ \ ------------------------------------------------------------------------ *************** *** 35,41 **** decimal \ start everything in decimal ! in-system \ Some comment words gleaned from various Forths, and C of course. : _commeof \ ( flag -- ) --- 35,54 ---- decimal \ start everything in decimal ! \ ------------------------------------------------------------------------ ! \ Some words that must be ported some time... ! \ ------------------------------------------------------------------------ ! ! in-application + : NOSTACK1 ; immediate \ *** to be done *** + : DEPRECATED ; immediate \ *** to be done *** + : ANEW BL WORD DROP ; immediate \ *** to be done *** + : IS-DEFAULT BL WORD 2DROP ; immediate \ *** to be done *** + + \ ------------------------------------------------------------------------ \ Some comment words gleaned from various Forths, and C of course. + \ ------------------------------------------------------------------------ + + in-system : _commeof \ ( flag -- ) *************** *** 57,61 **** : comment \ -<char>- char _comment ; immediate ! : "comment ( a1 n1 -- ) \ everything is a comment up to the string a1,n1 begin --- 70,74 ---- : comment \ -<char>- char _comment ; immediate ! : "comment ( a1 n1 -- ) \ everything is a comment up to the string a1,n1 begin *************** *** 77,83 **** : doc s" enddoc" "comment ; immediate \ comment till enddoc ! ! \ ----------------------- Various support words -------------------------- ' included alias "fload --- 90,96 ---- : doc s" enddoc" "comment ; immediate \ comment till enddoc ! \ ------------------------------------------------------------------------ \ ----------------------- Various support words -------------------------- + \ ------------------------------------------------------------------------ ' included alias "fload *************** *** 101,105 **** --- 114,120 ---- over offset + ; + \ ------------------------------------------------------------------------ \ -------------------------- Chain definitions --------------------------- + \ ------------------------------------------------------------------------ new-chain initialization-chain \ chain of things to initialize *************** *** 134,138 **** reset-stack-chain do-chain ; is reset-stacks \ install in kernel word ! : (viewinfo) ( nfa -- line# addr ) \ find source for word dup >vfa@ swap >ffa@ \ fetch line #, file name over 1 < \ view < 1 --- 149,157 ---- reset-stack-chain do-chain ; is reset-stacks \ install in kernel word ! \ ------------------------------------------------------------------------ ! \ ------------------------------------------------------------------------ ! ! : (viewinfo) ( nfa -- line# addr ) ! \ *G Find source for word. dup >vfa@ swap >ffa@ \ fetch line #, file name over 1 < \ view < 1 *************** *** 143,147 **** then ; ! : .viewinfo ( nfa -- ) \ print file & line # (viewinfo) ." loaded from " count type 15 ?cr --- 162,167 ---- then ; ! : .viewinfo ( nfa -- ) ! \ *G Print file & line # (viewinfo) ." loaded from " count type 15 ?cr *************** *** 150,151 **** --- 170,193 ---- else drop then ; + \ ------------------------------------------------------------------------ + \ ------------------------------------------------------------------------ + + : \- ( "word" -- ) + \ *G Interpret the rest of the line if "word" isn't defined. + defined nip + if POSTPONE \ + then ; immediate + + : \+ ( "word" -- ) + \ *G Interpret the rest of the line if "word" is defined. + defined nip 0= + if POSTPONE \ + then ; immediate + + : \IN-SYSTEM-OK ( -<line_to_interpret>- ) + \ *G Suppress in-system warnings for the rest of the current line, restoring the previous + \ ** state of the sys-warning? flag afterwards, even if an error occurs. + sys-warning? >r + sys-warning-off + ['] interpret catch + r> to sys-warning? throw ; immediate |
|
From: Dirk B. <db...@us...> - 2006-09-23 10:18:41
|
Update of /cvsroot/win32forth/win32forth-stc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19498 Modified Files: gkernel.exe w32fConsole.dll Log Message: Proted the latest Console-code and the LineEditor. Index: gkernel.exe =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 Binary files /tmp/cvsPpfKq8 and /tmp/cvsMsP9Ew differ Index: w32fConsole.dll =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/w32fConsole.dll,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 Binary files /tmp/cvspUuBhh and /tmp/cvsoDjCLF differ |
|
From: George H. <geo...@us...> - 2006-09-23 09:54:32
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9400/win32forth-stc/src/kernel Modified Files: gkernel.f Log Message: gah:Fixed bug in loocals plus correct (tested) version of previous mods Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** gkernel.f 22 Sep 2006 10:31:57 -0000 1.2 --- gkernel.f 23 Sep 2006 09:54:28 -0000 1.3 *************** *** 3470,3480 **** ; ! : inline ( -- ) \ code will be inlined ! tail-call 0= if \ there's at least one call, so no inline ! ['] xt-inline, ! last @ name>ct cell- ! \ comp field then ; - : compiles ( xt2 <name> -- ) \ parsing; set the compilation word ' (compiles) ; \ stack will be ( xt -- ) --- 3470,3478 ---- ; ! : inline ( -- ) \ code will be inlined ! tail-call 0= if \ there's at least one call, so no inline ! ['] xt-inline, last @ name>ct cell- ! \ comp field then ; : compiles ( xt2 <name> -- ) \ parsing; set the compilation word ' (compiles) ; \ stack will be ( xt -- ) *************** *** 3669,3695 **** 0x10 proc-modify ; ! |: compile-call ( xt -- ) ! ignore-missing-procs? not if \ should we ignore missing? ! res-multi-libs \ else resolve call now! ! then ! postpone literal _call move-code ! winproc-last @ proc>pcnt c@ dup $10 and ! if $0f and ?dup ! if _stdcall move-code ! cells code-here 1- code-c! ! then ! else drop ! then ; \ -------------------- Calling Procedures ----------------------------------- : proc>xt ( -<proc>- -- xt ) ! 0x80 parse-word #"proc ; \ build the proc (0x80 =unknown # parms) ! -1 1 in/out : call ( [args..] -<proc>- -- result ) \ compile or ! execute a windows procedure ! proc>xt (call) \ interpret ! compilation> drop \ and while compiling ! proc>xt compile-call ; --- 3667,3695 ---- 0x10 proc-modify ; ! |: compile-call ( xt -- ) ! ignore-missing-procs? not if \ should we ignore missing? ! res-multi-libs \ else resolve call now! ! then ! postpone literal _call move-code ! winproc-last @ proc>pcnt c@ dup $10 and ! if $0f and ?dup ! if _stdcall move-code ! cells code-here 1- code-c! ! then ! else drop ! then ! ; ! ! \ -------------------- Calling Procedures ----------------------------------- : proc>xt ( -<proc>- -- xt ) ! 0x80 parse-word #"proc ; \ build the proc (0x80 = unknown # parms) ! -1 1 in/out : call ( [args..] -<proc>- -- result ) \ compile or execute a windows procedure ! proc>xt (call) \ interpret ! compilation> drop \ and while compiling ! proc>xt compile-call ; *************** *** 4576,4580 **** 0 to tail-call \ will be non-zero if we have any calls header hide ! ['] ;name (:noname) \ set the named ; word ; --- 4576,4580 ---- 0 to tail-call \ will be non-zero if we have any calls header hide ! ['] ;name (:noname) \ set the named ; word ; *************** *** 4589,4594 **** ; ! : as ( 'name' -- ) \ make name an alias of call last ! winproc : winproc-last @ proc>ep compile-call postpone ; inline ; \ ---------------------------- DOES> ----------------------------------- --- 4589,4595 ---- ; ! : as ( 'name' -- ) \ make name an alias of call last winproc ! : winproc-last @ proc>ep compile-call ! postpone ; inline ; \ ---------------------------- DOES> ----------------------------------- *************** *** 5335,5338 **** --- 5336,5340 ---- 1 +to localstk \ total count of stack parms localstk #-locals > throw_localstoomany ?throw + get-current >r \ save current also locals definitions \ move to locals area last @ last-link @ 2>r \ save last (we wipe out) *************** *** 5345,5349 **** r> latestxt ! 2r> last-link ! last ! \ restore last, last-link ! previous definitions \ back out of locals locflg +to localsi \ locflg counts initialised else 2drop localsgen, \ go on to create locals --- 5347,5351 ---- r> latestxt ! 2r> last-link ! last ! \ restore last, last-link ! previous r> set-current \ back out of locals locflg +to localsi \ locflg counts initialised else 2drop localsgen, \ go on to create locals *************** *** 5423,5427 **** ; ! : +to ( n -<value>- -- ) \ add to a value [to] +! \ runtime compilation> drop --- 5425,5429 ---- ; ! : +to ( n -<value>- -- ) \ set a value [to] +! \ runtime compilation> drop *************** *** 5429,5437 **** ; ! : &of ( -<value>- -- addr ) \ get address ! [to] \ runtime compilation> drop ! _to ; \ compile time ! \ -------------------- Locals Allocation on rstack -------------------------- --- 5431,5438 ---- ; ! : &of ( -<value>- -- addr ) ! [to] compilation> drop ! _to ; \ -------------------- Locals Allocation on rstack -------------------------- |
|
From: Dirk B. <db...@us...> - 2006-09-23 09:51:01
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7871/console Log Message: Directory /cvsroot/win32forth/win32forth-stc/src/console added to the repository |
|
From: George H. <geo...@us...> - 2006-09-23 09:49:45
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7441/win32forth/src Modified Files: ANSFILE.F Log Message: gah:Fixed bug in dir in ansfile Index: ANSFILE.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/ANSFILE.F,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** ANSFILE.F 22 Sep 2006 10:50:20 -0000 1.8 --- ANSFILE.F 23 Sep 2006 09:49:37 -0000 1.9 *************** *** 310,319 **** \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n \ *P The pattern can contain the standard Windows wildcards. ! /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place ! THEN dup count + 1- c@ [char] : = \ if just a drive, add \ IF s" \" pocket +place ! THEN dup count + 1- c@ dup [char] \ \ if it ends in a \, ! swap [char] / = or \ or a /, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; --- 310,319 ---- \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n \ *P The pattern can contain the standard Windows wildcards. ! /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place ! THEN dup count + 1- c@ [char] : = \ if just a drive, add \ IF s" \" pocket +place ! THEN dup count + 1- c@ dup [char] \ = \ if it ends in a \, ! swap [char] / = or \ or a /, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; |
|
From: Dirk B. <db...@us...> - 2006-09-23 07:32:41
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21094/src Modified Files: extend.f Added Files: paths.f Log Message: Ported the Path support to the STC-Kernel. Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** extend.f 23 Sep 2006 06:00:17 -0000 1.2 --- extend.f 23 Sep 2006 07:32:38 -0000 1.3 *************** *** 24,30 **** --- 24,36 ---- 8 constant B/FLOAT \ default to 8 byte floating point numbers FLOAD src\float.f \ floating point support + + : DEPRECATED ; immediate + + FLOAD src\paths.f \ multi path support words + .olly + \s \ FLOAD src\lineedit.f \ a line editor utility --- NEW FILE: paths.f --- \ $Id: paths.f,v 1.1 2006/09/23 07:32:38 dbu_de Exp $ \ *D doc\ \ *! Paths \ *T Paths -- Multiple search path support \ *S Glossary cr .( Loading Path Functions...) \ anew -paths.f internal external in-application [undefined] deprecated [if] : deprecated ; immediate [endif] [undefined] defextz$ [if] : defextz$ defext$ 1+ ; \ default file extension (as zString) [endif] \ ------------------------------------------------------------------------ \ Some filename supporting words. \ ------------------------------------------------------------------------ [undefined] MAX-PATH [if] MAXBUFFER CONSTANT MAX-PATH \ maximum length of a filename buffer [endif] 1 PROC PathRemoveFileSpec as (call-prfs) 1 PROC PathRemoveExtension as (call-pre) \ Temp fix until AS work's within the STC-Kernel \ : ("path-func") ( a1 n1 xt -- a2 n2 ) \ execute path function \ -rot \ save the xt under the string \ over >r \ save original address \ MAX-PATH _localalloc \ allocate space on stack \ -z dup>r \ make a zstring \ swap execute drop \ call the function \ r> zcount \ count the chars \ _localfree \ nip r> swap \ use original address \ ; \ : "path-only" ( a1 n1 -- a2 n2 ) \ return path, minus final '\' \ ['] (call-prfs) ("path-func") \ ; \ \ : "minus-ext" ( a1 n1 -- a2 n2 ) \ remove the file extension \ ['] (call-pre) ("path-func") \ ; : "path-only" ( a1 n1 -- a2 n2 ) \ *G Return path, minus final '\' over >r \ save original address MAX_PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring call PathRemoveFileSpec drop \ call the function r> zcount \ count the chars _localfree nip r> swap \ use original address ; : "minus-ext" ( a1 n1 -- a2 n2 ) \ *G Remove the file extension over >r \ save original address MAX_PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring call PathRemoveExtension drop \ call the function r> zcount \ count the chars _localfree nip r> swap \ use original address ; : ".ext-only" ( a1 n1 -- a1 n1 ) \ *G returns dotted file extension 2dup "minus-ext" nip /string ; : "TO-PATHEND" ( a1 n1 --- a2 n2 ) \ *G return a2 and count=n1 of filename 2dup \ save originals MAX_PATH _LOCALALLOC ascii-z dup \ make zstring on the stack call PathFindFileName \ find the file part swap - /string \ remove the chars from caller _LOCALFREE ; : endchar? ( a1 char -- flag ) \ *G check the end character in a c-string swap dup c@ + c@ = ; : ?-\ ( a1 -- ) \ *G delete trailing '\' if present dup [char] \ endchar? \ end in '\'? if -1 swap c+! \ if so, delete it else drop \ else discard a1 then ; : ?+\ ( a1 -- ) \ *G append a '\' if not already present dup [char] \ endchar? \ end in '\'? if drop \ discard a1 else s" \" rot +place \ if not, append \ then ; : ?+; ( a1 -- ) \ *G append a ';' if not already present dup [char] ; endchar? \ end in ';'? if drop \ discard a1 else s" ;" rot +place \ if not, append ; then ; \ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------ : ?DEFEXT ( addr -- ) \ *G Conditionally add a default extension defext$ add.ext \ add extension if needed ; \ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------ create &forthdir \ *G A static forth installation directory. MAXCOUNTED 1+ allot &forthdir off : init-Win32fDirectory { \ kernel$ -- } \ *G Set &forthdir to the folder of the current forth application. \n &prognam count "path-only" &forthdir place &forthdir c@ 0= if \ if no dir specified make it the current dir current-dir$ count &forthdir place then &forthdir c@ if &forthdir ?+\ \ append '\' if needed &forthdir +null \ append 0 terminator then ; init-Win32fDirectory initialization-chain chain-add init-Win32fDirectory IN-SYSTEM : .program ( -- ) \ *G Type the program path. &prognam count type ; : .forthdir ( -- ) \ *G Type the forth directory. &forthdir count type ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ change directory \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : "chdir ( a1 n1 -- ) \ *G Set the current directory. IF $current-dir! THEN drop ; IN-SYSTEM : .dir ( -- ) \ *G Print the current directory. cr ." Current directory: " current-dir$ count type ; : chdir ( -<optional_new_directory>- ) \ *G Set the current directory. /parse-word count "chdir cr .dir ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Multiple directory path search capability for file open \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : path: ( - ) \ *G Defines a directory search path. \n \ ** The first 2 cells are used too handle a search path. \n \ ** The next 260 bytes are reserved for a counted string of a path. \n \ ** followed by 0. \n \ ** In runtime it returns adres of the counted string of a path create -1 , 0 , MAX-PATH 1+ allot does> \ run-time: ( - path ) [ 2 cells ] literal + ; INTERNAL create path-file$ MAX-PATH 1+ allot : path-source ( path - 2variable_path-source ) \ *G Path-source points to a substring in a path. \n \ ** Path-source returns this adress. 2 cells- ; EXTERNAL path: path-ptr deprecated \ *G The old functionality had the bad habbit to pass a pointer through a \ ** value instead of passing the parameter over the stack. \n \ ** Use win32forth\src\Compat\OldPaths.f for the old functionality. \n \ ** Words like first-path" and next-path" are now able to handle \ ** each path separate without saving and restoring a path-ptr. path: search-path \ *G search-path defines the path buffer for Forth.\n Applications that let Forth \ ** compile should not change it in a way that Forth is not able too compile. : next-path" ( path -- a1 n1 ) \ *G Get the next path from dir list. dup>r path-source 2@ 2dup ';' scan 2dup 1 /string r> path-source 2! nip - 2dup s" %FORTHDIR%" ISTR= if 2drop &forthdir dup ?+\ count "path-only" exit then 2dup s" %CURRENTDIR%" ISTR= if 2drop current-dir$ dup ?+\ count "path-only" exit then 2dup s" %APPDIR%" ISTR= if 2drop &prognam count "path-only" exit then ; : reset-path-source ( path -- ) \ *G Points the path-source to the whole path. dup>r count r> path-source 2! ; : first-path" ( path -- a1 n1 ) \ *G Get the first forth directory path. dup>r reset-path-source r> next-path" ; : "path+ ( a1 n1 path -- ) \ *G Append a directory to a path. >r 2dup upper 2dup + 1- c@ '\' = \ end in '\'? if 1- 0max \ if so, delete it then r@ first-path" \ get first path begin dup 0> >r 2over compare 0<> dup r> and \ check it while drop r@ next-path" \ and remaining paths repeat 0= \ -- f1=true if already in list if 2drop else dup r@ c@ if char+ then MAX-PATH >= abort" Path overflow" r@ c@ if r@ ?+; then r@ +place then r>drop ; : "fpath+ ( a1 n1 -- ) \ *G Append a directory to the Forth path. search-path "path+ ; : fpath+ ( -<directory>- ) \ *G Append a directory to the Forth path. /parse-s$ count "fpath+ ; : .path ( path -- ) \ *G Display a directory search path list. count begin ?dup while 2dup ';' scan 2dup 2>r nip - dup char+ ?cr type 2r> 1 /string dup if ." ;" then repeat drop ; : .fpath ( -- ) \ *G Display the Forth directory search path list. search-path .path ; INTERNAL : volume-indication? ( adr - flag ) \ *G True when the counted string at adr starts with x: or \\name dup 2 + c@ [char] : <> if count drop 2 s" \\" compare 0= else drop true then ; 6 PROC SearchPath : full-path { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 } \ *G Find file a1,n1 in a path and return the full path. \n \ ** a2,n2 and f1=false, succeeded. a1 n1 MAX-PATH 1+ localalloc ascii-z to filename$ MAX-PATH 1+ localalloc: searchpath$ MAX_PATH 1+ LocalAlloc: current$ current-dir$ count current$ place current$ +null \ save current dir search-path first-path" begin dup>r searchpath$ place searchpath$ +null searchpath$ volume-indication? \ Test for another volume if searchpath$ char+ $current-dir! \ 0 fails, then try next else true then if 0 \ file component path-file$ \ found file name buffer max-path \ size of buffer defextz$ \ file extension filename$ \ file name searchpath$ char+ \ search path call SearchPath 0<> if path-file$ zcount false \ path found current$ char+ $current-dir! not abort" $current-dir!" \ restore current dir r>drop exit \ clear the retun stack and exit then then r> while searchpath$ off search-path next-path" repeat a1 n1 path-file$ place path-file$ count true \ return input file and error flag current$ char+ $current-dir! not abort" $current-dir!" \ restore current dir ; EXTERNAL : program-path-init ( -- ) \ *G Initialize the Forth directory search path list. Automatically done at program \ ** initialization and when Paths.f is loaded. search-path off \ clear path list s" %CURRENTDIR%" "fpath+ s" %FORTHDIR%" "fpath+ s" %APPDIR%" "fpath+ s" src" "fpath+ s" src\lib" "fpath+ \ s" src\tools" "fpath+ \ this is causing problems when compiling the IDE... s" src\gdi" "fpath+ \ GDI class library s" src\res" "fpath+ s" src\console" "fpath+ \ s" demos" "fpath+ s" doc" "fpath+ \ last ; program-path-init INITIALIZATION-CHAIN CHAIN-ADD PROGRAM-PATH-INIT : "path-file { a1 n1 \ current$ -- a2 n2 f1 } \ *G Find file a1,n1 in the Forth path and return the full path. \n \ ** a2,n2 and f1=false, succeeded. \ first try it in the current directory a1 n1 search-path full-path -if 3drop \ then try it in the forth directory a1 n1 search-path full-path then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ "open with Multiple directory path search \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ create open-path$ MAXSTRING allot : n"open ( a1 n1 -- handle f1 ) \ *G Open file a1,n1 with a Forth path search. "path-file if 2drop 0 -1 else 2dup open-path$ place \ save full path _"open \ open file then ; ' n"open is "open \ link multi-path open word into system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ MakeAbsolutePath MakeRelativePath \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ INTERNAL create <AbsRelPath$> max-path 1+ allot EXTERNAL : IsAbsolutePath? ( a1 n1 -- f ) \ *G Returns true if path is absolute. MAXCOUNTED _LOCALALLOC \ allocate a string dup>r place r@ +null \ move the string r> 1+ \ for call call PathIsRelative 0= \ call function _LOCALFREE \ free buffer ; : MakeAbsolutePath ( a1 n1 a2 n2 -- a3 ) \ *G Make path a1 n1 absolute to path a2 n2. ?DUP \ only if a2 n2 point's to a path IF 2OVER IsAbsolutePath? IF 2DROP <AbsRelPath$> PLACE ELSE <AbsRelPath$> PLACE \ store path <AbsRelPath$> ?+\ \ append '\' if not already present <AbsRelPath$> +PLACE \ append file name THEN else DROP <AbsRelPath$> PLACE then <AbsRelPath$> dup +null ; : IsPathRelativeTo? { a1 n1 a2 n2 -- f } \ *G Return true if path a1 n1 is relative to path a2 n2 a1 n1 n2 MIN a2 OVER ISTR= ; : MakePathRelativeTo ( a1 n1 a2 n2 -- a3 ) \ *G Make path a1 n1 relative to path a2 n2. 4DUP IsPathRelativeTo? IF NIP DUP>R - SWAP R> + SWAP ( a2 n3 ) ELSE 2DROP ( a1 n1 ) THEN <AbsRelPath$> PLACE <AbsRelPath$> ; : FindRelativePath ( a1 n1 path - a2 n2 ) \ *G Returns a relative path for file a1 n1 in path ( first part ). \n \ ** n2=0 means not in search path. dup>r reset-path-source begin r@ path-source 2@ nip 0> if r@ next-path" 4dup IsPathRelativeTo? not else over 0 false then while 2drop repeat 2nip r>drop ; : FindRelativeName ( a1 n1 path - a2 n2 f ) \ *G Returns a relative name for file a1 n1 in path ( last-part ). \n \ ** n2=0 means not in search path. >r 2dup r> FindRelativePath dup 0> if nip dup 3 > if 1+ then /string true else 2drop false then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Prepend<home>\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : Prepend<home>\ ( a1 n1 -- a2 n2 ) &forthdir count MakeAbsolutePath count ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ "LOADED? \LOADED- \LOADED NEEDS \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ in-system : "LOADED? ( addr len -- flag ) \ *G True if a file addr len is loaded. The filename must contain a full path. CONTEXT @ >R \ save context files \ set context CONTEXT @ SEARCH-WORDLIST \ search for word IF DROP TRUE ELSE FALSE THEN \ correct the flag R> CONTEXT ! ; : LOADED? ( -<name>- -- flag ) { \ current$ } \ *G True if the following file is loaded. The filename may be relative. MAX_PATH 1+ LocalAlloc: current$ current-dir$ count current$ place \ get current dir current$ ?+\ \ append '\' new$ >r /parse-s$ count r@ place \ store file name r@ ?defext r> count \ add default ext if needed "path-file drop \ extend to full path "loaded? ; : \LOADED- ( -<name>- ) \ *G If the following file IS NOT LOADED interpret line. loaded? if postpone \ then ; : \LOADED ( -<name>- ) \ *G If the following file IS LOADED interpret line. loaded? 0= if postpone \ then ; : NEEDS ( -<name>- ) \ *G Conditionally load file "name" if not loaded. >in @ loaded? 0= if >in ! fload else drop then ; synonym Require needs \ *G Forth 200X name for needs. in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : "file-clip" { adr len limit \ temp$ pre -- 'adr 'len } \ *G Clip filename to limit. new$ to temp$ \ so string isn't de-allocated on exit limit 20 max to limit \ must be at east 16 limit 20 - 2 / 6 + to pre \ balance start and end len limit > if adr pre 3 - temp$ place \ lay in first 5 chars s" ..." temp$ +place \ append some dots adr len dup limit pre - - 0MAX /string \ clip to last part temp$ +place \ of name and lay in temp$ count else adr len \ no need to clip file then ; MODULE \ *Z |
|
From: Dirk B. <db...@us...> - 2006-09-23 06:00:25
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv17905/src/kernel Modified Files: gMeta.f Log Message: Changes path's from STC to SRC Index: gMeta.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gMeta.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gMeta.f 21 Sep 2006 16:26:33 -0000 1.1 --- gMeta.f 23 Sep 2006 06:00:17 -0000 1.2 *************** *** 41,48 **** create kern-name ," gkernel.exe" ! create kern-src ," stc\kernel\gkernel.f" ! create kern-next ," stc\kernel\gkernext.f" ! create kern-ver ," stc\kernel\gversion.f" ! create kern-cmp ," stc\kernel\gmeta-compiler.f" true value [debug] \ basic debug flag --- 41,48 ---- create kern-name ," gkernel.exe" ! create kern-src ," src\kernel\gkernel.f" ! create kern-next ," src\kernel\gkernext.f" ! create kern-ver ," src\kernel\gversion.f" ! create kern-cmp ," src\kernel\gmeta-compiler.f" true value [debug] \ basic debug flag *************** *** 54,59 **** true value image-save \ we want to save the image ! \ fpath+ stc\kernel ! fload stc\kernel\gmeta-fkernel \ compile the kernel --- 54,59 ---- true value image-save \ we want to save the image ! \ fpath+ src\kernel ! fload src\kernel\gmeta-fkernel \ compile the kernel |
|
From: Dirk B. <db...@us...> - 2006-09-23 06:00:25
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv17905/src Modified Files: asmwin32.f extend.f imageman.f Log Message: Changes path's from STC to SRC Index: asmwin32.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/asmwin32.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** asmwin32.f 21 Sep 2006 16:26:33 -0000 1.1 --- asmwin32.f 23 Sep 2006 06:00:17 -0000 1.2 *************** *** 33,37 **** : (_code) ( start a native code definition ) code-header hide ! !csp init-asm 0 to ofa ; --- 33,37 ---- : (_code) ( start a native code definition ) code-header hide ! !csp init-asm 0 to ofa ; *************** *** 59,63 **** ' end-code alias c; ! fload stc\kernel\gkernext.f \ load exec/next words ' next alias next, --- 59,63 ---- ' end-code alias c; ! fload src\kernel\gkernext.f \ load exec/next words ' next alias next, Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** extend.f 21 Sep 2006 16:26:33 -0000 1.1 --- extend.f 23 Sep 2006 06:00:17 -0000 1.2 *************** *** 4,85 **** cr .( -- META EXTEND.F ) cr ! sys-fload stc\primutil.f ! sys-fload stc\module.f \ scoping support for modules ! sys-fload stc\interpif.f \ interpretive conditionals ! fload stc\numconv.f \ general number conversions : nostack1 ; immediate ! sys-fload stc\486asm.f \ jim's 486 assembler ! sys-fload stc\asmmac.f \ jim's 486 macros ! sys-fload stc\asmwin32.f \ next for win32forth ! fload stc\console.f \ console i/o extracted from primutil.f ! sys-fload stc\dotwords.f \ dot support words ! sys-fload stc\imageman.f \ fsave, application & turnkey words ! sys-FLOAD stc\dis486.f \ load the disassembler ! fload stc\callback.f \ windows callback support ! fload stc\exception.f \ utility words to support windows exception handling 8 constant B/FLOAT \ default to 8 byte floating point numbers ! FLOAD stc\float.f \ floating point support .olly \s ! \ FLOAD stc\lineedit.f \ a line editor utility ! \ FLOAD stc\primhash.f \ primitive hash functions for OOP later *** to be done *** ! \ sys-FLOAD stc\winlib.f \ windows proc and memory words *** OBSOLETE *** ! \ FLOAD stc\paths.f \ multi path support words *** to be done *** ! \ sys-FLOAD stc\nforget.f \ forget words *** to be done *** \ FLOAD src\pointer.f \ pointer support *** depends on nforget ! \ sys-FLOAD stc\dbgsrc1.f \ source level debugging support part one *** to be done *** \s ! \ sys-FLOAD stc\dthread.f \ display threads ! \ sys-FLOAD stc\order.f \ vocabulary support ! sys-FLOAD stc\see.f ! \ sys-FLOAD stc\ctype.f \ 'c' style character typing ! sys-FLOAD stc\res\resforth.h \ load the headerfile with a few constants ! sys-FLOAD stc\debug.f ! sys-FLOAD stc\words.f ! FLOAD stc\class.f \ ***** Object Oriented Programming Support ***** ! \ FLOAD stc\scrnctrl.f \ screen control words ! FLOAD stc\registry.f \ Win32 Registry support ! FLOAD stc\ansfile.f \ ansi file words ! FLOAD stc\keyboard.f \ function and special key constants ! FLOAD stc\mapfile.f \ Windows32 file into memory mapping words ! sys-FLOAD stc\environ.f \ environment? support ! \ sys-FLOAD stc\transit.f \ minimal transient support now an extra file ! FLOAD stc\Shell.f \ load SHELL utility words ! FLOAD stc\utils.f \ load other misc utility words ! sys-FLOAD stc\dbgsrc2.f \ source level debugging support part two only forth also definitions \ ***** Object Oriented Support Continues ***** ! sys-FLOAD stc\classdbg.f ! FLOAD stc\colors.f ! FLOAD stc\fonts.f \ font class ! fload stc\xfiledlg.f \ xcall replacements for open dialogs ! FLOAD stc\PrintSupport.f \ replacement for the w32fPrint.dll ! FLOAD stc\dc.f \ device context class ! FLOAD stc\generic.f \ generic window class ! FLOAD stc\window.f ! FLOAD stc\childwnd.f \ child windows ! FLOAD stc\winmsg.f ! FLOAD stc\control.f ! FLOAD stc\controls.f ! FLOAD stc\button.f ! FLOAD stc\dialog.f ! FLOAD stc\console\forthdlg.f ! FLOAD stc\keysave.f ! FLOAD stc\lib\BROWSEFLD.F \ SHBrowseForFolder() support ! FLOAD stc\menu.f ! FLOAD stc\console\ConsoleMenu.f ! sys-FLOAD stc\console\ConsoleStatBar.f \ status bar for the console window ! \ sys-Fload stc\xref.f \ Cross reference all words used by the word in question create config$ ," WIN32FOR.CFG" --- 4,85 ---- cr .( -- META EXTEND.F ) cr ! sys-fload src\primutil.f ! sys-fload src\module.f \ scoping support for modules ! sys-fload src\interpif.f \ interpretive conditionals ! fload src\numconv.f \ general number conversions : nostack1 ; immediate ! sys-fload src\486asm.f \ jim's 486 assembler ! sys-fload src\asmmac.f \ jim's 486 macros ! sys-fload src\asmwin32.f \ next for win32forth ! fload src\console.f \ console i/o extracted from primutil.f ! sys-fload src\dotwords.f \ dot support words ! sys-fload src\imageman.f \ fsave, application & turnkey words ! sys-FLOAD src\dis486.f \ load the disassembler ! fload src\callback.f \ windows callback support ! fload src\exception.f \ utility words to support windows exception handling 8 constant B/FLOAT \ default to 8 byte floating point numbers ! FLOAD src\float.f \ floating point support .olly \s ! \ FLOAD src\lineedit.f \ a line editor utility ! \ FLOAD src\primhash.f \ primitive hash functions for OOP later *** to be done *** ! \ sys-FLOAD src\winlib.f \ windows proc and memory words *** OBSOLETE *** ! \ FLOAD src\paths.f \ multi path support words *** to be done *** ! \ sys-FLOAD src\nforget.f \ forget words *** to be done *** \ FLOAD src\pointer.f \ pointer support *** depends on nforget ! \ sys-FLOAD src\dbgsrc1.f \ source level debugging support part one *** to be done *** \s ! \ sys-FLOAD src\dthread.f \ display threads ! \ sys-FLOAD src\order.f \ vocabulary support ! sys-FLOAD src\see.f ! \ sys-FLOAD src\ctype.f \ 'c' style character typing ! sys-FLOAD src\res\resforth.h \ load the headerfile with a few constants ! sys-FLOAD src\debug.f ! sys-FLOAD src\words.f ! FLOAD src\class.f \ ***** Object Oriented Programming Support ***** ! \ FLOAD src\scrnctrl.f \ screen control words ! FLOAD src\registry.f \ Win32 Registry support ! FLOAD src\ansfile.f \ ansi file words ! FLOAD src\keyboard.f \ function and special key constants ! FLOAD src\mapfile.f \ Windows32 file into memory mapping words ! sys-FLOAD src\environ.f \ environment? support ! \ sys-FLOAD src\transit.f \ minimal transient support now an extra file ! FLOAD src\Shell.f \ load SHELL utility words ! FLOAD src\utils.f \ load other misc utility words ! sys-FLOAD src\dbgsrc2.f \ source level debugging support part two only forth also definitions \ ***** Object Oriented Support Continues ***** ! sys-FLOAD src\classdbg.f ! FLOAD src\colors.f ! FLOAD src\fonts.f \ font class ! fload src\xfiledlg.f \ xcall replacements for open dialogs ! FLOAD src\PrintSupport.f \ replacement for the w32fPrint.dll ! FLOAD src\dc.f \ device context class ! FLOAD src\generic.f \ generic window class ! FLOAD src\window.f ! FLOAD src\childwnd.f \ child windows ! FLOAD src\winmsg.f ! FLOAD src\control.f ! FLOAD src\controls.f ! FLOAD src\button.f ! FLOAD src\dialog.f ! FLOAD src\console\forthdlg.f ! FLOAD src\keysave.f ! FLOAD src\lib\BROWSEFLD.F \ SHBrowseForFolder() support ! FLOAD src\menu.f ! FLOAD src\console\ConsoleMenu.f ! sys-FLOAD src\console\ConsoleStatBar.f \ status bar for the console window ! \ sys-Fload src\xref.f \ Cross reference all words used by the word in question create config$ ," WIN32FOR.CFG" *************** *** 194,198 **** fsave Win32for \ save Win32For.EXE fload lib\Resources.f ! s" stc\res\Win32For.ico" s" Win32for.exe" AddAppIcon --- 194,198 ---- fsave Win32for \ save Win32For.EXE fload lib\Resources.f ! s" src\res\Win32For.ico" s" Win32for.exe" AddAppIcon Index: imageman.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/imageman.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** imageman.f 21 Sep 2006 16:26:33 -0000 1.1 --- imageman.f 23 Sep 2006 06:00:17 -0000 1.2 *************** *** 7,11 **** IMAGEMAN builds Windows EXE images. ! For documentation on the PECOFF format, see http://www.microsoft.com/hwdev/hardware/PECOFF.asp. Note: not included because of copyright restrictions, but freely downloadable. Also see "Peering Inside the PE: A Tour --- 7,11 ---- IMAGEMAN builds Windows EXE images. ! For documentation on the PECOFF format, see http://www.microsoft.com/hwdev/hardware/PECOFF.asp. Note: not included because of copyright restrictions, but freely downloadable. Also see "Peering Inside the PE: A Tour *************** *** 35,39 **** VIMAGE IMAGEMAN has its own dictionary (because of possible name collisions) ! so a separate dictionary is used. COMPACT Standard file is built with 4096 (4KBYTE) file sections. COMPACT specifies 512 (0x200) file sections, which builds a smaller EXE file --- 35,39 ---- VIMAGE IMAGEMAN has its own dictionary (because of possible name collisions) ! so a separate dictionary is used. COMPACT Standard file is built with 4096 (4KBYTE) file sections. COMPACT specifies 512 (0x200) file sections, which builds a smaller EXE file *************** *** 70,74 **** ENDBUILD Creates the image from the information given above. ! s" name" IMAGE-LOAD Loads a .IMG file for subsequent conversion. Sets the following words as a side effect; IMAGE-PTR pointer to the loaded image --- 70,74 ---- ENDBUILD Creates the image from the information given above. ! s" name" IMAGE-LOAD Loads a .IMG file for subsequent conversion. Sets the following words as a side effect; IMAGE-PTR pointer to the loaded image *************** *** 108,112 **** The first section always starts on 0x1000. Section #1 will start at 0x1000, and be 0x1234 bytes padded out to the next 4K boundary (out to 0x2FFF). Section #2 will start ! at 0x3000, be 0x1120 bytes padded out to 0x4FFF, etc. The .idata section should be written last. --- 108,112 ---- The first section always starts on 0x1000. Section #1 will start at 0x1000, and be 0x1234 bytes padded out to the next 4K boundary (out to 0x2FFF). Section #2 will start ! at 0x3000, be 0x1120 bytes padded out to 0x4FFF, etc. The .idata section should be written last. *************** *** 149,153 **** BASE @ DECIMAL NOSTACK1 ! SYS-FLOAD STC\IMAGEHDS.F \ image header file \ ---------------- File handling PE image -------------------------- --- 149,153 ---- BASE @ DECIMAL NOSTACK1 ! SYS-FLOAD SRC\IMAGEHDS.F \ image header file \ ---------------- File handling PE image -------------------------- *************** *** 160,164 **** cr ." File '" PEIMG-NAME count type ." ' : " ! WinErrMsg ON GetLastWinErr then ; --- 160,164 ---- cr ." File '" PEIMG-NAME count type ." ' : " ! WinErrMsg ON GetLastWinErr then ; *************** *** 184,188 **** PEIMG-HNDL FILE-POSITION ?PEIMG-FERROR d>s ; ! 0x1000 CONSTANT 4KBYTE 0x100000 CONSTANT 1MBYTE --- 184,188 ---- PEIMG-HNDL FILE-POSITION ?PEIMG-FERROR d>s ; ! 0x1000 CONSTANT 4KBYTE 0x100000 CONSTANT 1MBYTE *************** *** 255,259 **** RES-LOAD \ .res name before this RES-PTR RES-LEN ; ! )) --- 255,259 ---- RES-LOAD \ .res name before this RES-PTR RES-LEN ; ! )) *************** *** 356,360 **** "next" pointer points to a list of all functions (IMPORT) "func" pointer points to a list of functions in this library (IMPORTs in IMPLIB) ! Uses structure based on BASE-IMPSTR --- 356,360 ---- "next" pointer points to a list of all functions (IMPORT) "func" pointer points to a list of functions in this library (IMPORTs in IMPLIB) ! Uses structure based on BASE-IMPSTR *************** *** 407,411 **** Add imports a stand-alone section normally called .idata. Section must be declared. ! Steps: --- 407,411 ---- Add imports a stand-alone section normally called .idata. Section must be declared. ! Steps: *************** *** 415,419 **** Build the lib names, remember where we put them (write into the linked list at IMP-RVA) Build the hint/func names, remember where we put them ! If section isn't big enough, make it larger (we haven't written it yet) --- 415,419 ---- Build the lib names, remember where we put them (write into the linked list at IMP-RVA) Build the hint/func names, remember where we put them ! If section isn't big enough, make it larger (we haven't written it yet) *************** *** 433,440 **** IID-RVA-IAT ------------------------------------------------------+ ... ! # of IIDs = IMPLIB-COUNT + 1 # of ILT entries = IMPLIB-COUNT + IMPFUNC-COUNT (same for IAT) ! IAT is built first, and is the table modified by the loader to contain load addresses. Note that the entries are built back-to-front from the declaration order -- the last function --- 433,440 ---- IID-RVA-IAT ------------------------------------------------------+ ... ! # of IIDs = IMPLIB-COUNT + 1 # of ILT entries = IMPLIB-COUNT + IMPFUNC-COUNT (same for IAT) ! IAT is built first, and is the table modified by the loader to contain load addresses. Note that the entries are built back-to-front from the declaration order -- the last function *************** *** 473,477 **** CURR-IID ->RVA EXED-IMPORT ! \ point at imports LEN-ALLIIDS EXED-IMPORT CELL+ ! \ length of IIDs ! CURR-IAT ->RVA EXED-IAT ! \ point at IAT LEN-IAT EXED-IAT CELL+ ! \ length of IAT --- 473,477 ---- CURR-IID ->RVA EXED-IMPORT ! \ point at imports LEN-ALLIIDS EXED-IMPORT CELL+ ! \ length of IIDs ! CURR-IAT ->RVA EXED-IAT ! \ point at IAT LEN-IAT EXED-IAT CELL+ ! \ length of IAT *************** *** 494,498 **** CELL +TO CURR-ILT CELL +TO CURR-IAT \ update ILT/IAT pointers REPEAT ! CELL +TO CURR-ILT CELL +TO CURR-IAT \ update ILT/IAT pointers (zero entry) LEN-IID +TO CURR-IID \ next IID --- 494,498 ---- CELL +TO CURR-ILT CELL +TO CURR-IAT \ update ILT/IAT pointers REPEAT ! CELL +TO CURR-ILT CELL +TO CURR-IAT \ update ILT/IAT pointers (zero entry) LEN-IID +TO CURR-IID \ next IID *************** *** 629,637 **** SECTINIT ; ! : ENDBUILD ( -- ) \ fixup all the missing info cr ." Building image " PEIMG-NAME COUNT TYPE PEIMG-FCREATE \ create the file ! FILE-ALIGN EXEH-FILEALIGN ! \ n BYTE file align (mult of 512 bytes) LEN-HEAD EXEH-HEADSIZE ! \ n byte header size (mult of filealign) --- 629,637 ---- SECTINIT ; ! : ENDBUILD ( -- ) \ fixup all the missing info cr ." Building image " PEIMG-NAME COUNT TYPE PEIMG-FCREATE \ create the file ! FILE-ALIGN EXEH-FILEALIGN ! \ n BYTE file align (mult of 512 bytes) LEN-HEAD EXEH-HEADSIZE ! \ n byte header size (mult of filealign) *************** *** 656,660 **** R> cr ." Built length " dup . ." (" 1 H.R ." h) bytes" ! HEAD-BUFF release \ release storage --- 656,660 ---- R> cr ." Built length " dup . ." (" 1 H.R ." h) bytes" ! HEAD-BUFF release \ release storage *************** *** 702,706 **** s" .kode" SECTION ! STD-DATA S-EXECUTE or SECTIONTYPE IMAGE-KODEPTR IMAGE-KACTUAL SECTIONDATA IMAGE-KSIZE SECTIONSIZE --- 702,706 ---- s" .kode" SECTION ! STD-DATA S-EXECUTE or SECTIONTYPE IMAGE-KODEPTR IMAGE-KACTUAL SECTIONDATA IMAGE-KSIZE SECTIONSIZE |
|
From: Dirk B. <db...@us...> - 2006-09-23 06:00:25
|
Update of /cvsroot/win32forth/win32forth-stc/doc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv17905/doc Modified Files: readme.txt Log Message: Changes path's from STC to SRC Index: readme.txt =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** readme.txt 21 Sep 2006 16:26:32 -0000 1.1 --- readme.txt 23 Sep 2006 06:00:17 -0000 1.2 *************** *** 8,13 **** 2. Type ! fload stc\extend ! fsave w32f bye --- 8,13 ---- 2. Type ! fload src\extend ! fsave w32f.exe bye *************** *** 16,21 **** 4. Type ! fload stc\extend ! fload stc\kernel\gmeta --- 16,21 ---- 4. Type ! fload src\extend ! fload src\kernel\gmeta *************** *** 27,31 **** 2. Type ! fload bench To see generated code; after loading the benchmark try --- 27,31 ---- 2. Type ! fload demos\bench To see generated code; after loading the benchmark try |
|
From: George H. <geo...@us...> - 2006-09-22 10:50:25
|
Update of /cvsroot/win32forth/win32forth/doc In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15918/win32forth/doc Added Files: p-ansfile.htm Log Message: gah:Adde more documentaion for ansfile --- NEW FILE: p-ansfile.htm --- <?xml version="1.0"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> <meta name="GENERATOR" content="dexh v03"> <meta name="ProgId" content="FrontPage.Editor.Document"> <meta http-equiv="Content-Type" content="text/html; charset=windows-1252"> <title> W32F ansfile</title><style><!-- h1 { font-family: Tahoma; font-size: 24pt; font-weight: bold } h2 { font-family: Tahoma; font-size: 18pt; font-weight: bold } --> </style> </head> <body><h1 align="center"> <a href="mailto:win...@ya...?subject=DOC:Doc error in $Id: p-ansfile.htm,v 1.1 2006/09/22 10:50:22 georgeahubert Exp $"> <img border="0" src="TELLUS.gif" align="left" width="32" height="32"></a> <img border="0" src="FORTHPRO.gif" width="32" height="32"> Win32Forth</h1> <hr /><h1>File and directory searching words. </h1><hr /><p>These words are extensions to the ANSI file words for finding files. </p>If ior = 0, operation is O.K.; Otherwse, it is a failure. <h2>Glossary </h2><pre><b><a name="0">cell newuser _hdl-search ( -- addr ) </a></b></pre><p>Variable holding handle. </p><pre><b><a name="1">0 newuser _systemtime </a></b></pre><p>Structure FileTimeToSystemTime function; this struc is same as time-buf in kernel.tom </p><pre><b><a name="2">: get-fspace { zroot \ clus freclus b/sec s/clus -- as bs cs ds } </a></b></pre><p>Get a drive's free space, cluster and sector information "zroot" is the root directory spec zString for the desired drive in the format z" x:\", where x can be a, b, c, d or e etc... </p><pre><b><a name="3">: find-first-file ( addr1 len1 -- addr2 ior ) </a></b></pre><p>addr1 len1 is a string that specifies a valid directory or path and filename, which can contain wildcard characters (* and ?). This string must not exceed MAX_PATH characters. addr2 is the address of the _win32-find-data structure. ior is 0 for success in which case _hdl-search contains a valid handle. </p><p>Find-First-File searches a directory for a file whose name matches the specified filename. Find-First-File examines subdirectory names as well as filenames. </p><p>Find-First-File opens a search handle and returns information about the first file whose name matches the specified pattern. Once the search handle is established, you can use Find-Next-File to search for other files that match the same pattern. When the search handle is no longer needed, close it by using Find-Close. Find-First-File searches for files by name only; it cannot be used for attribute-based searches. </p><pre><b><a name="4">: find-next-file ( -- addr ior ) </a></b></pre><p>Find-first-file word must be called before this word can be called due to the fact that _hdl-search is needed </p><pre><b><a name="5">: find-close ( -- ior ) </a></b></pre><p>Close the _hdl-search handle. </p><pre><b><a name="6">: get-DOS-create-datetime ( -- ;convert 64 bit file time to MS_DOS ) </a></b></pre><p>Date and time values of creation. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. </p><pre><b><a name="7">: get-DOS-access-datetime ( -- ;convert 64 bit file time to MS_DOS ) </a></b></pre><p>date and time values of last access. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. </p><pre><b><a name="8">: get-DOS-write-datetime ( -- ;convert 64 bit file time to MS_DOS ) </a></b></pre><p>Date and time values of last write. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. </p><pre><b><a name="9">: get-file-size ( -- size ) \ W32F Files Extra </a></b></pre><p>Size of the last found file. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. </p><pre><b><a name="10">: get-file-name ( -- adr; address for file name ) </a></b></pre><p>get the name of the last found file. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. </p><pre><b><a name="11">: dir-attribute? ( - flag ) </a></b></pre><p>Returns true when a file is a directory. <br /> You need to call find-first-file or find-next-file word in the current task before using this word. <br /> Can be used in combination with ForAllFileNames </p><pre><b><a name="12">2 cells newuser file-time-buf </a></b></pre><p>2Variable to hold the FILETIME structure, which is a little endian (i.e. reversed order) 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601. </p><pre><b><a name="13">: dir->file-name ( -- adr count ) </a></b></pre><p>Returns the address and count of a file in a directory. <br /> Need to call find-first-file or find-next-file word before using this word. <br /> Can be used in combination with ForAllFileNames </p><pre><b><a name="14">: ForAllFileNames { cfa } ( adr slen cfa -- ) </a></b></pre><p>Executes the CFA for each found file in a directory. <br /> A file specification adr slen may contain wildcards <br /> NOTE: Directory names are also considered to be a file-name. <br /> Directory names can be detected by dir-attribute? </p><pre><b><a name="15">: ForAllFiles ( cfa -- ) </a></b></pre><p>Executes the CFA on ALL found files in a directory. <br /> NOTE: Directory names are also considered to be a file-name. <br /> Directory names can be detected by dir-attribute? <br /> </p><pre><b><a name="16">: .dir->file-size ( -- ) </a></b></pre><p>Print the size or directory indication of a file <br /> Need to call find-first-file or find-next-file word before using this word. <br /> Can be used in combination with ForAllFileNames </p><pre><b><a name="17">: .file-size-name ( adr len - ) </a></b></pre><p>Print the size or directory indication and the name of file. It also formats the line. <br /> Need to call find-first-file or find-next-file word before using this word. <br /> Can be used in combination with ForAllFileNames </p><pre><b><a name="18">: print-dir-files ( adr slen -- ) \ W32F Files Extra </a></b></pre><p>Print all the files and sub-directories in a directory that match a specific pattern. </p><pre><b><a name="19">: dir ( "name" -- ) \ W32F Files Extra </a></b></pre><p>Print all the files and sub-directories in a directory that match a specific pattern. <br /> If "name" is missing or ends in \ or / search for all files that match *.* <br /> If "name" contains a relative path then it's relative to the current directory. <br /> If "name" ends in : assume a drive use "name"\*.* for the search pattern. <br /> </p><p>The pattern can contain the standard Windows wildcards. </p><hr><p>Document $Id: p-ansfile.htm,v 1.1 2006/09/22 10:50:22 georgeahubert Exp $</p> </body></html> |
|
From: George H. <geo...@us...> - 2006-09-22 10:50:25
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15918/win32forth/src Modified Files: ANSFILE.F Log Message: gah:Adde more documentaion for ansfile Index: ANSFILE.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/ANSFILE.F,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** ANSFILE.F 21 Sep 2006 12:50:17 -0000 1.7 --- ANSFILE.F 22 Sep 2006 10:50:20 -0000 1.8 *************** *** 1,4 **** --- 1,8 ---- \ $Id$ + \ *D doc + \ *! p-ansfile W32F ansfile + \ *T File and directory searching words. + \ *P These words are extensions to the ANSI file words for finding files. \ The ANSI words are defined in the kernel. *************** *** 28,31 **** --- 32,37 ---- 2 PROC FileTimeToSystemTime + \ *S Glossary + cell newuser _hdl-search ( -- addr ) \ *G Variable holding handle. *************** *** 108,112 **** r> release ; \ free buff - : find-next-file ( -- addr ior ) \ *G Find-first-file word must be called --- 114,117 ---- *************** *** 118,122 **** swap 0= ; \ adrd ior - 0 = success - : find-close ( -- ior ) \ *G Close the _hdl-search handle. --- 123,126 ---- *************** *** 135,168 **** : get-DOS-create-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ date and time values ! \ need to call find-first-file or find-next-file word ! \ before using this word 1 (DOSTime) ; : get-DOS-access-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ date and time values ! \ need to call find-first-file or find-next-file word ! \ before using this word 3 (DOSTime) ; : get-DOS-write-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ date and time values ! \ need to call find-first-file or find-next-file word ! \ before using this word 5 (DOSTime) ; ! : get-file-size ( -- size ) ! \ need to call find-first-file or find-next-file word ! \ before using this word _win32-find-data 8 cells+ @ ; : get-file-name ( -- adr; address for file name ) ! \ need to call find-first-file or find-next-file word ! \ before using this word _win32-find-data 11 cells+ ; : dir-attribute? ( - flag ) \ *G Returns true when a file is a directory. \n ! \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames _win32-find-data @ FILE_ATTRIBUTE_DIRECTORY and ; --- 139,175 ---- : get-DOS-create-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ *G Date and time values of creation. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. 1 (DOSTime) ; : get-DOS-access-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ *G date and time values of last access. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. 3 (DOSTime) ; : get-DOS-write-datetime ( -- ;convert 64 bit file time to MS_DOS ) ! \ *G Date and time values of last write. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. 5 (DOSTime) ; ! : get-file-size ( -- size ) \ W32F Files Extra ! \ *G Size of the last found file. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. _win32-find-data 8 cells+ @ ; : get-file-name ( -- adr; address for file name ) ! \ *G get the name of the last found file. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. _win32-find-data 11 cells+ ; : dir-attribute? ( - flag ) \ *G Returns true when a file is a directory. \n ! \ ** You need to call find-first-file or find-next-file word in the current task ! \ ** before using this word. \n \ ** Can be used in combination with ForAllFileNames _win32-find-data @ FILE_ATTRIBUTE_DIRECTORY and ; *************** *** 202,206 **** : dir->file-name ( -- adr count ) ! \ *G Returns the adres and count of a file in a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames --- 209,213 ---- : dir->file-name ( -- adr count ) ! \ *G Returns the address and count of a file in a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames *************** *** 254,257 **** --- 261,266 ---- then ; + dpr-warning? dpr-warning-off checkstack + : _print-dir-files ( adr slen -- ) 0 total-file-bytes ! *************** *** 270,273 **** --- 279,284 ---- REPEAT ; deprecated + to dpr-warning? + : .file-size-name ( adr len - ) \ *G Print the size or directory indication and the name of file. *************** *** 295,299 **** \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. \n ! \ ** If "name" is missing or ends in \ search for all files that match *.* \n \ ** If "name" contains a relative path then it's relative to the current directory. \n \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n --- 306,310 ---- \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. \n ! \ ** If "name" is missing or ends in \ or / search for all files that match *.* \n \ ** If "name" contains a relative path then it's relative to the current directory. \n \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n *************** *** 301,307 **** /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place ! THEN dup count + 1- c@ ':' = \ if just a drive, add \ IF s" \" pocket +place ! THEN dup count + 1- c@ '\' = \ if it ends in a \, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; --- 312,319 ---- /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place ! THEN dup count + 1- c@ [char] : = \ if just a drive, add \ IF s" \" pocket +place ! THEN dup count + 1- c@ dup [char] \ \ if it ends in a \, ! swap [char] / = or \ or a /, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; *************** *** 309,314 **** : do-rename-afile { RenamePart1$ RenamePart2$ \ RenameTemp$ -- } \ rename one file MAXSTRING LocalAlloc: RenameTemp$ ! _win32-find-data 11 CELLS+ \ adrz ! zcount \ adrz -- adr len 2dup 2dup RenamePart1$ count caps-search IF 2dup 2>r nip - RenameTemp$ place \ leading part --- 321,325 ---- : do-rename-afile { RenamePart1$ RenamePart2$ \ RenameTemp$ -- } \ rename one file MAXSTRING LocalAlloc: RenameTemp$ ! dir->file-name 2dup 2dup RenamePart1$ count caps-search IF 2dup 2>r nip - RenameTemp$ place \ leading part |
1040 messages has been excluded from this view by a project administrator.
