win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth-stc gkernel.exe,1.4,1.5

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3406

Modified Files:
	gkernel.exe 
Log Message:
arm: rename xt>name, xt>ct... and name>xt to omit xt part; in line with other Forths
 that use >name

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
Binary files /tmp/cvs8FC6pB and /tmp/cvs2ryL34 differ

[Win32forth-cvs] win32forth-stc/src dis486.f, 1.2, 1.3 dotwords.f, 1.1, 1.2

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32694

Modified Files:
	dis486.f dotwords.f 
Log Message:
arm: rename xt>name, xt>ct... and name>xt to omit xt part; in line with other Forths
 that use >name

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** dis486.f	27 Sep 2006 21:01:56 -0000	1.2
--- dis486.f	30 Sep 2006 23:22:26 -0000	1.3
***************
*** 1078,1082 ****
  : see           ( -- )
                  defined ?missing
!                 dup xt>name n>ofa w@ over +    \ length to disassemble
                  swap
                  begin
--- 1078,1082 ----
  : see           ( -- )
                  defined ?missing
!                 dup >name n>ofa w@ over +      \ length to disassemble
                  swap
                  begin

Index: dotwords.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dotwords.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** dotwords.f	21 Sep 2006 16:26:33 -0000	1.1
--- dotwords.f	30 Sep 2006 23:22:26 -0000	1.2
***************
*** 116,120 ****
                    begin @ ?dup
                    while   dup cell+ @
!                     xt>name
                      dup count nip 3 + ?cr
                      getxy drop 24 <
--- 116,120 ----
                    begin @ ?dup
                    while   dup cell+ @
!                     >name
                      dup count nip 3 + ?cr
                      getxy drop 24 <

[Win32forth-cvs] win32forth-stc/src paths.f, 1.3, 1.4 primutil.f, 1.6, 1.7

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4224/src

Modified Files:
	paths.f primutil.f 
Log Message:
- Made fload, needs, loaded? and friends work correctly with the path search.
- The path search stuff is mostly rewritten. Know there are two list's. One for the base-folders and one for the sub-folders to search in.

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** primutil.f	27 Sep 2006 21:38:36 -0000	1.6
--- primutil.f	30 Sep 2006 15:17:33 -0000	1.7
***************
*** 99,109 ****
  \ ------------------------------------------------------------------------
  
- ' included  alias "fload
- ' fload     alias include
- ' requires  alias needs
  ' dpl       alias dp-location
- 
  ' postpone  alias compile
- 
  ' maxbuffer alias max-path
  
--- 99,104 ----

Index: paths.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/paths.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** paths.f	24 Sep 2006 08:32:38 -0000	1.3
--- paths.f	30 Sep 2006 15:17:33 -0000	1.4
***************
*** 174,179 ****
  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
--- 174,177 ----
***************
*** 183,198 ****
  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!
--- 181,185 ----
  EXTERNAL
  
! : next-path"    ( path -- a1 n1  )      \ w32f path
  \ *G Get the next path from dir list.
                  dup>r path-source 2@ 2dup ';' scan  2dup 1 /string r> path-source 2!
***************
*** 204,216 ****
                  ;
  
! : 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
--- 191,203 ----
                  ;
  
! : reset-path-source     ( path --  )    \ w32f path
  \ *G Points the path-source to the whole path.
                  dup>r count r> path-source 2! ;
  
! : first-path"   ( path -- a1 n1  )      \ w32f path
  \ *G Get the first forth directory path.
                  dup>r reset-path-source  r> next-path" ;
  
! : "path+        ( a1 n1 path -- )       \ w32f path
  \ *G Append a directory to a path.
                  >r 2dup upper
***************
*** 227,347 ****
                  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
  
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 214,338 ----
                  then    r>drop ;
  
! in-system
  
+ : .path         ( path -- )             \ w32f path system
+ \ *G Display a directory search path list.
+ \ ** Note: The path source will be resetted for this path.
+                 dup >r first-path"
+                 begin  dup
+                        if   2dup cr type
+                        then nip
+                 while  r@ next-path"
+                 repeat r> reset-path-source ;
  
  
+ in-application
  
! INTERNAL
  
! : volume-indication? ( addr - flag )
! \ 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 ;
  
+ : save-current  ( current$ -- )
+ \ save current dir
+                 dup current-dir$ count rot place +null ;
  
! : restore-current  ( current$ -- )
! \ Restore current dir
!                 char+ $current-dir! not abort" $current-dir!" ;
  
! create path-file$ MAX-PATH 1+ allot
! 
! : search-error  ( addr -- )
! \ return input file and error flag
!                 count path-file$ place path-file$ count
!                 true ;
  
  6 PROC SearchPath
  
  EXTERNAL
  
! : full-path     { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 }
! \ *G Find the file \i a1,n1 \d in the path \i path \d and return the full path.
! \ ** \i a2,n2 \d . \i f1 \d = false if succeeded.
!                 a1 n1 MAX-PATH 1+ LocalAlloc ascii-z to filename$ \ save file name
  
!                 MAX_PATH 1+ LocalAlloc: current$
!                 current$ save-current \ save current dir
  
!                 MAX-PATH 1+ LocalAlloc: searchpath$
  
!                 path first-path"
!                 begin dup
!                       if    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   path-file$ off
!                                  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$ restore-current  \ restore current dir
!                                       exit                      \ and exit
!                                  else true \ try next path...
!                                  then
!                             then
!                        else nip
!                        then
!                 while  path next-path"
!                 repeat
  
!                 current$ restore-current \ restore current dir
!                 filename$ search-error ; \ return input file and error flag
  
! : find-path     { a1 n1 basepath path \ filename$ current$ search-current$ -- a2 n2 f1 }
! \ *G Find the file \i a1,n1 \d in the path \i basepath \d by scanning the sub folders
! \ ** defined in \i path \d. Returns the full path of the file if possible.
! \ ** \i a2,n2 \d . \i f1 \d = false if succeeded.
  
!                 \ Note: We have to save the file name in a temporay buffer,
!                 \ because a1 n2 can point to the internal buffer new$ and
!                 \ this buffer can be changed during the search (by current-dir$
!                 \ for example).
!                 MAX-PATH 1+ LocalAlloc: filename$
!                 a1 n1 filename$ place \ save file name
! 
!                 MAX_PATH 1+ LocalAlloc: current$
!                 current$ save-current \ save current dir
! 
!                 MAX_PATH 1+ LocalAlloc: search-current$
  
+                 basepath first-path"
+                 begin  dup
+                        if   \ set the next base folder we shall look in
+                             search-current$ place search-current$ +null
+                             search-current$ char+ $current-dir!
+ 
+                             \ and try to find the file in this folder
+                             if   filename$ count path full-path 0=
+                                  if   current$ restore-current
+                                       0 exit \ we found the file !!!
+                                  else 2drop true \ try the next folder...
+                                  then
+                             then
+                        else nip
+                        then
+                 while  basepath next-path"
+                 repeat
+ 
+                 current$ restore-current \ restore current dir
+                 filename$ search-error ; \ return input file and error flag
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 392,403 ****
  \ ** 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 )
--- 383,392 ----
  \ ** 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 )
***************
*** 405,415 ****
  \ ** 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
!    ;
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 394,473 ----
  \ ** 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 ;
! 
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \  FILE-REL>ABS with Multiple directory path search
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! 
! path: search-base-path                  \ w32f path
! \ *G The path buffer for the base search folders for Forth.\n
! \ ** Applications that let Forth compile should not change it.
! 
! path: search-path                       \ w32f path
! \ *G The path buffer for the sub folders to search in.
! \ ** Applications that let Forth compile should not change it.
! 
! in-system
! 
! : "fbase-path+  ( a1 n1 -- )            \ w32f path
! \ *G Append a directory to the Forth search base path.
!                 search-base-path "path+ ;
! 
! : fbase-path+   ( -<directory>- -- )    \ w32f path system
! \ *G Append a directory to the Forth search base path.
!                 /parse-s$ count "fbase-path+ ;
! 
! : "fpath+       ( a1 n1 -- )            \ w32f path
! \ *G Append a directory to the Forth search path.
!                 search-path "path+ ;
! 
! : fpath+        ( -<directory>- -- )    \ w32f path system
! \ *G Append a directory to the Forth search path.
!                 /parse-s$ count "fpath+ ;
! 
! : .fpath        ( -- )                  \ w32f path system
! \ *G Display the Forth directory search path list.
!                 cr ." Base path: "   search-base-path .path
!                 cr ." Search path: " search-path      .path ;
! 
! in-application
! 
! : program-path-init ( -- )
! \ *G Initialize the Forth directory search path list. Automatically done at program
! \ ** initialization and when Paths.f is loaded.
!                 search-base-path off    \ clear path list
!                 s" %CURRENTDIR%" "fbase-path+
!                 s" %FORTHDIR%"   "fbase-path+
!                 s" %APPDIR%"     "fbase-path+
! 
!                 search-path off          \ clear path list
!                 s" ."            "fpath+ \ current dir is first
!                 s" src"          "fpath+
!                 s" src\lib"      "fpath+
!                 s" src\gdi"      "fpath+ \ GDI class library
!                 s" src\tools"    "fpath+
!                 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 -- a2 n2 f1 )
! \ *G Find file a1,n1 in the Forth search path and return the full path. \n
! \ ** a2,n2 and f1=false, succeeded.
!                 search-base-path  search-path  find-path ;
! 
! :noname         ( addr len -- addr1 len1 )
! \ *G Turn rel file name into abs file name with Forth path search.
!                 "path-file drop
!                 2dup tempfile place \ save full path (for LINKFILE)
!                 ; is file-rel>abs
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 418,424 ****
  
  : Prepend<home>\        ( a1 n1 -- a2 n2 )
          &forthdir count MakeAbsolutePath count ;
  
- 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ "LOADED?  \LOADED-  \LOADED  NEEDS
--- 476,482 ----
  
  : Prepend<home>\        ( a1 n1 -- a2 n2 )
+ \ *G Make the rel file absoulute to the forth directory.
          &forthdir count MakeAbsolutePath count ;
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ "LOADED?  \LOADED-  \LOADED  NEEDS
***************
*** 427,463 ****
  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
--- 485,531 ----
  in-system
  
! : ("LOADED?)    ( addr len -- flag )            \ w32f path system
! \ *G Returns true if the file addr len is loaded.
! \ ** The filename must contain a full path.
!                 ['] files >body search-wordlist \ search for file name
!                 if drop true else false then ;
! 
! : "LOADED?      ( addr len -- flag )            \ w32f path system
! \ *G Returns true if the file addr len is loaded.
!                 { \ current$ }
  
                  MAX_PATH 1+ LocalAlloc: current$
!                 current$ place                  \ store file name
!                 current$ ?defext                \ add default ext if needed
!                 current$ count "path-file drop  \ extend to full path
  
!                 ("LOADED?) ; \ search for file name
! 
! : LOADED?       ( -<name>- -- flag )            \ w32f path system
! \ *G Returns true if the file addr len is loaded.
!                 /parse-s$ count "loaded? ;
! 
! : \LOADED-      ( -<name>- )                    \ w32f path system
  \ *G If the following file IS NOT LOADED interpret line.
                  loaded? if postpone \ then ;
  
! : \LOADED       ( -<name>- )                    \ w32f path system
  \ *G  If the following file IS LOADED interpret line.
                  loaded? 0= if postpone \ then ;
  
! : REQUIRED      ( addr len -- )
! \ *G Load the file \i addr len \d only if it's not loaded.
!                 2dup "LOADED?                   \ search for file name
!                 if   2drop                      \ no, don't load
!                 else included                   \ load the file
!                 then ;
  
! : REQUIRES      ( -<filename>- )
! \ *G Load the file \i filename \d only if it's not loaded.
!                 /parse-s$ count required ;
! 
! ' requires  alias NEEDS
! ' included  alias "FLOAD
! ' fload     alias INCLUDE
  
  in-application

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.4,1.5

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4224/src/kernel

Modified Files:
	gkernel.f 
Log Message:
- Made fload, needs, loaded? and friends work correctly with the path search.
- The path search stuff is mostly rewritten. Know there are two list's. One for the base-folders and one for the sub-folders to search in.

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** gkernel.f	27 Sep 2006 21:38:59 -0000	1.4
--- gkernel.f	30 Sep 2006 15:17:32 -0000	1.5
***************
*** 2478,2484 ****
                  lea     ebp, -4 [ebp]
                  ;g
!                 
  : (litval)  ( n -- )
!             >body 
              code-here _litval move-code
              5 + !                             \ update the literal in the code
--- 2478,2484 ----
                  lea     ebp, -4 [ebp]
                  ;g
! 
  : (litval)  ( n -- )
!             >body
              code-here _litval move-code
              5 + !                             \ update the literal in the code
***************
*** 3581,3585 ****
  : header    ( -<name>- )                      \ build a header
              code-align                        \ align code section, temporary
!             bl word count "header 
              latestxt @ to ofa                 \ for length calculations of the code generated
              ;
--- 3581,3585 ----
  : header    ( -<name>- )                      \ build a header
              code-align                        \ align code section, temporary
!             bl word count "header
              latestxt @ to ofa                 \ for length calculations of the code generated
              ;
***************
*** 4874,4889 ****
                  ;
  
- : _"open        ( a1 n1 -- fileid f1 )             \ open filename a1,n1
-                 _mlocalbuff dup>r
-                 place                              \ drop name to openbuf
-                 r@ defext$ add.ext               \ add extension if needed
-                 r@ count 2dup pocket place         \ and set pocket
-                 r/o open-file                      \ try to open it
-                 _mlocalfree
-                 ;
- 
- defer "open     ( a1 n1 -- fileid f1 )  \ open filename a1,n1  ( but not in editor )
-    ' _"open is "open                    \ return fileid and f1=false=ok
- 
  \ -------------------- Get/Set current directory ----------------------------
  
--- 4874,4877 ----
***************
*** 5078,5084 ****
  
  1 PROC PathIsRelative                    \ in SHLWAPI.DLL
! | 0 value tempfile                             \ ptr to tempfile
  
! : file-rel>abs  ( addr len -- )                    \ turn rel file name into abs file name
                  2dup tempfile place                \ copy to local buffer (must be 260 bytes)
                  tempfile +null tempfile 1+
--- 5066,5072 ----
  
  1 PROC PathIsRelative                    \ in SHLWAPI.DLL
! | 0 value tempfile                       \ ptr to tempfile
  
! |: (file-rel>abs) ( addr len -- addr1 len1 )       \ turn rel file name into abs file name
                  2dup tempfile place                \ copy to local buffer (must be 260 bytes)
                  tempfile +null tempfile 1+
***************
*** 5089,5113 ****
                  else 2drop
                  then
!                 tempfile lowercase defext$ add.ext ; \ lower the string
  
! : linkfile      ( addr len -- nfa )                \
!                 file-rel>abs                       \ make absolute
!                 tempfile count
                  [ ' files >body ] literal _header-build \ create header for this file
                  ['] isfile xtptr!                  \ point xt at this function (null)
                  last @ to include-filename ;       \ last file loaded ptr
  
! : included      ( addr len -- )   \ load file addr,len into current dictionary
!                 2dup "open throw_filenotfound ?throw
!                 -rot linkfile
!                 include-file ;
! 
! : required      ( addr len -- )
                  file-rel>abs                       \ make absolute
!                 tempfile count
!                 2dup ['] files >body search-wordlist \ search for file name
!                 if 3drop                           \ no, don't load
!                 else included                      \ load the file
!                 then ;                             \ free local path buffer
  
  : $fload        ( a1 -- )         \ a1 = counted file string
--- 5077,5104 ----
                  else 2drop
                  then
!                 tempfile defext$ add.ext           \ add extension if needed
!                 tempfile count ;                   \ return the abs file name
  
! defer file-rel>abs ' (file-rel>abs) is file-rel>abs
! 
! |: linkfile     ( -- nfa )        \ create header for the current file
!                 tempfile lowercase count           \ lower the file name
                  [ ' files >body ] literal _header-build \ create header for this file
                  ['] isfile xtptr!                  \ point xt at this function (null)
                  last @ to include-filename ;       \ last file loaded ptr
  
! : "open         ( a1 n1 -- fileid f1 )             \ open filename a1,n1
                  file-rel>abs                       \ make absolute
!                 _mlocalbuff dup>r
!                 place                              \ drop name to openbuf
!                 r@ defext$ add.ext                 \ add extension if needed
!                 r@ count 2dup pocket place         \ and set pocket
!                 r/o open-file                      \ try to open it
!                 _mlocalfree ;
! 
! : included      ( addr len -- )   \ load file addr,len into current dictionary
!                 "open throw_filenotfound ?throw    \ try to open the file
!                 linkfile                           \ create a header for the file
!                 include-file ;                     \ and load it
  
  : $fload        ( a1 -- )         \ a1 = counted file string
***************
*** 5117,5124 ****
                  /parse-s$ $fload ;
  
! : requires      ( -<filename>- )            \ load if not already loaded
!                 /parse-s$ count required ;
! 
! : sys-fload     ( -<filename>- )  \ load "filename" into system dictionary
                  >system fload system> ;
  
--- 5108,5112 ----
                  /parse-s$ $fload ;
  
! : sys-fload     ( -<filename>- )  \ load "filename" into system space
                  >system fload system> ;
  

[Win32forth-cvs] win32forth-stc gkernel.exe,1.3,1.4

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4224

Modified Files:
	gkernel.exe 
Log Message:
- Made fload, needs, loaded? and friends work correctly with the path search.
- The path search stuff is mostly rewritten. Know there are two list's. One for the base-folders and one for the sub-folders to search in.

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
Binary files /tmp/cvsCVNWBa and /tmp/cvs2oTim5 differ

[Win32forth-cvs] win32forth/src/console Console2.f, 1.5, 1.6 LINEEDIT.F, 1.7, 1.8

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

Update of /cvsroot/win32forth/win32forth/src/console
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8301/win32forth/src/console

Modified Files:
	Console2.f LINEEDIT.F 
Log Message:
gah:Added ACTION-OF (per F200X) and made DEFER@ a (temporary) deprecated synonym. Replaced defer@ by action-of (accept in 486asm). Added DEFER!. Support for extension queries (partial) added to environment.f

Index: Console2.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/Console2.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Console2.f	13 May 2006 20:32:07 -0000	1.5
--- Console2.f	28 Sep 2006 10:16:48 -0000	1.6
***************
*** 197,201 ****
  \ ------------------------------------------------------------------------------
  
! defer@ accept value defaultAccept
  
  : _basic-forth-io  ( -- )               \ reset to Forth IO words
--- 197,201 ----
  \ ------------------------------------------------------------------------------
  
! action-of accept value defaultAccept
  
  : _basic-forth-io  ( -- )               \ reset to Forth IO words

Index: LINEEDIT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/LINEEDIT.F,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** LINEEDIT.F	24 Sep 2006 08:18:24 -0000	1.7
--- LINEEDIT.F	28 Sep 2006 10:16:48 -0000	1.8
***************
*** 372,377 ****
                                          \ 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
                  0 to editpos
                  <ledit>
--- 372,377 ----
                                          \ f1 = false for canceled with ESC
  : lineeditor    ( x y a1 n1 --- f1 )    \ Edit line in a1
!                 action-of _le-quit >r ['] _lequit is _le-quit
!                 action-of _le-LF   >r ['] noop    is _le-LF
                  0 to editpos
                  <ledit>
***************
*** 461,466 ****
  
  : _laccept      ( a1 n1 -- n2 ) \ line editor version of ACCEPT
!                 defer@ _le-up   >r
!                 defer@ _le-down >r
                  ['] __laccept catch             \ -- f1
                  r> is _le-down                  \ restore these functions
--- 461,466 ----
  
  : _laccept      ( a1 n1 -- n2 ) \ line editor version of ACCEPT
!                 action-of _le-up   >r
!                 action-of _le-down >r
                  ['] __laccept catch             \ -- f1
                  r> is _le-down                  \ restore these functions

[Win32forth-cvs] win32forth/src/old OPTIMIZE.F,1.1,1.2

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

Update of /cvsroot/win32forth/win32forth/src/old
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8301/win32forth/src/old

Modified Files:
	OPTIMIZE.F 
Log Message:
gah:Added ACTION-OF (per F200X) and made DEFER@ a (temporary) deprecated synonym. Replaced defer@ by action-of (accept in 486asm). Added DEFER!. Support for extension queries (partial) added to environment.f

Index: OPTIMIZE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/old/OPTIMIZE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** OPTIMIZE.F	21 Dec 2004 00:19:11 -0000	1.1
--- OPTIMIZE.F	28 Sep 2006 10:16:48 -0000	1.2
***************
*** 7,22 ****
        BUG: OPT-LAST
        opt-last is a value with initial 0. Used as a pointer to the last
!       word optimised, it was used as 
             opt-last @ optimizable?
        which only worked with origin=0 code (i.e., relocatable) as 0
        pointed at the MAGIC word, which (fortunately) wasn't optimisable ;-).
!       
        For origin<>0, this causes a fetch from ABSOLUTE 0, gives exception C0000005h.
!       
        Fixed arm 4/10/2002 by pointing at _BEGIN in kernel (non-opt NCODE word)
!       
!       Temp fix: Won't generate in anything other than the DATA section, so the 
        assembler is temporarily overridden to produce code there
!       
  ))
  
--- 7,22 ----
        BUG: OPT-LAST
        opt-last is a value with initial 0. Used as a pointer to the last
!       word optimised, it was used as
             opt-last @ optimizable?
        which only worked with origin=0 code (i.e., relocatable) as 0
        pointed at the MAGIC word, which (fortunately) wasn't optimisable ;-).
! 
        For origin<>0, this causes a fetch from ABSOLUTE 0, gives exception C0000005h.
! 
        Fixed arm 4/10/2002 by pointing at _BEGIN in kernel (non-opt NCODE word)
! 
!       Temp fix: Won't generate in anything other than the DATA section, so the
        assembler is temporarily overridden to produce code there
! 
  ))
  
***************
*** 559,563 ****
                                  set-opt-last
                                  compile,                \ compile a cfa address
!                         then    
                  then    ;
  
--- 559,563 ----
                                  set-opt-last
                                  compile,                \ compile a cfa address
!                         then
                  then    ;
  
***************
*** 579,583 ****
                                          set-opt-last
                                          execute         \ compile a cfa address
!                                 then        
                          else    2drop                   \ discard flags
                                  set-opt-last
--- 579,583 ----
                                          set-opt-last
                                          execute         \ compile a cfa address
!                                 then
                          else    2drop                   \ discard flags
                                  set-opt-last
***************
*** 609,613 ****
                                                  number,
                                          then
!                                 else    drop                    \ discard flag        
                                          set-opt-last
                                          number,
--- 609,613 ----
                                                  number,
                                          then
!                                 else    drop                    \ discard flag
                                          set-opt-last
                                          number,
***************
*** 617,625 ****
  
  0 value interpret-cnt   \ compiles slowly, so give user something to look at
! 0 value opt-started? 
  
  : OPT-INTERPRET ( -- )
          begin   bl word dup c@
!         while   save-src 
  \ cr pocket count type
                  find ?dup
--- 617,625 ----
  
  0 value interpret-cnt   \ compiles slowly, so give user something to look at
! 0 value opt-started?
  
  : OPT-INTERPRET ( -- )
          begin   bl word dup c@
!         while   save-src
  \ cr pocket count type
                  find ?dup
***************
*** 698,703 ****
                  FALSE to opt-state
                  ['] _BEGIN to opt-last \ arm
!                 defer@ interpret to prev-interpret
!                 ['] opt-interpret is interpret 
                  opt2data ;
  
--- 698,703 ----
                  FALSE to opt-state
                  ['] _BEGIN to opt-last \ arm
!                 action-of interpret to prev-interpret
!                 ['] opt-interpret is interpret
                  opt2data ;
  
***************
*** 708,712 ****
                  if      ['] _interpret
                  then    is interpret
!                 0 to prev-interpret 
                  opt2code ;
  
--- 708,712 ----
                  if      ['] _interpret
                  then    is interpret
!                 0 to prev-interpret
                  opt2code ;
  

[Win32forth-cvs] win32forth/src DBGSRC2.F, 1.4, 1.5 Debug.f, 1.14, 1.15 ENVIRON.F, 1.3, 1.4 Extend.f, 1.10, 1.11 Primutil.f, 1.18, 1.19 imageman.f, 1.10, 1.11

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

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8301/win32forth/src

Modified Files:
	DBGSRC2.F Debug.f ENVIRON.F Extend.f Primutil.f imageman.f 
Log Message:
gah:Added ACTION-OF (per F200X) and made DEFER@ a (temporary) deprecated synonym. Replaced defer@ by action-of (accept in 486asm). Added DEFER!. Support for extension queries (partial) added to environment.f

Index: Extend.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Extend.f,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Extend.f	22 Jul 2006 08:21:53 -0000	1.10
--- Extend.f	28 Sep 2006 10:16:48 -0000	1.11
***************
*** 115,119 ****
  : HELLO         { \ doing-app? -- }             \ startup stuff
                  only forth also definitions
!                 defer@ default-application ['] bye <> to doing-app?
                  init-console                    \ -- f1
                  dup                             \ init if we created a console
--- 115,119 ----
  : HELLO         { \ doing-app? -- }             \ startup stuff
                  only forth also definitions
!                 action-of default-application ['] bye <> to doing-app?
                  init-console                    \ -- f1
                  dup                             \ init if we created a console

Index: Debug.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Debug.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Debug.f	21 Sep 2006 12:46:08 -0000	1.14
--- Debug.f	28 Sep 2006 10:16:48 -0000	1.15
***************
*** 452,456 ****
                  left-margin-save to left-margin
                  indent-save      to indent
!                  key-save defer@ key = ?EXIT
                  emit-save        is emit
                  type-save        is type
--- 452,456 ----
                  left-margin-save to left-margin
                  indent-save      to indent
!                 key-save action-of key = ?EXIT
                  emit-save        is emit
                  type-save        is type
***************
*** 472,491 ****
  
  : debug-io      ( -- )
!                 defer@ key key-save = ?EXIT     \ leave already saved
!                 getxy to y-save to x-save
!                 defer@ emit    to   emit-save   \ save current contents
!                 defer@ type    to   type-save
!                 defer@ cr      to     cr-save
!                 defer@ ?cr     to    ?cr-save
!                 defer@ key     to    key-save
!                 defer@ key?    to   key?-save
!                 defer@ cls     to    cls-save
!                 defer@ page    to   page-save
!                 defer@ gotoxy  to gotoxy-save
!                 defer@ getxy   to  getxy-save
!                 defer@ col     to    col-save
!                 tabing?        to tabing?-save
!                 left-margin    to left-margin-save
!                 indent         to indent-save
                  remote-debug? 0=
                  IF      unhide-console
--- 472,491 ----
  
  : debug-io      ( -- )
!                 action-of key key-save = ?EXIT     \ leave already saved
!                 getxy to y-save  to x-save
!                 action-of emit   to   emit-save   \ save current contents
!                 action-of type   to   type-save
!                 action-of cr     to     cr-save
!                 action-of ?cr    to    ?cr-save
!                 action-of key    to    key-save
!                 action-of key?   to   key?-save
!                 action-of cls    to    cls-save
!                 action-of page   to   page-save
!                 action-of gotoxy to gotoxy-save
!                 action-of getxy  to  getxy-save
!                 action-of col    to    col-save
!                 tabing?          to tabing?-save
!                 left-margin      to left-margin-save
!                 indent           to indent-save
                  remote-debug? 0=
                  IF      unhide-console

Index: DBGSRC2.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/DBGSRC2.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** DBGSRC2.F	12 Jun 2006 12:25:11 -0000	1.4
--- DBGSRC2.F	28 Sep 2006 10:16:48 -0000	1.5
***************
*** 71,76 ****
                  then
                  editor-present? 0= ?EXIT
!                 defer@ type >r ['] buf-type is type
!                 defer@ emit >r ['] buf-emit is emit
                  ed-dbgline off
                  .smax @ >r 3 .smax !    \ limit stack display to 3 items
--- 71,76 ----
                  then
                  editor-present? 0= ?EXIT
!                 action-of type >r ['] buf-type is type
!                 action-of emit >r ['] buf-emit is emit
                  ed-dbgline off
                  .smax @ >r 3 .smax !    \ limit stack display to 3 items
***************
*** 114,119 ****
                          UNTIL   drop
                  then prev-return return-top -   \ if return stack has changed
!                 if      defer@ type >r ['] rst-type is type
!                         defer@ emit >r ['] rst-emit is emit
                          ed-return off
                          return-top      \ if returnstack is set
--- 114,119 ----
                          UNTIL   drop
                  then prev-return return-top -   \ if return stack has changed
!                 if      action-of type >r ['] rst-type is type
!                         action-of emit >r ['] rst-emit is emit
                          ed-return off
                          return-top      \ if returnstack is set

Index: imageman.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/imageman.f,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** imageman.f	13 Feb 2006 14:06:09 -0000	1.10
--- imageman.f	28 Sep 2006 10:16:48 -0000	1.11
***************
*** 955,961 ****
                  depth 3 < abort" Need 3 arguments, APP-MEM SYS-MEM and APP-CFA"
                  >r 2drop
!                 defer@ boot
!                 defer@ default-application
!                 defer@ default-hello is boot \ initialization program to BOOT
                  r> is default-application    \ calls default application after init
                  &except off                  \ no previous exceptions...
--- 955,961 ----
                  depth 3 < abort" Need 3 arguments, APP-MEM SYS-MEM and APP-CFA"
                  >r 2drop
!                 action-of boot
!                 action-of default-application
!                 action-of default-hello is boot \ initialization program to BOOT
                  r> is default-application    \ calls default application after init
                  &except off                  \ no previous exceptions...
***************
*** 970,974 ****
                  ignore-missing-procs?
                  true to ignore-missing-procs?     \ WHEN TURNKEYING, IGNORE MISSING PROCEDURE WARNINGS !
!                 defer@ INIT-CONSOLE ['] x_INIT-CONSOLE is INIT-CONSOLE \ no statusbar for the console
                  SYS-SIZE 0 ['] SYS-SIZE >BODY !   \ set system free space to zero, no system
                  FALSE to with-source?             \ no source level debugging
--- 970,974 ----
                  ignore-missing-procs?
                  true to ignore-missing-procs?     \ WHEN TURNKEYING, IGNORE MISSING PROCEDURE WARNINGS !
!                 action-of INIT-CONSOLE ['] x_INIT-CONSOLE is INIT-CONSOLE \ no statusbar for the console
                  SYS-SIZE 0 ['] SYS-SIZE >BODY !   \ set system free space to zero, no system
                  FALSE to with-source?             \ no source level debugging

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** Primutil.f	13 Sep 2006 09:34:57 -0000	1.18
--- Primutil.f	28 Sep 2006 10:16:48 -0000	1.19
***************
*** 161,165 ****
                  then    ; immediate
  
! : defer@        ( -<name>- )    \ function currently in deferred word name
                  ' >BODY
                  state @
--- 161,166 ----
                  then    ; immediate
  
! : action-of     ( "<spaces>name" -- xt ) \ 200X   system      Core ext x:deferred
! \ *G Return xt that deferred word name is set to. When compiling put into current def.
                  ' >BODY
                  state @
***************
*** 168,173 ****
--- 169,185 ----
                  then    ; immediate
  
+ synonym defer@ action-of deprecated
+ 
  in-application
  
+ 
+ \ : defer@        ( xt1 -- xt2 )           \ 200X               Core ext x:deferred
+ \ *G xt1 is deffered word. xt2 is current setting.
+ \                >body @ ; \ currently unsupported until old use fades out.
+ 
+ : DEFER!        ( xt2 xt1 -- )           \ 200X               Core ext x:deferred
+ \ *G xt1 is deffered word. xt2 is new setting.
+                 >body ! ;
+ 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Index: ENVIRON.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/ENVIRON.F,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** ENVIRON.F	30 Aug 2005 11:55:15 -0000	1.3
--- ENVIRON.F	28 Sep 2006 10:16:48 -0000	1.4
***************
*** 24,32 ****
                 TRUE  CONSTANT CORE-EXT
          -10 7 / -2 = CONSTANT FLOORED
! 
! \ -rbs
! \         0xFFFFFFFF  CONSTANT MAX-CHAR
! 0xFF CONSTANT MAX-CHAR
! 
  0x7FFFFFFF.FFFFFFFF 2CONSTANT MAX-D
           0x7FFFFFFF  CONSTANT MAX-N
--- 24,28 ----
                 TRUE  CONSTANT CORE-EXT
          -10 7 / -2 = CONSTANT FLOORED
!                0xFF  CONSTANT MAX-CHAR
  0x7FFFFFFF.FFFFFFFF 2CONSTANT MAX-D
           0x7FFFFFFF  CONSTANT MAX-N
***************
*** 53,59 ****
                 TRUE  CONSTANT STRING-EXT
             #-LOCALS  CONSTANT #LOCALS
!                             : LOCALS TRUE ;
!                TRUE  CONSTANT LOCALS-EXT             
!                TRUE  CONSTANT WIN32FORTH
  
  LOADED? FLOAT.F [IF]
--- 49,54 ----
                 TRUE  CONSTANT STRING-EXT
             #-LOCALS  CONSTANT #LOCALS
!                TRUE  CONSTANT LOCALS
!                TRUE  CONSTANT LOCALS-EXT
  
  LOADED? FLOAT.F [IF]
***************
*** 64,68 ****
  [then]
  
! forth definitions
  
  
--- 59,74 ----
  [then]
  
! \ Win32Forth specific queries
!                TRUE  CONSTANT WIN32FORTH
! 
! 
! \ Added Wednesday, September 27 2006 to support Forth 200x extensions. gah
! 
!                             : X:EXTENSION-QUERY ;
!                             : X:DEFINED         ;
! \                            : X:DEFERRED        ; \ Not fully done yet
! \                            : X:PARSE-NAME      ; \ Not yet
! 
! previous definitions
  
  

[Win32forth-cvs] win32forth/apps/Setup Setup.f,1.10,1.11

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

Update of /cvsroot/win32forth/win32forth/apps/Setup
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8301/win32forth/apps/Setup

Modified Files:
	Setup.f 
Log Message:
gah:Added ACTION-OF (per F200X) and made DEFER@ a (temporary) deprecated synonym. Replaced defer@ by action-of (accept in 486asm). Added DEFER!. Support for extension queries (partial) added to environment.f

Index: Setup.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Setup/Setup.f,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Setup.f	23 Jul 2006 09:29:50 -0000	1.10
--- Setup.f	28 Sep 2006 10:16:47 -0000	1.11
***************
*** 72,76 ****
  : setup-bye     ( -- )
          &CB-BYE @ &noop &CB-BYE !  \ make BYE a noop; so that destroying the console
!         defer@ bye ['] noop is bye \ window will not terminate the setup
          _conHndl call DestroyWindow drop \ destroy the console window
          regsett count s" console" setsetting \ restore console window size in registry
--- 72,76 ----
  : setup-bye     ( -- )
          &CB-BYE @ &noop &CB-BYE !  \ make BYE a noop; so that destroying the console
!         action-of bye ['] noop is bye \ window will not terminate the setup
          _conHndl call DestroyWindow drop \ destroy the console window
          regsett count s" console" setsetting \ restore console window size in registry

[Win32forth-cvs] win32forth/src/lib FCOM.F,1.5,1.6

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

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8301/win32forth/src/lib

Modified Files:
	FCOM.F 
Log Message:
gah:Added ACTION-OF (per F200X) and made DEFER@ a (temporary) deprecated synonym. Replaced defer@ by action-of (accept in 486asm). Added DEFER!. Support for extension queries (partial) added to environment.f

Index: FCOM.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/FCOM.F,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** FCOM.F	13 Sep 2006 09:34:57 -0000	1.5
--- FCOM.F	28 Sep 2006 10:16:48 -0000	1.6
***************
*** 855,859 ****
  
  : comfind ( str -- str 0 | cfa flag )
!   [ defer@ find literal ] execute  \ call previous find word
    ?dup 0= if count 0 ?typelib if ['] noop 1 else drop 1- 0 then
    then ;
--- 855,859 ----
  
  : comfind ( str -- str 0 | cfa flag )
!   [ action-of find literal ] execute  \ call previous find word
    ?dup 0= if count 0 ?typelib if ['] noop 1 else drop 1- 0 then
    then ;

[Win32forth-cvs] win32forth-stc lgpl.txt,NONE,1.1

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25660

Added Files:
	lgpl.txt 
Log Message:
arm: GPL licences

--- NEW FILE: lgpl.txt ---
		  GNU LESSER GENERAL PUBLIC LICENSE
		       Version 2.1, February 1999

 Copyright (C) 1991, 1999 Free Software Foundation, Inc.
 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

[This is the first released version of the Lesser GPL.  It also counts
 as the successor of the GNU Library Public License, version 2, hence
 the version number 2.1.]

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.

  This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it.  You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.

  When we speak of free software, we are referring to freedom of use,
not price.  Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.

  To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights.  These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.

  For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you.  You must make sure that they, too, receive or can get the source
code.  If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it.  And you must show them these terms so they know their rights.

  We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.

  To protect each distributor, we want to make it very clear that
there is no warranty for the free library.  Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.

  Finally, software patents pose a constant threat to the existence of
any free program.  We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder.  Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.

  Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License.  This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License.  We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.

  When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library.  The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom.  The Lesser General
Public License permits more lax criteria for linking other code with
the library.

  We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License.  It also provides other free software developers Less
of an advantage over competing non-free programs.  These disadvantages
are the reason we use the ordinary General Public License for many
libraries.  However, the Lesser license provides advantages in certain
special circumstances.

  For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard.  To achieve this, non-free programs must be
allowed to use the library.  A more frequent case is that a free
library does the same job as widely used non-free libraries.  In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.

  In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software.  For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.

  Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.

  The precise terms and conditions for copying, distribution and
modification follow.  Pay close attention to the difference between a
"work based on the library" and a "work that uses the library".  The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.

		  GNU LESSER GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".

  A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.

  The "Library", below, refers to any such software library or work
which has been distributed under these terms.  A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language.  (Hereinafter, translation is
included without limitation in the term "modification".)

  "Source code" for a work means the preferred form of the work for
making modifications to it.  For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.

  Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it).  Whether that is true depends on what the Library does
and what the program that uses the Library does.
  
  1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.

  You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.

  2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) The modified work must itself be a software library.

    b) You must cause the files modified to carry prominent notices
    stating that you changed the files and the date of any change.

    c) You must cause the whole of the work to be licensed at no
    charge to all third parties under the terms of this License.

    d) If a facility in the modified Library refers to a function or a
    table of data to be supplied by an application program that uses
    the facility, other than as an argument passed when the facility
    is invoked, then you must make a good faith effort to ensure that,
    in the event an application does not supply such function or
    table, the facility still operates, and performs whatever part of
    its purpose remains meaningful.

    (For example, a function in a library to compute square roots has
    a purpose that is entirely well-defined independent of the
    application.  Therefore, Subsection 2d requires that any
    application-supplied function or table used by this function must
    be optional: if the application does not supply it, the square
    root function must still compute square roots.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.

In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library.  To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License.  (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.)  Do not make any other change in
these notices.

  Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.

  This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.

  4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.

  If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.

  5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library".  Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.

  However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library".  The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.

  When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library.  The
threshold for this to be true is not precisely defined by law.

  If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work.  (Executables containing this object code plus portions of the
Library will still fall under Section 6.)

  Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.

  6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.

  You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License.  You must supply a copy of this License.  If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License.  Also, you must do one
of these things:

    a) Accompany the work with the complete corresponding
    machine-readable source code for the Library including whatever
    changes were used in the work (which must be distributed under
    Sections 1 and 2 above); and, if the work is an executable linked
    with the Library, with the complete machine-readable "work that
    uses the Library", as object code and/or source code, so that the
    user can modify the Library and then relink to produce a modified
    executable containing the modified Library.  (It is understood
    that the user who changes the contents of definitions files in the
    Library will not necessarily be able to recompile the application
    to use the modified definitions.)

    b) Use a suitable shared library mechanism for linking with the
    Library.  A suitable mechanism is one that (1) uses at run time a
    copy of the library already present on the user's computer system,
    rather than copying library functions into the executable, and (2)
    will operate properly with a modified version of the library, if
    the user installs one, as long as the modified version is
    interface-compatible with the version that the work was made with.

    c) Accompany the work with a written offer, valid for at
    least three years, to give the same user the materials
    specified in Subsection 6a, above, for a charge no more
    than the cost of performing this distribution.

    d) If distribution of the work is made by offering access to copy
    from a designated place, offer equivalent access to copy the above
    specified materials from the same place.

    e) Verify that the user has already received a copy of these
    materials or that you have already sent this user a copy.

  For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it.  However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.

  It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system.  Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.

  7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:

    a) Accompany the combined library with a copy of the same work
    based on the Library, uncombined with any other library
    facilities.  This must be distributed under the terms of the
    Sections above.

    b) Give prominent notice with the combined library of the fact
    that part of it is a work based on the Library, and explaining
    where to find the accompanying uncombined form of the same work.

  8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License.  Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License.  However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.

  9. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Library or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.

  10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.

  11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all.  For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.

If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded.  In such case, this License incorporates the limitation as if
written in the body of this License.

  13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.

Each version is given a distinguishing version number.  If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation.  If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.

  14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission.  For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this.  Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.

			    NO WARRANTY

  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.

		     END OF TERMS AND CONDITIONS

           How to Apply These Terms to Your New Libraries

  If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change.  You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).

  To apply these terms, attach the following notices to the library.  It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.

    <one line to give the library's name and a brief idea of what it does.>
    Copyright (C) <year>  <name of author>

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library 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
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

Also add information on how to contact you by electronic and paper mail.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the
  library `Frob' (a library for tweaking knobs) written by James Random Hacker.

  <signature of Ty Coon>, 1 April 1990
  Ty Coon, President of Vice

That's all there is to it!

[Win32forth-cvs] win32forth-stc gpl.txt,NONE,1.1

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25289

Added Files:
	gpl.txt 
Log Message:
arm: GPL licences

--- NEW FILE: gpl.txt ---
		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Lesser General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	    How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) <year>  <name of author>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the 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.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) year name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  <signature of Ty Coon>, 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Lesser General
Public License instead of this License.

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.3, 1.4 gversion.f, 1.1, 1.2

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5036

Modified Files:
	gkernel.f gversion.f 
Log Message:
arm: bring kernel up to latest version
remove do;-chain as no longer required
consistent support for inline

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** gkernel.f	23 Sep 2006 09:54:28 -0000	1.3
--- gkernel.f	27 Sep 2006 21:38:59 -0000	1.4
***************
*** 2303,2306 ****
--- 2303,2308 ----
  variable latestxt               \ xt of last definition
  variable last-link              \ address of last link for last header created
+ 0 value ofa                     \ ofa support
+ 
  
   26 offset  link>name ( lfa -- nfa )
***************
*** 2391,2395 ****
  
  : (compiles) ( xt2 xt1 -- )                   \ set the compile word
!             xt>ct ! ;
  
  : (comp-only)   ( -- )                        \ compile only message
--- 2393,2397 ----
  
  : (compiles) ( xt2 xt1 -- )                   \ set the compile word
!             >comp ! ;
  
  : (comp-only)   ( -- )                        \ compile only message
***************
*** 2429,2437 ****
              body-off + @ ;
  
- : dogen     ( xt <-name-> -- )                \ generate do code
-             header                            \ header
-             here movecx#, xt-jmp,             \ name -> mov ecx, # here | jmp xt
-             _next move-code ;                 \ stops disasm
- 
  gcode _lit
                  mov     -4 [ebp], eax
--- 2431,2434 ----
***************
*** 2443,2460 ****
              ( -- n )                          \ run time
      (comp-only)                               \ compile only
!     compilation> ( -- xt ) drop
!             code-here _lit move-code
              5 + !                             \ update the literal in the code
              ;
  
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
!             header
              postpone literal
              _next move-code                   \ stops disassembler
!             ;
! 
! 0 1 in/out : create    ( -<name>- )           \ pointer
!             ['] dovar dogen
              ;
  
--- 2440,2469 ----
              ( -- n )                          \ run time
      (comp-only)                               \ compile only
!     compilation> ( -- xt )
!             drop code-here _lit move-code
              5 + !                             \ update the literal in the code
              ;
  
+ : dogen     ( xt <-name-> -- )                \ generate do code
+             header                            \ header
+             here movecx#, xt-jmp,             \ name -> mov ecx, # here | jmp xt
+             ofa-calc                          \ length calculation
+             _next move-code ;                 \ stops disasm
+ 
+ 0 1 in/out : create    ( -<name>- )           \ pointer
+             ['] dovar dogen
+             ;
+ 
+ : (x-cons)  ( xt -- )                         \ execute & compile a literal
+             execute postpone literal ;
+ 
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
! \            >system create , system>          \ create in system space
!             header                            \
              postpone literal
+             ofa-calc                          \ length calculation
              _next move-code                   \ stops disassembler
!             ['] (x-cons) latestxt @ (compiles)
              ;
  
***************
*** 2464,2469 ****
--- 2473,2491 ----
              ;
  
+ gcode _litval
+                 mov     -4 [ebp], eax
+                 mov     eax, 1234
+                 lea     ebp, -4 [ebp]
+                 ;g
+                 
+ : (litval)  ( n -- )
+             >body 
+             code-here _litval move-code
+             5 + !                             \ update the literal in the code
+             ;
+ 
  0 1 in/out : value     ( n -<name>- )         \ self fetching value
              ['] doval dogen ,
+             ['] (litval) latestxt @ (compiles)
              ;
  
***************
*** 2476,2488 ****
              ;                                 \ compile only
  
- \ : literal   ( n -- )                        \ literal
- \             movecx#, ['] dolit compile, ; immediate
- 
- \ : constant  ( n "name")                     \ constant
- \             ['] docon dogen , ;
- 
- \ : variable  ( "name")                       \ variable
- \             create 0 , ;
- 
  \ -------------------- Link Operations (Single Linked)  --------------------
  
--- 2498,2501 ----
***************
*** 3471,3476 ****
  
  : 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 ;
  
--- 3484,3490 ----
  
  : inline        ( -- )                           \ code will be inlined
!                 tail-call 0= if                   \ there's a tail-call, so not inlineable
!                   ['] xt-inline,
!                   last @ name>ct cell- !          \ comp field
                  then ;
  
***************
*** 3567,3571 ****
  : header    ( -<name>- )                      \ build a header
              code-align                        \ align code section, temporary
!             bl word count "header ;
  
  : alias     ( xt -<name>- )                   \ make another 'name' for 'xt'
--- 3581,3587 ----
  : header    ( -<name>- )                      \ build a header
              code-align                        \ align code section, temporary
!             bl word count "header 
!             latestxt @ to ofa                 \ for length calculations of the code generated
!             ;
  
  : alias     ( xt -<name>- )                   \ make another 'name' for 'xt'
***************
*** 4521,4525 ****
                  postpone then ;
  
- defer do-;chain ' noop is do-;chain
  variable csp                           \ current stack pointer variable
  
--- 4537,4540 ----
***************
*** 4532,4537 ****
  \ Words to support ;
  
- 0 value ofa
- 
  : (ofa-calc)    ( ofa -- )
                  code-here swap -       \ length of the code
--- 4547,4550 ----
***************
*** 4546,4550 ****
                  postpone unnest        \ extra ret to stop see (ret ret is end of definition)
                  postpone [ ?csp        \ stop compiling, check stack
!                 do-;chain ;
  
  |: ;noname      ( -- )                 \ ; for :noname
--- 4559,4563 ----
                  postpone unnest        \ extra ret to stop see (ret ret is end of definition)
                  postpone [ ?csp        \ stop compiling, check stack
!                 ;
  
  |: ;noname      ( -- )                 \ ; for :noname
***************
*** 4552,4556 ****
  
  |: ;name        ( -- )                 \ ; for :
!                 latestxt @ (ofa-calc)  \ length calculation
                  (;noname) reveal ;     \ reveal the name
  
--- 4565,4569 ----
  
  |: ;name        ( -- )                 \ ; for :
!                 ofa-calc               \ length calculation
                  (;noname) reveal ;     \ reveal the name
  
***************
*** 4759,4764 ****
  
  : get-order     ( -- widn .. wid1 n )      \ fetch widn .. wid1 n
!                 context-base context
!                 - 2 rshift dup >r
                  0 ?do
                    context-base i 1+ cells - @
--- 4772,4777 ----
  
  : get-order     ( -- widn .. wid1 n )      \ fetch widn .. wid1 n
!                 context-base context -
!                 2 rshift dup >r
                  0 ?do
                    context-base i 1+ cells - @
***************
*** 4849,4853 ****
                  s" ." defext$ place
                  /parse-s$ count
!                 over c@ [char] . = if 1 /string then
                  6 min defext$ +place
                  defext$ +null
--- 4862,4866 ----
                  s" ." defext$ place
                  /parse-s$ count
!                 over c@ [char] . = negate /string
                  6 min defext$ +place
                  defext$ +null
***************
*** 5471,5474 ****
--- 5484,5488 ----
              header                            \ create a defer
              jmp[], ['] defer-err ,            \ the jump
+             ofa-calc                          \ length calculation
              ;
  
***************
*** 5942,5944 ****
--- 5956,5959 ----
  ' warnmsg       resolves warnmsg
  ' find          resolves find
+ ' ofa-calc      resolves ofa-calc
  

Index: gversion.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gversion.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** gversion.f	21 Sep 2006 16:26:33 -0000	1.1
--- gversion.f	27 Sep 2006 21:38:59 -0000	1.2
***************
*** 3,7 ****
  cr .( Loading META version info)
  
! 00203     VALUE #VERSION#
  
  \ Change only the version number above; the build number is automatically assigned.
--- 3,7 ----
  cr .( Loading META version info)
  
! 00204     VALUE #VERSION#
  
  \ Change only the version number above; the build number is automatically assigned.

[Win32forth-cvs] win32forth-stc/src asmwin32.f, 1.3, 1.4 primutil.f, 1.5, 1.6

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5024

Modified Files:
	asmwin32.f primutil.f 
Log Message:
arm: bring kernel up to latest version
remove do;-chain as no longer required
consistent support for inline

Index: asmwin32.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/asmwin32.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** asmwin32.f	27 Sep 2006 09:09:50 -0000	1.3
--- asmwin32.f	27 Sep 2006 21:38:36 -0000	1.4
***************
*** 91,98 ****
  ' _enter-assembler is enter-assembler
  
! : _exit-assembler       ( -- )
!                 semicolon-chain do-chain ;
! 
! ' _exit-assembler is exit-assembler
  
  only forth also definitions
--- 91,95 ----
  ' _enter-assembler is enter-assembler
  
! \ exit-assembler is unused      ( -- )
  
  only forth also definitions

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** primutil.f	25 Sep 2006 11:57:53 -0000	1.5
--- primutil.f	27 Sep 2006 21:38:36 -0000	1.6
***************
*** 136,146 ****
  in-system
  
- new-sys-chain      semicolon-chain  \ chain of things to do at end of definition
  new-sys-chain         forget-chain  \ chain of types of things to forget
  new-sys-chain    post-forget-chain  \ chain of types of things to forget
  
- :noname         ( -- )
-                 semicolon-chain do-chain ; is do-;chain
- 
  :noname         ( -- )         \ chain for cleanup
                  initialization-chain do-chain ; is load-forth \ install in kernel word
--- 136,142 ----

[Win32forth-cvs] win32forth-stc gkernel.exe,1.2,1.3

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5009

Modified Files:
	gkernel.exe 
Log Message:
arm: bring kernel up to latest version
remove do;-chain as no longer required
consistent support for inline

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
Binary files /tmp/cvsQO8O05 and /tmp/cvsGgnw9m differ

[Win32forth-cvs] win32forth-stc/src dis486.f,1.1,1.2

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23151

Modified Files:
	dis486.f 
Log Message:
arm: correct spacing on output, support REST and SEE

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** dis486.f	21 Sep 2006 16:26:33 -0000	1.1
--- dis486.f	27 Sep 2006 21:01:56 -0000	1.2
***************
*** 101,105 ****
  : cmnt-col 60 col ; \ set to comment field
  
! : .ss     ( n adr len w ) oper-col >r drop swap r@ * + r> type ;
  : .#      ( -- )          ." # " ;
  : .,      ( -- )          ." , " ;
--- 101,105 ----
  : cmnt-col 60 col ; \ set to comment field
  
! : .ss     ( n adr len w ) oper-col >r drop swap r@ * + r> type opnd-col ;
  : .#      ( -- )          ." # " ;
  : .,      ( -- )          ." , " ;
***************
*** 366,370 ****
  \ -------------------- ALU Opcodes --------------------
  
! : .alu  ( n -- )            bits3-5 S" addor adcsbbandsubxorcmp" 3 .ss opnd-col ;
  : alu   ( adr op -- adr' )  dup .alu r/m() ;
  
--- 366,370 ----
  \ -------------------- ALU Opcodes --------------------
  
! : .alu  ( n -- )            bits3-5 S" addor adcsbbandsubxorcmp" 3 .ss ;
  : alu   ( adr op -- adr' )  dup .alu r/m() ;
  
***************
*** 388,392 ****
  
  : txb   ( addr op -- addr' )
!         dup bits0-1 S" testtestxchgxchg" 4 .ss opnd-col
          1 and
          IF      1 to dis.size r,r/m()     \ SMuB removed COUNT
--- 388,392 ----
  
  : txb   ( addr op -- addr' )
!         dup bits0-1 S" testtestxchgxchg" 4 .ss
          1 and
          IF      1 to dis.size r,r/m()     \ SMuB removed COUNT
***************
*** 508,512 ****
  : .jxx ( addr op -- addr' ) oper-col ." j" .cnd-code(op) opnd-col ;
  : bra  ( addr op -- addr' ) .jxx .rel8 ;
! : lup  ( addr op -- addr' ) bits0-1 S" loopnzloopz loop  jecxz " 6 .ss opnd-col .rel8 ;
  : lbr  ( addr op -- addr' ) .jxx .rel16/32 ;
  : rtn  ( addr op -- addr' ) .sop" ret"     ." near " 1 and 0= IF wCount $. THEN ;
--- 508,512 ----
  : .jxx ( addr op -- addr' ) oper-col ." j" .cnd-code(op) opnd-col ;
  : bra  ( addr op -- addr' ) .jxx .rel8 ;
! : lup  ( addr op -- addr' ) bits0-1 S" loopnzloopz loop  jecxz " 6 .ss .rel8 ;
  : lbr  ( addr op -- addr' ) .jxx .rel16/32 ;
  : rtn  ( addr op -- addr' ) .sop" ret"     ." near " 1 and 0= IF wCount $. THEN ;
***************
*** 543,547 ****
  \ -------------------- Shifts & Rotates --------------------
  
! : .shift ( n -- ) bits0-2 S" rolrorrclrcrshlshrxxxsar" 3 .ss opnd-col ;
  
  
--- 543,547 ----
  \ -------------------- Shifts & Rotates --------------------
  
! : .shift ( n -- ) bits0-2 S" rolrorrclrcrshlshrxxxsar" 3 .ss ;
  
  
***************
*** 605,613 ****
          THEN ;
  
! : falu1   ( xopcode -- )   bits3-5 S" fadd fmul fcom fcompfsub fsubrfdiv fdivr"         5 .ss opnd-col ;
! : falu3   ( op -- )        bits3-5 S" fiadd fimul ficom ficompfisub fisubrfidiv fidivr" 6 .ss opnd-col ;
! : falu5   ( xopcode -- )   bits3-5 s" fadd fmul ???? ???? fsubrfsub fdivrfdiv "         5 .ss opnd-col ;
! : falu6   ( op -- )        bits3-5 s" ffree ???   fst   fstp  fucom fucomp???   ???   " 6 .ss opnd-col ;
! : falu7   ( op -- )        bits3-5 S" faddp fmulp ???   ???   fsubrpfsubp fdivrpfdivp " 6 .ss opnd-col ;
  
  : sti.   ( op -- )         bits0-2 ." st(" 1 .r ." )" ;
--- 605,613 ----
          THEN ;
  
! : falu1   ( xopcode -- )   bits3-5 S" fadd fmul fcom fcompfsub fsubrfdiv fdivr"         5 .ss ;
! : falu3   ( op -- )        bits3-5 S" fiadd fimul ficom ficompfisub fisubrfidiv fidivr" 6 .ss ;
! : falu5   ( xopcode -- )   bits3-5 s" fadd fmul ???? ???? fsubrfsub fdivrfdiv "         5 .ss ;
! : falu6   ( op -- )        bits3-5 s" ffree ???   fst   fstp  fucom fucomp???   ???   " 6 .ss ;
! : falu7   ( op -- )        bits3-5 S" faddp fmulp ???   ???   fsubrpfsubp fdivrpfdivp " 6 .ss ;
  
  : sti.   ( op -- )         bits0-2 ." st(" 1 .r ." )" ;
***************
*** 637,641 ****
             S" fprem  fyl2xp1fsqrt  fsincosfrndintfscale fsin   fcos   "
          THEN
!         7 .ss opnd-col ;
  
  : fnullary-e   ( op -- )
--- 637,641 ----
             S" fprem  fyl2xp1fsqrt  fsincosfrndintfscale fsin   fcos   "
          THEN
!         7 .ss ;
  
  : fnullary-e   ( op -- )
***************
*** 646,650 ****
             S" fld1   fldl2t fldl2e fldpi  fldlg2 fldln2 fldz   ???    "
          THEN
!         7 .ss opnd-col ;
  
  : fnullary   ( op -- )
--- 646,650 ----
             S" fld1   fldl2t fldl2e fldpi  fldlg2 fldln2 fldz   ???    "
          THEN
!         7 .ss ;
  
  : fnullary   ( op -- )
***************
*** 712,716 ****
  : fcmovb  ( op -- )
          bits3-5
!         S" fcmovnb fcmovne fcmovnbefcmovnu ???     fucomi  fcomi   ???     " 8 .ss opnd-col ;
  
  : fdb   ( addr op -- addr' )
--- 712,716 ----
  : fcmovb  ( op -- )
          bits3-5
!         S" fcmovnb fcmovne fcmovnbefcmovnu ???     fucomi  fcomi   ???     " 8 .ss ;
  
  : fdb   ( addr op -- addr' )
***************
*** 771,778 ****
  
  : gp6 ( addr op -- addr' )
!         drop count dup bits3-5 S" sldtstr lldtltr verrverw??? ???" 4 .ss opnd-col r/m16(ModR/M) ;
  
  : gp7 ( addr op -- addr' )
!         drop count dup bits3-5 dup S" sgdt  sidt  lgdt  lidt  smsw  ???   lmsw  invlpg" 6 .ss opnd-col
          4 and 4 =
          if   r/m16(ModR/M)
--- 771,778 ----
  
  : gp6 ( addr op -- addr' )
!         drop count dup bits3-5 S" sldtstr lldtltr verrverw??? ???" 4 .ss r/m16(ModR/M) ;
  
  : gp7 ( addr op -- addr' )
!         drop count dup bits3-5 dup S" sgdt  sidt  lgdt  lidt  smsw  ???   lmsw  invlpg" 6 .ss
          4 and 4 =
          if   r/m16(ModR/M)
***************
*** 780,784 ****
          then ;
  
! : .btx(XXXN-NXXX)  ( n -- )   bits3-4 S" bt btsbtrbtc" 3 .ss opnd-col ;
  
  : gp8 ( addr op -- addr' )
--- 780,784 ----
          then ;
  
! : .btx(XXXN-NXXX)  ( n -- )   bits3-4 S" bt btsbtrbtc" 3 .ss ;
  
  : gp8 ( addr op -- addr' )
***************
*** 887,891 ****
  \ --------------------- MMX Operations -----------------
  
! : mmx-size ( op -- ) bits0-1 S" bwdq" 1 .ss opnd-col ;
  
  
--- 887,891 ----
  \ --------------------- MMX Operations -----------------
  
! : mmx-size ( op -- ) bits0-1 S" bwdq" 1 .ss ;
  
  
***************
*** 1070,1080 ****
  : rest          ( -- )
                  begin
!                   cr
!                   dup next?                    \ NEXT ?
                  while
!                   inst
                    start/stop
                  repeat
!                 dis-loc .sop" next" ." ;c" cmnt-col ."  \ end of word sequence"
                  ;
  
--- 1070,1090 ----
  : rest          ( -- )
                  begin
!                   dup cr inst
!                   start/stop
!                   swap next? 0=                \ NEXT ?
!                 until drop
!                 ;
! 
! : see           ( -- )
!                 defined ?missing
!                 dup xt>name n>ofa w@ over +    \ length to disassemble
!                 swap
!                 begin
!                   2dup - 0> over next? 0= or   \ anything left?
                  while
!                   cr inst
                    start/stop
                  repeat
!                 ."  ( end )" 2drop
                  ;
  
***************
*** 1086,1090 ****
  
  : rest rest ;
! : see  defined ?missing rest ;
  
  ONLY FORTH ALSO DEFINITIONS
--- 1096,1100 ----
  
  : rest rest ;
! : see  see  ;
  
  ONLY FORTH ALSO DEFINITIONS

[Win32forth-cvs] win32forth-stc/doc readme.txt,1.4,1.5

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/doc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10167/doc

Modified Files:
	readme.txt 
Log Message:
typo fixed

Index: readme.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** readme.txt	26 Sep 2006 16:29:20 -0000	1.4
--- readme.txt	27 Sep 2006 16:21:23 -0000	1.5
***************
*** 52,56 ****
  
  fload src\task
! fload semos\taskdemo
  
  To run pardemo
--- 52,56 ----
  
  fload src\task
! fload demos\taskdemo
  
  To run pardemo

[Win32forth-cvs] win32forth-stc/src asmwin32.f,1.2,1.3

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

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv848/win32forth-stc/src

Modified Files:
	asmwin32.f 
Log Message:
gah:Alex's fix for (_code)

Index: asmwin32.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/asmwin32.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** asmwin32.f	23 Sep 2006 06:00:17 -0000	1.2
--- asmwin32.f	27 Sep 2006 09:09:50 -0000	1.3
***************
*** 34,38 ****
          code-header hide
          !csp init-asm
!         0 to ofa ;
  
  ' (_code) is code
--- 34,38 ----
          code-header hide
          !csp init-asm
!         code-here to ofa ;
  
  ' (_code) is code

[Win32forth-cvs] win32forth-stc/doc readme.txt,1.3,1.4

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

Update of /cvsroot/win32forth/win32forth-stc/doc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv4777/win32forth-stc/doc

Modified Files:
	readme.txt 
Log Message:
gah:Updated for extra demos

Index: readme.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** readme.txt	25 Sep 2006 12:02:24 -0000	1.3
--- readme.txt	26 Sep 2006 16:29:20 -0000	1.4
***************
*** 42,44 ****
     fload demos\TestPde
  
! ( NB for comparison with the ITC version (or rival STC versions) just fload Pde1 in them; the test harness isn't needed)
\ No newline at end of file
--- 42,65 ----
     fload demos\TestPde
  
! ( NB for comparison with the ITC version (or rival STC versions) just fload Pde1 in them; the test harness isn't needed)
! 
! To run the task demos
! -------------------------
! 
! 1.Run w32f.exe
! 
! 2. Type
! 
! fload src\task
! fload semos\taskdemo
! 
! To run pardemo
! 
! 1.Run w32f.exe
! 
! 2.Type
! 
! fload src\task
! fload src\multithr
! fload demos\pardemo
! 

[Win32forth-cvs] win32forth-stc/demos pardemo.f, NONE, 1.1 taskdemo.f, NONE, 1.1

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

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18614/win32forth-stc/demos

Added Files:
	pardemo.f taskdemo.f 
Log Message:
gah:Added multithr and multi-task demos

--- NEW FILE: taskdemo.f ---
\ $Id: taskdemo.f,v 1.1 2006/09/26 08:44:05 georgeahubert Exp $

\ needs task.f \ task demo code

\ -------------------- Demonstrations  --------------------
\ demo1 code, fairly complex example.
\ creates several running tasks and waits for them to complete.
\ each task runs and produces output on a line number passed as a parameter
\ and waits between printing numbers based on the line it's on.
\ wait-eachtask is notable -- it waits on all the tasks. as each task completes
\ it then rewaits on those that are still running until none are left.

make-lock console-lock                     \ a simple console lock, the console is not thread-safe
: c-lock console-lock lock getxy ;         \ lock console, save where the cursor is
: c-unlock gotoxy console-lock unlock ;    \ unlock, restore cursor

4 newuser location

: my-task { y -- }  \ prints a counter from 1 to 99 with a wait
                               \ that depends on which line it is running
          y location !         \ show that user & local variables work
          c-lock
          1 location @ gotoxy
          ." Task " tcb @ task>id @ .  tab
          ."  running at line " location @ 1+ .
          c-unlock
          100 1 do
          location @ 15 * task-sleep  \ sleep depends on line number, bigger=longer
          c-lock
            40 location @  gotoxy
            i  .
          c-unlock
          loop
          c-lock 50 location @ gotoxy ." Exiting..." c-unlock 1 ;     \  my exit code

15 value taskcount                      \ number of tasks to start
create taskblocks 15 cells allot        \ cells to hold task blocks ptrs
create taskhndls  15 cells allot        \ cells to hold task handles for wait function

: make-tasks   ( n -- )                  \ create the task blocks
    to taskcount
    taskcount 0 do
        i 1 +                            \ line number for my-task
        ['] my-task task-block           \ create the task block
        taskblocks i cells+ !            \ save in the taskblocks area
    loop
    ;

: run-tasks  ( -- )                      \ run all the tasks
    taskcount 0 do                       \ for each task
       taskblocks i cells+ @             \ get the task-block
       dup run-task drop                  \ run the tasks
       task>handle @ taskhndls i cells+ ! \ save all the task handles created
    loop
    ;

winerrmsg on

0 value taskwaits
: wait-eachtask ( -- )                   \ wait for each task
        taskcount to taskwaits
        begin
          taskwaits
        while
          INFINITE false taskhndls       \ wait for 1 or more tasks to end
          taskwaits call WaitForMultipleObjects \ wait on handles list
          dup WAIT_FAILED = if getlastwinerr then \ note the error
          WAIT_OBJECT_0 +
          dup>r taskblocks +cells @ task>id @   \ get the task id
          console-lock lock
          ." Task " . ." completed" cr
          console-lock unlock
          -1 +to taskwaits                    \ 1 fewer task, clean up the list
          taskhndls taskwaits cells+ @        \ get last handle in list
          taskhndls r@ cells+ !               \ store in signaled event ptr
          taskblocks taskwaits cells+ @       \ get last block in list
          taskblocks r> cells+ !              \ store in signaled block
        repeat
        ." All tasks completed" cr
    ;

: start-tasks ( n -- )
     make-tasks
     run-tasks
     console-lock lock
     0 25 gotoxy ." Main task is waiting for " taskcount . ." tasks" cr
     console-lock unlock
     wait-eachtask
     ." All tasks ended" cr
     ;

: demo1
     cls
     ." Demo1: Creating free running tasks "
     taskcount start-tasks ;

cr .( Type Demo1 to start Demo1) cr

\ demo2 creates 2 tasks that read the same file, but at varying speeds, showing
\ that file i/o is thread safe

4 newuser fhndl

: t2-openfile ( addr len -- )
        r/o open-file abort" File open error!" fhndl ! ;

: my-task2 { speed -- }
        console-lock lock
        tcb @  task>id @ ." Task" . ." is running with a delay of"
           speed . cr
        console-lock unlock
        s" src\task.f" Prepend<home>\ t2-openfile
        begin
          pad 256 fhndl @ read-line abort" IO Error!"
          tcb @  task-stop? not and
        while
          console-lock lock
          ." Task" tcb @  task>id @ .
          pad swap type cr
          console-lock unlock
          speed task-sleep
        repeat
        fhndl @ close-file ;

0 value task-slow
0 value task-fast
100 constant  task-slow-speed
30 constant  task-fast-speed

: demo2
  cls ." Multithread file I/O, press any key to stop" cr
  task-slow-speed ['] my-task2 task-block to task-slow
  task-fast-speed ['] my-task2 task-block to task-fast
  task-slow run-task drop
  task-fast run-task drop
  key drop
  task-slow stop-task
  task-fast stop-task
  ." Ended"
;

.( Type Demo2 to start Demo2, any key to stop) cr


--- NEW FILE: pardemo.f ---
\ needs multithr.f  \ 10-4-99

: ascii char state @ if postpone literal then ; immediate

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Timing Routines                     \
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

create TIME-BUF
here
        0 w,    \ +0  year
        0 w,    \ +2  month
        0 w,    \ +4  day of week
        0 w,    \ +6  day of month
        0 w,    \ +8  hour
        0 w,    \ +10 minute
        0 w,    \ +12 second
        0 w,    \ +14 milliseconds
here swap - constant TIME-LEN

create date$ 32 allot
create time$ 32 allot

: get-local-time ( -- )                 \ get the local computer date and time
        time-buf call GetLocalTime drop ;

: time&date     ( -- sec min hour day month year )
                get-local-time
                time-buf 12 + w@        \ seconds
                time-buf 10 + w@        \ minutes
                time-buf  8 + w@        \ hours
                time-buf  6 + w@        \ day of month
                time-buf  2 + w@        \ month of year
                time-buf      w@ ;      \ year

: .#"           ( n1 n2 -- a1 n3 )
                >r 0 <# r> 0 ?do # loop #> ;

: >date"        ( time_structure -- )
                >r 31 date$ null \ z" ddddd',' MMMM dd yyyy"
                r> null LOCALE_USER_DEFAULT
                call GetDateFormat date$ swap 1- ;

: .date         ( -- )
                get-local-time time-buf >date" type ;

: >month,day,year" ( time_structure -- )
                >r 31 date$  z" ddddd',' MMMM dd yyyy"
                r> null LOCALE_USER_DEFAULT
                call GetDateFormat date$ swap 1- ;


: .month,day,year ( -- )
                get-local-time time-buf >month,day,year" type ;

: >time"        ( time_structure -- )
                >r 31 time$ null
                r> null LOCALE_USER_DEFAULT
                call GetTimeFormat time$ swap 1- ;

: .time         ( -- )
                get-local-time time-buf >time" type ;

: >am/pm"       ( time_structure -- )
                >r 31 time$ z" h':'mmtt"
                r> null LOCALE_USER_DEFAULT
                call GetTimeFormat time$ swap 1- ;

: .am/pm        ( -- )
                get-local-time time-buf >am/pm" type ;

: ms@           ( -- ms )
                get-local-time
                time-buf
                dup   8 + w@     60 *           \ hours
                over 10 + w@ +   60 *           \ minutes
                over 12 + w@ + 1000 *           \ seconds
                swap 14 + w@ + ;                \ milli-seconds

0 value start-time

: time-reset    ( -- )
                ms@ to start-time ;

' time-reset alias timer-reset

: .elapsed      ( -- )
                ." Elapsed time: "
                ms@ start-time -
                1000 /mod
                  60 /mod
                  60 /mod 2 .#" type ." :"
                          2 .#" type ." :"
                          2 .#" type ." ."
                          3 .#" type ;

: elapse        ( -<commandline>- )
                time-reset interpret cr .elapsed ;

anew  pardemo.f   \ 10-4-99

create-thread-user: thread-area-cnt1

0e fvalue ft0

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

value-ft0

\ 191700e fto ft0

ft0 fvalue ft1     ft0 f>d drop value t1     t1 value  t2

0 value h_ev_wake_cnt1_integer   0 value h_ev_wake_cnt1_float
0 value h_ev_wake_cnt2_integer   0 value h_ev_wake_cnt2_float
0 value h_ev_wake_cnt3-7_float

0 value h_ev_init_cnt1_integer   0 value h_ev_init_cnt1_float
0 value h_ev_init_cnt2_integer   0 value h_ev_init_cnt2_float
0 value h_ev_init_cnt3-7_float

: cnt1_integer
   thread-area-cnt1 init-thread-user
        begin   h_ev_wake_cnt1_integer event-wait ft0 f>d drop to t1
                h_ev_init_cnt1_integer event-set
                time-reset
                    begin   pause  -1 t1 + to t1  t1 0<  \ int
                    until
                h_ev_wake_cnt1_integer event-reset
        again
 ;

create-thread-user: thread-area-fcnt1

: cnt1_float
   thread-area-cnt1 init-thread-user
        begin   h_ev_wake_cnt1_float event-wait ft0 fto ft1
                h_ev_init_cnt1_float event-set
                time-reset
                  begin   pause -1e ft1 f+ fto ft1   ft1 f0<  \ floats
                  until
        h_ev_wake_cnt1_float event-reset
        again
;

create-thread-user: thread-area-cnt2

: cnt2_integer
   thread-area-cnt2 init-thread-user
        begin   h_ev_wake_cnt2_integer event-wait ft0 f>d drop to t2
                h_ev_init_cnt2_integer event-set
                   begin  pause -1 t2 + to t2  t2 0<
                   until
        h_ev_wake_cnt2_integer event-reset
        again
;

create-thread-user: thread-area-fcnt2       ft0 fvalue ft2
create-thread-user: thread-area-fcnt3       ft0 fvalue ft3
create-thread-user: thread-area-fcnt4       ft0 fvalue ft4
create-thread-user: thread-area-fcnt5       ft0 fvalue ft5
create-thread-user: thread-area-fcnt6       ft0 fvalue ft6
create-thread-user: thread-area-fcnt7       ft0 fvalue ft7

: cnt2_float
   thread-area-fcnt2 init-thread-user
        begin   h_ev_wake_cnt2_float event-wait ft0 fto ft2
                h_ev_init_cnt2_float event-set
                  begin   pause -1e ft2 f+ fto ft2   ft2 f0<  \ floats
                  until
        h_ev_wake_cnt2_float event-reset
        again ;


: cnt3_float
   thread-area-fcnt3 init-thread-user
        begin   h_ev_wake_cnt3-7_float event-wait ft0 fto ft3
                  begin   pause -1e ft3 f+ fto ft3   ft3 f0<  \ floats
                  until
        h_ev_wake_cnt3-7_float event-reset
        again ;

: cnt4_float
   thread-area-fcnt4 init-thread-user
        begin  h_ev_wake_cnt3-7_float event-wait ft0 fto ft4
                  begin   pause -1e ft4 f+ fto ft4   ft4 f0<  \ floats
                  until
        h_ev_wake_cnt3-7_float event-reset
        again ;

: cnt5_float
   thread-area-fcnt5 init-thread-user
        begin  h_ev_wake_cnt3-7_float event-wait ft0 fto ft5
                  begin   pause -1e ft5 f+ fto ft5   ft5 f0<  \ floats
                  until
        h_ev_wake_cnt3-7_float event-reset
        again ;

: cnt6_float
   thread-area-fcnt6 init-thread-user
        begin  h_ev_wake_cnt3-7_float event-wait ft0 fto ft6
                  begin   pause -1e ft6 f+ fto ft6   ft6 f0<  \ floats
                  until
        h_ev_wake_cnt3-7_float event-reset
        again ;

: cnt7_float
   thread-area-fcnt7 init-thread-user
        begin  h_ev_wake_cnt3-7_float event-wait ft0 fto ft7
               h_ev_init_cnt3-7_float event-set
                  begin   pause -1e ft7 f+ fto ft7   ft7 f0<  \ floats
                  until
        h_ev_wake_cnt3-7_float event-reset
        again ;


\ cnt2_integer abort

false value no-mon

: mon-integer
   h_ev_init_cnt1_integer event-wait
   h_ev_init_cnt2_integer event-wait
   no-mon
     if    begin   t1 0< t2 0< and pause     until
     else  begin  9 9 at-xy  space  t1 . space t2 . pause
                  t1 0< t2 0< and
           until
    then .elapsed ;

: mon-float
     h_ev_init_cnt1_float event-wait
     h_ev_init_cnt2_float event-wait
     no-mon
     if    begin   ft1  f0< ft2  f0<  and pause   until
     else  begin   9 9 at-xy  space  ft1 fdup f0< f. space ft2 fdup f0< f.
                   and pause
           until
     then  .elapsed ;

: mon-7float
   h_ev_init_cnt1_float event-wait
   h_ev_init_cnt2_float event-wait
   h_ev_init_cnt3-7_float event-wait
   no-mon
     if  begin
             ft1 f0<   ft2 f0<  ft3 f0<
             ft4 f0<   ft5 f0<  ft6 f0<
             ft7 f0<
            and and and and and and pause
         until
     else
       begin  0 9 at-xy
            space ft1 fdup f0< f.  space ft2 fdup f0< f.  space  ft3 fdup f0< f.
            space ft4 fdup f0< f.  space ft5 fdup f0< f.  space  ft6 fdup f0< f.
            space ft7 fdup f0< f.
            and and and and and and pause
       until
     then .elapsed cr ;

\ events need to be made in runtime for W9x

: init-events ( - )
   z" cnt_ready" make-event-set drop
   z" wake_all"  make-event-set to h_ev_wake_all
   z" wake_cnt1_integer" make-event-reset to h_ev_wake_cnt1_integer
   z" wake_cnt2_integer" make-event-reset to h_ev_wake_cnt2_integer
   z" wake_cnt1_float"   make-event-reset to h_ev_wake_cnt1_float
   z" wake_cnt2_float"   make-event-reset to h_ev_wake_cnt2_float
   z" wake_cnt3-7_float" make-event-reset to h_ev_wake_cnt3-7_float

   z" init_cnt1_integer" make-event-reset to h_ev_init_cnt1_integer
   z" init_cnt2_integer" make-event-reset to h_ev_init_cnt2_integer
   z" init_cnt1_float"   make-event-reset to h_ev_init_cnt1_float
   z" init_cnt2_float"   make-event-reset to h_ev_init_cnt2_float
   z" init_cnt3-7_float" make-event-reset to h_ev_init_cnt3-7_float
 ;

: resume ( - )
  no-mon
    if    cr ."  Moment..."
        else  cr ." Press any key...." key drop cls 9 8 at-xy
    then
    ;

true value init

: pardemo
   init
  if false to init
   init-events                               \ initialize all events one time
   thread-area-cnt1 ['] cnt1_integer start   \ start all threads they are
   thread-area-cnt2 ['] cnt2_integer start   \ event driven.
   thread-area-fcnt1 ['] cnt1_float start
   thread-area-fcnt2 ['] cnt2_float start
   thread-area-fcnt3 ['] cnt3_float start
   thread-area-fcnt4 ['] cnt4_float start
   thread-area-fcnt5 ['] cnt5_float start
   thread-area-fcnt6 ['] cnt6_float start
   thread-area-fcnt7 ['] cnt7_float start
  then
    begin  ." Monitor on [Y/N]?" key upc ascii Y <>
              if    true to no-mon
              else  false to no-mon
              then
   cls 9 7 at-xy

   ." Number to count for each counter is: " ft0 f.
    9 8 at-xy ." Running 1 counter using an integer. Moment... "
    -1 to t2
    h_ev_init_cnt1_integer event-reset   \ for synchronizing mon-integer
    h_ev_init_cnt2_integer event-set
    h_ev_wake_cnt1_integer  event-set    \ (re)starts cnt1_integer
    mon-integer

   resume   ." Running 2 counters using integers "
   h_ev_init_cnt1_integer event-reset
   h_ev_init_cnt2_integer event-reset
   h_ev_wake_cnt1_integer event-set
   h_ev_wake_cnt2_integer event-set  mon-integer

   resume   ." Running 2 counters using floats "
   h_ev_init_cnt1_float event-reset
   h_ev_init_cnt2_float event-reset
   h_ev_wake_cnt1_float event-set
   h_ev_wake_cnt2_float event-set    mon-float

   resume   ." Running 7 counters using floats "
   h_ev_init_cnt1_float event-reset
   h_ev_init_cnt2_float event-reset
   h_ev_init_cnt3-7_float event-reset
   h_ev_wake_cnt1_float event-set
   h_ev_wake_cnt2_float event-set
   h_ev_wake_cnt3-7_float event-set
   mon-7float
   cr cr
   ." Note the elapsed time. Again [Y/N]?" key upc ascii Y <>

   until
  cr ." pardemo restarts"    ;

pardemo
\s

PII/400 results:

Results: old version:
          Number to count for each counter is: 1917.00
 Running 1 counter using an integer. Moment... Elapsed time: 00:00:09.560
 Moment...Running 2 counters using integers Elapsed time: 00:00:09.550
 Moment...Running 2 counters using floats Elapsed time: 00:00:09.560
 Moment...Running 7 counters using floats Elapsed time: 00:00:09.500

Results: new version:

         Number to count for each counter is: 191700.
         Running 1 counter using an integer. Moment... Elapsed time: 00:00:04.500
 Moment...Running 2 counters using integers Elapsed time: 00:00:06.980
 Moment...Running 2 counters using floats Elapsed time: 00:00:08.680
 Moment...Running 7 counters using floats Elapsed time: 00:00:23.670

Note: The version of 7 counters can be improoved.

[Win32forth-cvs] win32forth-stc/src multithr.f,NONE,1.1

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

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18614/win32forth-stc/src

Added Files:
	multithr.f 
Log Message:
gah:Added multithr and multi-task demos

--- NEW FILE: multithr.f ---
\ $Id: multithr.f,v 1.1 2006/09/26 08:44:05 georgeahubert Exp $

\ needs optimize.f

anew -multithr.f  \ 10-4-99 for Win32Forth 4.1
                  \ 19apr03 for Win32Forth 6.07 with kernel v501A gah

\ needs task.f
((
This system uses a simpel way to do parallel arithmetic.
Use events to synchronize several threads.
If an event is not set, the WaitForSingleObject enters an efficient wait state,
consuming very little processor time while waiting till the event is set.

Limitations:
Do not decompile a running thread.
Do not change a deferred execution vector while a thread is using it. ( eg pause)
Do not forget a running thread, leave Win32Forth.
The use of this pack is at your own risk.
This version run needs Win32forth version 4.1
The word pause is changed.
The result in pardemo is more than 100 better then the old one when
you use 2 counters.

Results: old version:
          Number to count for each counter is: 1917.00
 Running 1 counter using an integer. Moment... Elapsed time: 00:00:09.560
 Moment...Running 2 counters using integers Elapsed time: 00:00:09.550
 Moment...Running 2 counters using floats Elapsed time: 00:00:09.560
 Moment...Running 7 counters using floats Elapsed time: 00:00:09.500

Results: The new version when the number to count is 100 times bigger:
          Number to count for each counter is: 191700.
 Running 1 counter using an integer. Moment... Elapsed time: 00:00:04.500
 Moment...Running 2 counters using integers Elapsed time: 00:00:06.980
 Moment...Running 2 counters using floats Elapsed time: 00:00:08.680
 Moment...Running 7 counters using floats Elapsed time: 00:00:23.670

Note: The version of 7 counters can be improved.
))

\ opt[
0 value h_ev_wake_all

: event-set     ( hEvent - )  Call SetEvent   0= abort" Event not set" ;
: event-reset   ( hEvent - )  Call ResetEvent 0= abort" Event not reset" ;


: event-wait    ( hEvent - )            \ wait while event or object is NOT set
   INFINITE  swap  Call WaitForSingleObject drop  ;

\ Events-to-wait-for can wait till ALL or ONE event is set.
\ The handles of the events are in an array of pHandles.

\ if bWaitAll is false events-to-wait-for will wait till one event or object is set
\ if bWaitAll is true  events-to-wait-for will wait till all events or objects are set
\ pHandles is a pointer to an array with events or object handles
\ nCount is the number of handles in the array

: events-to-wait-for  ( bWaitAll pHandles nCount - #waitobject )
   dup MAXIMUM_WAIT_OBJECTS > abort" Too many objects"
   >r INFINITE -rot r> Call WaitForMultipleObjects ;

\ Note: In W98 it does not matter if bWaitAll is true or false

: event-set?    ( hEvent - true/false )    \ set/not_set
   0  swap  Call WaitForSingleObject 0=  ;

: make-event-set       ( z"name" - ) \ In Win32
    false              \ init state      ( seems ignored ? )
    true               \ manuel reset ( seems ignored ? )
    NULL               \ lpSecurityAttrib
    Call CreateEvent   \ handle event, the event seems allways NOT set
    dup event-set ;

: make-event-reset     ( z"name" - ) \ In Win32
    false              \ init state      ( seems ignored ? )
    true               \ manuel reset ( seems ignored ? )
    NULL               \ lpSecurityAttrib
    Call CreateEvent   \ handle event, the event seems allways NOT set
    dup event-reset ;

\ : test     h_ev_wake_all ev_set?     ;

\ If there isn't a pause in your thread then your thread will not run.

: (pause   0 Call Sleep drop ;

\ : (pause 0  false Call SleepEx DROP ;
\ : (pause-wake  h_ev_wake_all event-wait (pause ;


defined pause nip not [IF]    defer pause    [THEN]

\ ' (pause-wake is pause \ activate when you would like to use h_ev_wake_all

' (pause is pause

variable lpThreadID  666 lpThreadID !

(( These definitions are not needed as their functionality is in task.f
or kernel V501A 19apr03 gah

\ cell newuser thread-handle

\ The idea to use a callback came from Eric Colin.

1 Callback: ThreadFunc ( arg -- f )  execute  ( return )  1 ;

: thread-up ( user-area-thread - thread-up )   3 cells+ ;   \ Forth depended.
: offset    ( user - offset-relative-to-up )   >body  @ ;

0 value thr

: start ( user-area-thread tid - )
   lpThreadID                \ ptr to DWORD
   0                         \ 0 or CREATE_SUSPENDED
   rot                       \ arg for ThreadFunc tid
   &ThreadFunc               \ address of ThreadFunc callback
   0                         \ thread's stack size: 0-> default
   0                         \ security attributes: 0 -> default or LP
   call CreateThread         \  ( - thread-handle )
   dup 0= abort" Thread not created."
  swap ['] thread-handle offset thread-up +  ! \ save the thread-handle in its
 ;                                             \ user-area-thread

\ Note: In w9x the created thread gets the same handle as the thread which
\ created the thread. So I decided to use events and WaitForSingleObject to let
\ threads wait.

: init-thread-user  ( user-area-thread - )
   csp @ sp0 !                            \ restore sp0 in the main thread
   thread-up up!                          \ now up points into the new user-area
   sp@ sp0 ! rp@ rp0 !                    \ put rp and sp in it \ handler ??
 ;

: create-thread-user:
   create  here usersize allot            \ allocate an user area
           conuser swap usersize move     \ copy the main user area
   does> ;
 ]opt ))

\ gah 19apr03 for task.f

cell newuser MyBlock

: thread-handle MyBlock @ task>handle ;


: START ( addr xt -- )
        over ! run-task drop ;

: init-thread-user ( addr addr -- )
        MyBlock ! ;

: create-thread-user:
    \in-system-ok  0 0 task-block constant ;

\s

[Win32forth-cvs] win32forth-stc/doc readme.txt,1.2,1.3

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

Update of /cvsroot/win32forth/win32forth-stc/doc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13333/win32forth-stc/doc

Modified Files:
	readme.txt 
Log Message:
gah:Added pde1 benchmark

Index: readme.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** readme.txt	23 Sep 2006 06:00:17 -0000	1.2
--- readme.txt	25 Sep 2006 12:02:24 -0000	1.3
***************
*** 32,33 ****
--- 32,44 ----
  
  see fib
+ 
+ To test the PDE benchmark
+ -------------------------
+ 
+ 1. Run w32f.exe
+ 
+ 2. Type
+ 
+    fload demos\TestPde
+ 
+ ( NB for comparison with the ITC version (or rival STC versions) just fload Pde1 in them; the test harness isn't needed)
\ No newline at end of file

[Win32forth-cvs] win32forth-stc/demos Testpde.f, NONE, 1.1 matrix.f, NONE, 1.1 pde1.f, NONE, 1.1

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

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13333/win32forth-stc/demos

Added Files:
	Testpde.f matrix.f pde1.f 
Log Message:
gah:Added pde1 benchmark

--- NEW FILE: pde1.f ---
\ pde1.f  ( win32forth version)
\
\ Numerical Solution of Electrostatics Boundary-Value Problems.
\ Solve Laplace's Equation in 2 Dimensions:
\
\	D_xx u(x,y) + D_yy u(x,y) = 0
\
\ Copyright (c) 2003 Krishna Myneni, Creative Consulting for Research 
\ and Education
\
\ Provided under the terms of the GNU General Public License.
\
\ This program demonstrates a method of solving one kind of a partial 
\ differential equation (PDE) for a function u(x,y), a function
\ of the two variables x and y. In Laplace's Equation above, 
\ D_xx represents taking the second partial derivative with respect to 
\ x of u(x,y), and D_yy the second partial derivative w.r.t. y. This 
\ equation holds for the electrostatic potential u(x,y) inside
\ a charge-free two dimensional region. If we know the values of
\ u(x,y) along a boundary enclosing the region, Laplace's equation
\ may be solved to obtain the values of u(x,y) at all interior points
\ of the region. 
\
\ In this demonstration, we can setup two different bounding regions:
\
\ 1) a hollow rectangular box with voltages defined on the edges,
\
\ 2) a hollow circular region with the top half boundary at one voltage,
\      and the bottom half boundary at a second voltage.
\
\ Very thin insulators are assumed to be separating the regions which 
\ are at different potentials on the bounding region.
\ 
\ Laplace's equation is solved by an iterative application of the 
\ "mean value theorem for the electrostatic potential" (see 
\ "Classical Electrodynamics", 2nd ed, by J.D. Jackson) to each grid 
\ point inside the boundary until the solution converges. For more 
\ information on solving PDEs and boundary value problems, 
\ see "Partial differential equations for engineers and scientists", 
\ by Stanley J. Farlow, 1982, Dover. The method of solving Laplace's 
\ equation used in this example is known as Liebmann's method.
\
\
\ K. Myneni, 1998-10-23
\
\ Adapted for gforth on 2003-12-15; graphics output removed. KM
\

include matrix.f
: FROUND>S FROUND F>D D>S ;

: fmat_copy ( a1 a2 -- | copy fmatrix a1 into a2)
    over mat_size@ * dfloats cell+ cell+ cmove ;

\ Create a floating pt matrix to hold the grid values

64 constant GRIDSIZE
GRIDSIZE dup fmatrix grid
GRIDSIZE dup fmatrix last_grid	\ copy of last grid values for convergence test

\ Rectangular Region Boundary Values

100e  FCONSTANT  TOP_EDGE	\ Top edge at   100.0 V
0e    FCONSTANT  RIGHT_EDGE	\ Right edge at   0.0 V
0e    FCONSTANT  BOTTOM_EDGE	\ Bottom edge at  0.0 V
50e   FCONSTANT  LEFT_EDGE	\ Left edge at   50.0 V

: inside_rectangle? ( row col -- flag | inside rectangular boundary?)
    dup 1 > swap GRIDSIZE < AND swap
    dup 1 > swap GRIDSIZE < AND AND
;

: set_rectangular_bvs ( -- | setup the rectangular boundary values)
    GRIDSIZE 1+ 1 do  TOP_EDGE    1 i grid fmat! loop
    GRIDSIZE 1+ 1 do  RIGHT_EDGE  i GRIDSIZE grid fmat! loop
    GRIDSIZE 1+ 1 do  BOTTOM_EDGE GRIDSIZE i grid fmat! loop
    GRIDSIZE 1+ 1 do  LEFT_EDGE   i 1 grid fmat! loop
;

: init_rectangular_grid ( -- | set up the starting grid values )
    set_rectangular_bvs
    TOP_EDGE BOTTOM_EDGE RIGHT_EDGE LEFT_EDGE f+ f+ f+ 4e f/
    GRIDSIZE 1+ 1 do
      GRIDSIZE 1+ 1 do
        j i inside_rectangle? IF fdup j i grid fmat! THEN
      loop
    loop fdrop ;

\ Circular Region Boundary Values

100e  FCONSTANT  TOP_HALF	\ Top half of boundary region at 100. V
0e    FCONSTANT  BOTTOM_HALF    \ Bottom half at 0.0 V
GRIDSIZE 2 - 2/ CONSTANT RADIUS  \ Radius of boundary region

: inside_circle? ( row col -- flag | inside circular boundary? )
     GRIDSIZE 2/ - dup * swap 
     GRIDSIZE 2/ - dup * + s>f fsqrt fround>s
     RADIUS < ;
 
: set_circular_bvs ( -- | setup the circular boundary region )
    GRIDSIZE 1+ 1 do
      GRIDSIZE 1+ 1 do
        j i inside_circle? 0= IF
	  j GRIDSIZE 2/ < IF TOP_HALF ELSE BOTTOM_HALF THEN
	  j i grid fmat!
	THEN 
      LOOP
    LOOP ;

: init_circular_grid ( -- | set starting values of the grid)
    set_circular_bvs
    TOP_HALF BOTTOM_HALF f+ 2e f/
    GRIDSIZE 1+ 1 do
      GRIDSIZE 1+ 1 do
        j i inside_circle? IF fdup j i grid fmat! THEN
      loop
    loop fdrop ;
	    
defer inside?

: circ ( -- | use the two semi-circle boundary values )
    grid fmat_zero
    ['] inside_circle? is inside? 
    init_circular_grid ;

: rect ( -- | use rectangular boundary values )
    grid fmat_zero
    ['] inside_rectangle? is inside?
    init_rectangular_grid ;


: nearest@ ( i j -- f1 f2 f3 f4 | fetch the nearest neighbor grid values )
    2>R
    2R@ 1- 1 MAX grid fmat@         \ fetch left nearest neighbor
    2R@ 1+ GRIDSIZE MIN grid fmat@  \ fetch right nearest neighbor
    2R@ SWAP 1- 1 MAX SWAP grid fmat@  \ fetch up nearest neighbor
    2R> SWAP 1+ GRIDSIZE MIN SWAP grid fmat@ \ fetch down nearest neighbor
;	    	  

\ Apply the mean value theorem once to each of the interior grid values:
\   Replace each grid value with the average of the four nearest
\   neighbor values.

: iterate ( -- ) 
	GRIDSIZE 1+ 1 ?do
	  GRIDSIZE 1+ 1 ?do
	    j i inside? IF
	      j i nearest@	\ fetch four nearest neighbors
	      f+ f+ f+ 4e f/	\ take average of the four values
	      j i grid fmat!	\ store at this position
	    THEN
	  loop
	loop
;



fvariable tol	\ tolerance for solution
1e-3 tol f!

: converged? ( -- flag | test for convergence between current and last grid)
    GRIDSIZE 1+ 1 do
      GRIDSIZE 1+ 1 do
        j i inside? IF j i grid fmat@ j i last_grid fmat@ f-
	               fabs tol f@ f> IF FALSE unloop unloop EXIT THEN
		    THEN
      loop
    loop TRUE ;


\ Iterate until the solution converges to the specified tolerance 
\ at all interior points.

: solve ( -- )
	begin
          grid last_grid fmat_copy
	  iterate
	  converged?
	until
;


fvariable temp 

: grid_minmax ( -- fmin fmax | find min and max of grid values )
	1 1 grid fmat@ fdup
	GRIDSIZE 1+ 1 do
	  GRIDSIZE 1+ 1 do
	    j i grid fmat@ fswap fover fmax ( 2>r) temp f! fmin ( 2r>) temp f@
	  loop
	loop
;

: display_grid ( -- | display the grid values as a character map )
	grid_minmax
	fover f- 
	15e fswap f/	\ scale factor to scale grid value from 0 to 15
	fswap

	GRIDSIZE 1+ 1 ?do
	  GRIDSIZE 1+ 1 ?do
	    fover fover
	    j i grid fmat@ fswap f- f*
	    fround>s dup 9 >
	    if 55 + else 48 + then emit
	  loop
	  cr
	loop

	fdrop fdrop
;




rect
CR CR
.( Numerical Solution of Electrostatics Boundary-Value Problems ) CR 
GRIDSIZE dup 3 .r char x emit .    
.( grid has been setup. Type: ) CR CR
.(    rect           to use the rectangular boundary values) CR
.(    circ           to use the circular boundary values) CR
.(    solve          to find the solution) CR
.(    display_grid   to view grid as a character map) CR
CR
    

--- NEW FILE: matrix.f ---
\
\ matrix.f  (Win32Forth version)
\
\ Integer and floating point matrix manipulation routines for Forth
\   systems which use a separate floating point stack and which do NOT
\   have kForth style data typing.
\
\ Copyright (c) 1998--2002 Krishna Myneni
\
\ Revisions:
\
\	12-29-1998
\	3-29-1999   added rc>frc KM
\	12-25-1999  updated  KM
\	05-10-2000  fixed determ for singular matrix  KM
\	05-17-2000  added defining words for matrices  KM
\	08-10-2001  improved efficiency of several matrix words;
\	              about 10% faster execution in real apps  KM
\       12-09-2002  begin port to Forths with separate fp stack;
\		      changed all references to dfloats to floats  KM
\       12-14-2002  finished port to pfe and gforth. cleaned up
\                     determ and matinv by using values and the
\		      loop indexing word K	 KM
\       12-16-2002  fixed fmat_addr when size of float is not 2 cells KM
\
\ Notes:
\
\   Usage:
\	n m matrix name
\	n m fmatrix name
\
\   Examples:
\
\	3 5 matrix alpha 	( create a 3 by 5 integer matrix called alpha )
\	3 3 fmatrix beta	( create a 3 by 3 floating pt matrix, beta )

\ Memory storage format for matrices:
\   The first four bytes contains ncols and the next four bytes contains
\   nrows. The matrix data is stored next in row order.
\
\ Indexing Convention:
\	Top left element is 1, 1
\	Bottom right element is nrows, ncols
\
\ matinv and determ are based on routines from P.R. Bevington,
\   "Data Reduction and Error Analysis for the Physical Sciences".
\
\ The word K is assumed to be defined. It provides the second outer
\   loop index, as an extension of I, J, ...
\
\ Some Forths may require the following defs:
\
\ : s>f s>d d>f ;
: ?allot here swap allot ;
: float- [ 1 floats ] literal - ;

: rc_index ( n -- rc | generate an rc with a running index 1 to n )
	dup 1+ 1 do i swap loop ;

: rc_neg ( rc1 -- rc2 | negate the values in the rc )
	sp@ cell+ over 0 do dup @ negate over ! cell+ loop drop ;

: rc_dup ( rc -- rc rc | duplicate an rc on the stack )
	dup 1+ dup 0 do dup pick swap loop drop ;

: rc_max ( rc -- n | find max value in rc )
	1- dup 0> if 0 do max loop else drop then ;

: rc_min ( rc -- n | find min value in rc )
	1- dup 0> if 0 do min loop else drop then ;

: frc_index ( n -- | generate fp running index )
	    ( F: -- 1e 2e ... ne )
	dup 1+ 1 do i s>f loop ;

: frc_neg ( n -- n | negate the values in the frc )
	  ( F: f1 f2 ... fn -- -f1 -f2 ... -fn )
	dup dup 1- floats floatsp + swap
	0 do dup f@ fnegate dup f! float- loop drop ;

: frc_dup ( n -- n n | duplicate an frc on the stacks )
	  ( F: f1 f2 ... fn -- f1 f2 ... fn f1 f2 ... fn )
	dup dup 1- floats floatsp + swap 0 do dup f@ float- loop drop dup ;

: frc_max ( n --  | find max value in frc )
	  ( F: f1 f2 ... fn -- fmax )
	1- dup 0> if 0 do fmax loop else drop then ;

: frc_min ( n --  | find min value in frc )
	  ( F: f1 f2 ... fn -- fmin )
	1- dup 0> if 0 do fmin loop else drop then ;

: rc>frc ( m1 m2 ... mn n -- n | convert integer rc to frc )
	 ( F: -- f1 f2 ... fn )
	dup 0 do dup i - roll s>f loop ;

: mat_size@ ( a -- nrows ncols | gets the matrix size )
	dup cell+ @ swap @ ;

: mat_size! ( nrows ncols a -- | set up the matrix size )
	dup >r ! r> cell+ ! ;

: mat_addr ( i j a -- a2 | returns address of the i j element of a )
	>r cells swap 1- r@ @ * cells + cell+ r> + ;

: mat@ ( i j a -- n | returns the i j element of a )
	mat_addr @ ;

: mat! ( n i j a -- | store n as the i j element of a )
	mat_addr ! ;

: mat_zero ( a -- | zero all entries in matrix )
	dup mat_size@ * >r 1 1 rot mat_addr r>
	0 do 0 over ! cell+ loop drop ;

: row@ ( i a -- rc | fetch row i onto the stack as an rc )
	dup @ >r 1 swap mat_addr r> dup
	0 do over @ -rot swap cell+ swap loop nip ;

: row! ( rc i a -- | store rc as row i of matrix a )
	dup @ dup >r swap mat_addr r>
	0 do rot over ! 4 - loop 2drop ;

: col@ ( j a -- rc | fetch column j onto the stack as an rc )
	dup mat_size@ cells 2>r 1 -rot mat_addr 2r>
	swap dup >r
	0 do over @ -rot swap over + swap loop 2drop r> ;

: col! ( rc j a -- | store rc as column j of matrix a )
	dup mat_size@ cells >r dup >r -rot mat_addr r> r>
	swap
	0 do >r rot over ! r@ - r> loop 2drop drop ;

: row_swap ( i j a -- | swap rows i and j of matrix a )
	tuck 2dup 2>r 2over 2>r
	2>r row@ 2r> row@
	2r> row! 2r> row! ;

: col_swap ( i j a -- | swap columns i and j of matrix a )
	tuck 2dup 2>r 2over 2>r
	2>r col@ 2r> col@
	2r> col! 2r> col! ;

: mat. ( a -- | print out the matrix )
	dup mat_size@ 1+
	swap 1+ 1 do dup 1 do over j i rot mat@ . 9 emit loop cr loop
	2drop ;

: fmat_addr ( i j a -- a2 | returns address of the i j element of a )
	    ( F: -- )
	>r 1- floats swap 1- r@ @ * floats + r> +
	[ 2 cells ] literal + ;

: fmat@ ( i j a -- | returns the i j element of a ) ( F: -- f )
	fmat_addr f@ ;

: fmat! ( i j a -- | store f as the i j element of a ) ( F: f -- )
	fmat_addr f! ;

: fmat_zero ( a -- | zero all entries in fp matrix ) ( F: -- )
	dup mat_size@ * >r 1 1 rot fmat_addr r>
	0 do dup 0e f! float+ loop drop ;

: frow@ ( i a -- n | fetch row i of fp matrix a as an frc )
	( F: -- f1 f2 ... fn )
	dup @ >r 1 swap fmat_addr r@
	0 do dup f@ float+ loop drop r> ;

: fcol@ ( j a -- n | fetch column j of fp matrix a )
	( F: -- f1 f2 ... fn )
	dup mat_size@ floats 2>r 1 -rot fmat_addr 2r>
	swap dup >r
	0 do over f@ swap over + swap loop 2drop r> ;

: frow! ( n i a -- | store frc as row i of fp matrix a )
	( F: f1 f2 ... fn -- )
	dup @ dup >r swap fmat_addr r>
	0 do dup f! float- loop 2drop ;

: fcol! ( n j a -- | store frc as column j of fp matrix a )
	( F: f1 f2 ... fn -- )
	dup mat_size@ floats >r dup >r -rot fmat_addr r> r>
	swap
	0 do over f! dup >r - r> loop 2drop drop ;

: frow_swap ( i j a -- | interchange rows i and j for fp matrix a )
	tuck 2dup 2>r 2over 2>r
	2>r frow@ 2r> frow@
	2r> frow! 2r> frow! ;

: fcol_swap ( i j a -- | interchange columns i and j for a )
	tuck 2dup 2>r 2over 2>r
	2>r fcol@ 2r> fcol@
	2r> fcol! 2r> fcol! ;

: fmat. ( a -- | print out the fp matrix )
	cr
	dup mat_size@ 1+
	swap 1+
	1 do
	  dup
	  1 do
	    over j i rot fmat@ f. 9 emit
	  loop
	  cr
	loop
	2drop
;

\ Defining words for matrices

: matrix ( nrows ncols -- | allocate space and initialize size )
	create 2dup * cells 2 cells + ?allot mat_size! ;

: fmatrix ( nrows ncols -- | allocate space for fp matrix and initialize size )
	create 2dup * floats 2 cells + ?allot mat_size! ;



0 value norder		\ order of matrix for determ and matinv
0 value arr		\ address of array for determ and matinv
fvariable det

\ Calculate the determinant of a square floating pt matrix
\ Destroys the input matrix

: determ ( a -- | a is the fmatrix address )
	 ( F: -- fdet )
	to arr
	arr mat_size@ to norder drop
	1e det f!

	norder 1+ 1 do
	  i dup arr fmat@
	  f0= if
	    \ Find next element in row which is non-zero
	    i norder < if
	      i dup 1+
	      begin
	        2dup arr fmat@ f0=
	        over norder < and
	      while
	        1+
	      repeat
	      2dup arr fmat@
	      f0= if
	        2drop 0e fdup det f!
	        unloop exit
	      then
	      nip
	      norder 1+ i do
	        i over arr fmat@
	        i j arr fmat@
	        i   over arr fmat!
	        i j arr fmat!
	      loop
	      drop
	      det f@ fnegate det f!
	    else
	      0e fdup det f! unloop exit
	    then
	  then

\ Subtract row k from lower rows to get diagonal matrix

	  i dup dup arr fmat@ det f@ f* det f!

	  norder < if
	    norder 1+ i 1+ do
	      norder 1+ j 1+ do
	        j i arr fmat@
	        j k arr fmat@
	        k i arr fmat@
	        k dup arr fmat@
	        f/ f* f-
	        j i arr fmat!
	      loop
	    loop
	  then
	loop

	det f@
;



fvariable amax
64 1 matrix ik		\ norder can be up to 64
64 1 matrix jk
0 value kk

\ matinv computes the inverse of a symmetric matrix and returns its determinant
\ The input matrix is replaced by its inverse

: matinv ( a  -- )  ( F: -- fdet )
    dup to arr
    @ dup to norder
    dup 1 ik mat_size! 1 jk mat_size!
    1e det f!

    norder 1+ 1 do

\ Find largest element in rest of matrix

      0e amax f!

      begin
        begin
          norder 1+ i do
            norder 1+ j do
	      j i arr fmat@
	      fdup fabs amax f@ fabs
	      f>= if
	        amax f!
	        j k 1 ik mat!
	        i k 1 jk mat!
	      else
                fdrop
	      then
            loop
         loop

\ Interchange rows and columns to put amax on diagonal

         amax f@
	 f0= if 0e fdup det f! exit then

         i 1 ik mat@ i >=
       until

       i 1 ik mat@ i > if
	 i arr frow@ frc_neg
	 i 1 ik mat@ arr frow@
	 i arr frow!
	 i 1 ik mat@ arr frow!
       then

       i 1 jk mat@ i >=
     until

     i 1 jk mat@ i > if
       i arr fcol@ frc_neg
       i 1 jk mat@ arr fcol@
       i arr fcol!
       i 1 jk mat@ arr fcol!
     then

\ Accumulate elements of inverse matrix

     norder 1+ 1 do
       i j <>
       if
         i j arr fmat@ fnegate amax f@ f/
	 i j arr fmat!
       then
     loop

     norder 1+ 1 do
       norder 1+ 1 do
         j k <> if
           i k <> if
             k i arr fmat@
             j k arr fmat@
             f*
             j i arr fmat@ f+
	     j i arr fmat!
           then
         then
       loop
     loop

     norder 1+ 1 do
       i j <> if
         j i arr fmat@ amax f@ f/
         j i arr fmat!
       then
     loop

     1e amax f@ f/ i dup arr fmat!
     det f@ amax f@ f* det f!

   loop

\ Restore ordering of matrix

   norder 0 do
     norder i - to kk
     kk 1 ik mat@
     kk > if
       kk arr fcol@
       kk 1 ik mat@ arr fcol@ frc_neg
       kk arr fcol!
       kk 1 ik mat@ arr fcol!
     then
     kk 1 jk mat@
     kk > if
       kk arr frow@
       kk 1 jk mat@ arr frow@ frc_neg
       kk arr frow!
       kk 1 ik mat@ arr frow!
     then
   loop

   det f@
;














--- NEW FILE: Testpde.f ---

only forth also definitions decimal

\ defined b/float nip 0= [if] 8 constant b/float [then]

\ needs stc/float

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Timing Routines                     \
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

create TIME-BUF
here
        0 w,    \ +0  year
        0 w,    \ +2  month
        0 w,    \ +4  day of week
        0 w,    \ +6  day of month
        0 w,    \ +8  hour
        0 w,    \ +10 minute
        0 w,    \ +12 second
        0 w,    \ +14 milliseconds
here swap - constant TIME-LEN

create date$ 32 allot
create time$ 32 allot

: get-local-time ( -- )                 \ get the local computer date and time
        time-buf call GetLocalTime drop ;

: time&date     ( -- sec min hour day month year )
                get-local-time
                time-buf 12 + w@        \ seconds
                time-buf 10 + w@        \ minutes
                time-buf  8 + w@        \ hours
                time-buf  6 + w@        \ day of month
                time-buf  2 + w@        \ month of year
                time-buf      w@ ;      \ year

: .#"           ( n1 n2 -- a1 n3 )
                >r 0 <# r> 0 ?do # loop #> ;

: >date"        ( time_structure -- )
                >r 31 date$ null \ z" ddddd',' MMMM dd yyyy"
                r> null LOCALE_USER_DEFAULT
                call GetDateFormat date$ swap 1- ;

: .date         ( -- )
                get-local-time time-buf >date" type ;

: >month,day,year" ( time_structure -- )
                >r 31 date$  z" ddddd',' MMMM dd yyyy"
                r> null LOCALE_USER_DEFAULT
                call GetDateFormat date$ swap 1- ;


: .month,day,year ( -- )
                get-local-time time-buf >month,day,year" type ;

: >time"        ( time_structure -- )
                >r 31 time$ null
                r> null LOCALE_USER_DEFAULT
                call GetTimeFormat time$ swap 1- ;

: .time         ( -- )
                get-local-time time-buf >time" type ;

: >am/pm"       ( time_structure -- )
                >r 31 time$ z" h':'mmtt"
                r> null LOCALE_USER_DEFAULT
                call GetTimeFormat time$ swap 1- ;

: .am/pm        ( -- )
                get-local-time time-buf >am/pm" type ;

: ms@           ( -- ms )
                get-local-time
                time-buf
                dup   8 + w@     60 *           \ hours
                over 10 + w@ +   60 *           \ minutes
                over 12 + w@ + 1000 *           \ seconds
                swap 14 + w@ + ;                \ milli-seconds

0 value start-time

: time-reset    ( -- )
                ms@ to start-time ;

' time-reset alias timer-reset

: .elapsed      ( -- )
                ." Elapsed time: "
                ms@ start-time -
                1000 /mod
                  60 /mod
                  60 /mod 2 .#" type ." :"
                          2 .#" type ." :"
                          2 .#" type ." ."
                          3 .#" type ;

: elapse        ( -<commandline>- )
                time-reset interpret cr .elapsed ;

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Other utilities                                \
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
\  Rotate k values on the stack, bringing the deepest to the top.
                DUP>R PICK SP@ DUP CELL+ R> CELLS CELL+ MOVE DROP ;

code k          ( -- n )
                mov     -4 [ebp], eax
                mov     eax, 20 [esp]
                add     eax, 24 [esp]
                lea     ebp, -4 [ebp]
                next ;c

\ Need to set directory until fload etc work with paths.
s" demos" Prepend<home>\ "chdir

fload pde1

[Win32forth-cvs] win32forth-stc/src ANSFILE.F, 1.1, 1.2 primutil.f, 1.4, 1.5 task.f, 1.1, 1.2

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

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv11338/win32forth-stc/src

Modified Files:
	ANSFILE.F primutil.f task.f 
Log Message:
gah:Added to primutils words for multi-tasker and got task working.Newest version of Ansfile.

Index: task.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/task.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** task.f	21 Sep 2006 16:26:33 -0000	1.1
--- task.f	25 Sep 2006 11:57:53 -0000	1.2
***************
*** 19,27 ****
  \ -------------------- Task Start Initialisation --------------------
  
! 1 proc ExitThread \ as exit-task     ( n -- )     \ exit the thread
  
  : (task)        ( parm cfa -- )                 \ helper routine
                  catch                           \ execute cfa and catch errors gah 27nov03
!                 call ExitThread                       \ and exit the thread, never returns
                  ;
  
--- 19,27 ----
  \ -------------------- Task Start Initialisation --------------------
  
! 1 proc ExitThread  as exit-task     ( n -- )     \ exit the thread
  
  : (task)        ( parm cfa -- )                 \ helper routine
                  catch                           \ execute cfa and catch errors gah 27nov03
!                 Exit-Task                       \ and exit the thread, never returns
                  ;
  
***************
*** 32,43 ****
                  push    esi
                  mov     ebp, esp
                  call    ' task-entry            \ setup stacks, error-handler etc (in kernel)
!                 mov     ecx, 5 cells [ebp]      \ get task block
                  mov     TCB [UP] , ecx          \ save in TCB
!                 mov     ebx, 4 [ecx]            \ parameter
!                 mov     -4 [ebp], ebx           \ save it
                  lea     ebp, -4 [ebp]
                  mov     eax, 0 [ecx]            \ cfa = tos
!                 jmp     [dword] ' (task)        \ get helper entry point
                  next    c;
  
--- 32,44 ----
                  push    esi
                  mov     ebp, esp
+                 mov     esi, esp
                  call    ' task-entry            \ setup stacks, error-handler etc (in kernel)
!                 mov     ecx, 5 cells [esi]      \ get task block
                  mov     TCB [UP] , ecx          \ save in TCB
!                 mov     edx, 4 [ecx]            \ parameter
!                 mov     -4 [ebp], edx           \ save it
                  lea     ebp, -4 [ebp]
                  mov     eax, 0 [ecx]            \ cfa = tos
!                 jmp     ' (task)                \ get helper entry point
                  next    c;
  
***************
*** 51,55 ****
                  swap ( CREATE_SUSPENDED | 0  )  \ run it later? from state on stack
                  r@                              \ parameter (ptr to cfa/parm pair)
!                 begin-task                      \ task entry code
                  0 0                             \ stack, thread attributes
                  call CreateThread dup
--- 52,56 ----
                  swap ( CREATE_SUSPENDED | 0  )  \ run it later? from state on stack
                  r@                              \ parameter (ptr to cfa/parm pair)
!                 ['] begin-task                      \ task entry code
                  0 0                             \ stack, thread attributes
                  call CreateThread dup
***************
*** 175,178 ****
--- 176,183 ----
  \ forgotten to avoid CRASHING !! YOU HAVE BEEN WARNED
  
+ module
+ 
+ \s
+ 
  in-system
  \s

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** primutil.f	24 Sep 2006 08:42:06 -0000	1.4
--- primutil.f	25 Sep 2006 11:57:53 -0000	1.5
***************
*** 201,208 ****
  
  
! \ 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)
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 201,205 ----
  
  
! \ needed by ansfile.
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 250,251 ****
--- 247,284 ----
                  st1 count st2 count compare ;
  
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \       Locking for Windows
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ 
+ defer (controllock)
+ defer (controlunlock)
+ defer (dialoglock)
+ defer (dialogunlock)
+ defer (classnamelock)
+ defer (classnameunlock)
+ defer (pointerlock)
+ defer (pointerunlock)
+ defer (dynlock)
+ defer (dynunlock)
+ 
+ : init-system-locks-off ( -- )
+ \ *G Set all the system deferred words for locking to noops. This is done automatically
+ \ ** by the system at start-up so code that uses it will work correctly before the locks
+ \ ** are initialised.
+      ['] noop is (controllock)
+      ['] noop is (controlunlock)
+      ['] noop is (dialoglock)
+      ['] noop is (dialogunlock)
+      ['] noop is (classnamelock)
+      ['] noop is (classnameunlock)
+      ['] noop is (pointerlock)
+      ['] noop is (pointerunlock)
+      ['] noop is (dynlock)
+      ['] noop is (dynunlock)
+ ;
+ 
+ init-system-locks-off
+ 
+ initialization-chain chain-add init-system-locks-off
+ 
+ \s

Index: ANSFILE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/ANSFILE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ANSFILE.F	24 Sep 2006 08:42:06 -0000	1.1
--- ANSFILE.F	25 Sep 2006 11:57:52 -0000	1.2
***************
*** 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,307 ****
  \ *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 ;
--- 306,319 ----
  \ *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
  \ *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 ;
***************
*** 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

[Win32forth-cvs] win32forth/src paths.f,1.25,1.26

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

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6187/win32forth/src

Modified Files:
	paths.f 
Log Message:
gah:Minor spelling corrections.

Index: paths.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/paths.f,v
retrieving revision 1.25
retrieving revision 1.26
diff -C2 -d -r1.25 -r1.26
*** paths.f	26 Aug 2006 15:25:32 -0000	1.25
--- paths.f	25 Sep 2006 11:44:34 -0000	1.26
***************
*** 53,57 ****
                  cr ." Current directory: " current-dir$ count type ;
  
! : chdir         ( -<optional_new_directory>- )
  \ *G Set the current directory.
                  /parse-word count "chdir cr .dir ;
--- 53,57 ----
                  cr ." Current directory: " current-dir$ count type ;
  
! : chdir         ( -<optional_new_directory>- -- )
  \ *G Set the current directory.
                  /parse-word count "chdir cr .dir ;
***************
*** 60,69 ****
  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 +
--- 60,69 ----
  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 null. \n
! \ ** At runtime it returns address of the counted string of a path
          create  -1 , 0 , MAX-PATH 1+ allot  does>   \ run-time: ( - path )
          [ 2 cells ] literal +
***************
*** 78,84 ****
     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- ;
  
--- 78,84 ----
     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 address.
          2 cells- ;
  
***************
*** 156,161 ****
  INTERNAL
  
! : volume-indication? ( adr - flag )
! \ *G True when the counted string at adr starts with x: or \\name
      dup 2 + c@ ascii : <>
          if      count drop 2 s" \\" compare 0=
--- 156,161 ----
  INTERNAL
  
! : volume-indication? ( addr -- flag )
! \ *G True when the counted string at addr starts with x: or \\name
      dup 2 + c@ ascii : <>
          if      count drop 2 s" \\" compare 0=
***************
*** 358,373 ****
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! : "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    ;
  
--- 358,376 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! : "file-clip"   { addr len limit | temp$ pre -- addr len2 }
! \ *G 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.
                  new$ to temp$                           \ so string isn't de-allocated on exit
!                 limit 20 max to limit                   \ must be at least 16
                  limit 20 - 2 / 6 + to pre               \ balance start and end
                  len limit >
!                 if      addr pre 3 -    temp$  place    \ lay in first 5 chars
                          s" ..."         temp$ +place    \ append some dots
!                         addr len dup limit pre - - 0MAX /string \ clip to last part
                                          temp$ +place    \ of name and lay in
                                          temp$  count
!                 else    addr len                         \ no need to clip file
                  then    ;