win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth-stc/src float.f, 1.3, 1.4 primutil.f, 1.16, 1.17

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

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

Modified Files:
	float.f primutil.f 
Log Message:
gah:Added ASCIIZ to priimutil.f plus minor optimisations

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** primutil.f	31 Oct 2006 11:33:31 -0000	1.16
--- primutil.f	4 Nov 2006 11:19:10 -0000	1.17
***************
*** 40,49 ****
  \ ------------------------------------------------------------------------
  
! in-application
  
  0 value DPR-WARNING?            \ null value      *** to be done ***
  
- in-system
- 
  \ : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
--- 40,47 ----
  \ ------------------------------------------------------------------------
  
! in-system
  
  0 value DPR-WARNING?            \ null value      *** to be done ***
  
  \ : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
***************
*** 61,66 ****
  \ ------------------------------------------------------------------------
  
- in-system
- 
  : _commeof      \ ( flag -- )
                  abort" EOF encountered in comment" ;
--- 59,62 ----
***************
*** 102,105 ****
--- 98,103 ----
  \ ------------------------------------------------------------------------
  
+ in-previous
+ 
  : 2constant     ( n m "name" )
                  >system create , , dp>
***************
*** 113,121 ****
  ' maxbuffer alias max-path
  
  defer enter-assembler ' noop is enter-assembler
  defer exit-assembler  ' noop is exit-assembler
  
- in-application
- 
  : (comp-offs)   ( xt -- )
                  0 swap execute postpone literal postpone + ;
--- 111,119 ----
  ' maxbuffer alias max-path
  
+ in-system
+ 
  defer enter-assembler ' noop is enter-assembler
  defer exit-assembler  ' noop is exit-assembler
  
  : (comp-offs)   ( xt -- )
                  0 swap execute postpone literal postpone + ;
***************
*** 129,135 ****
                  over offset + ;
  
! : ascii    char          state @ if postpone literal then ; immediate
! : alt      char 4096  or state @ if postpone literal then ; immediate
! : ctrl     char   31 and state @ if postpone literal then ; immediate
  
  \ ------------------------------------------------------------------------
--- 127,144 ----
                  over offset + ;
  
! : ascii    char          compilation> execute postpone literal ;
! : alt      char 4096  or compilation> execute postpone literal ;
! : ctrl     char   31 and compilation> execute postpone literal ;
! 
! in-previous
! 
! \ Moved to user area to make asciiz thread safe gah 28jun04
! MAXSTRING newuser z-buf
! \ *G Per-task buffer for holding the string for asciiz.
! 
! : asciiz        ( addr len -- z-buf )
! \ *G Place string addr len in buffer z-buf and null terminate it. Note only one string
! \ ** per task can used at a time.
!                 z-buf ascii-z ;
  
  \ ------------------------------------------------------------------------
***************
*** 151,155 ****
  \ new-sys-chain    post-forget-chain  \ chain of types of things to forget
  
! in-application
  
  :noname         ( -- )         \ chain for cleanup
--- 160,164 ----
  \ new-sys-chain    post-forget-chain  \ chain of types of things to forget
  
! in-previous
  
  :noname         ( -- )         \ chain for cleanup

Index: float.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/float.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** float.f	31 Oct 2006 00:06:31 -0000	1.3
--- float.f	4 Nov 2006 11:19:10 -0000	1.4
***************
*** 44,48 ****
                  0 [tos] endm
  
! in-application
  
  code >fregs     ( addr -- ) \ Restore x87 FPU State
--- 44,48 ----
                  0 [tos] endm
  
! in-previous
  
  code >fregs     ( addr -- ) \ Restore x87 FPU State
***************
*** 121,125 ****
                  FLOATSTACK + [ecx] [up] endm
  
! in-application
  
  -45 Constant THROW_FLOATSTACKUNDER
--- 121,125 ----
                  FLOATSTACK + [ecx] [up] endm
  
! in-previous
  
  -45 Constant THROW_FLOATSTACKUNDER
***************
*** 237,248 ****
  
  \ macro to end float words
! macro: float;
                  fsp-adjust if
                  add     ecx,  # fsp-adjust
                  mov     FSP_MEMORY , ecx
                  0 to fsp-adjust then
!                 false to fsp-cached? next ;c endm
  
! in-application
  
  \ Subroutine to check the depth of the float stack for underflow errors.
--- 237,252 ----
  
  \ macro to end float words
! 
! macro: ?uncash-fsp
                  fsp-adjust if
                  add     ecx,  # fsp-adjust
                  mov     FSP_MEMORY , ecx
                  0 to fsp-adjust then
!                 false to fsp-cached? endm
  
! macro: float;
!                  ?uncash-fsp next ;c endm
! 
! in-previous
  
  \ Subroutine to check the depth of the float stack for underflow errors.
***************
*** 280,284 ****
                  endm
  
! in-application
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 284,288 ----
                  endm
  
! in-previous
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 371,375 ****
                  float;
  ))              does> f@ ;
! in-application
  
  code _fto       ( FS: n -  )  ( 'fvalue  - )
--- 375,379 ----
                  float;
  ))              does> f@ ;
! in-previous
  
  code _fto       ( FS: n -  )  ( 'fvalue  - )
***************
*** 392,396 ****
                  then    ; IMMEDIATE
  
! in-application
  
  : FCONSTANT     ( -<name>- ) ( F: r -- )        \ compile time
--- 396,400 ----
                  then    ; IMMEDIATE
  
! in-previous
  
  : FCONSTANT     ( -<name>- ) ( F: r -- )        \ compile time
***************
*** 653,657 ****
                  ; immediate
  
! in-application
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 657,661 ----
                  ; immediate
  
! in-previous
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 696,700 ****
                  endm
  
! in-application
  
  external
--- 700,704 ----
                  endm
  
! in-previous
  
  external
***************
*** 806,810 ****
                  endm
  
! in-application
  
  code fcomppx    ( -- flags )   ( fs: r1 r2 -- )
--- 810,814 ----
                  endm
  
! in-previous
  
  code fcomppx    ( -- flags )   ( fs: r1 r2 -- )
***************
*** 1276,1280 ****
  internal
  
! in-application
  ((
  \ pointer to a float primitives
--- 1280,1284 ----
  internal
  
! in-previous
  ((
  \ pointer to a float primitives
***************
*** 1348,1352 ****
                  ' ?#float  2 cells+ cfa-comp, ; immediate
  
! in-application
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 1352,1356 ----
                  ' ?#float  2 cells+ cfa-comp, ; immediate
  
! in-previous
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 1740,1744 ****
          IF  postpone fliteral  THEN ;   immediate
  
! in-application
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 1744,1748 ----
          IF  postpone fliteral  THEN ;   immediate
  
! in-previous
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 2079,2083 ****
  defer .float    ' see.float is .float
  
! in-application
  
  \ changed arm 25/04/2005 23:09:50 to use new number chain technique (see numconv.f)
--- 2083,2087 ----
  defer .float    ' see.float is .float
  
! in-previous
  
  \ changed arm 25/04/2005 23:09:50 to use new number chain technique (see numconv.f)

[Win32forth-cvs] win32forth-stc/src/lib BROWSEFLD.F,NONE,1.1

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

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

Added Files:
	BROWSEFLD.F 
Log Message:
gah:Added browsefld.f

--- NEW FILE: BROWSEFLD.F ---
\ $Id: BROWSEFLD.F,v 1.1 2006/11/01 14:08:24 georgeahubert Exp $

\    File: browsefld.f
\  Author: Jos v.d. Ven, Dirk Busch
\ Created: ??? - jos
\ Updated: Sonntag, Mai 16 2004 - 12:58 - dbu
\
\ SHBrowseForFolder() support for Win32Forth

cr .( Loading SHBrowseForFolder support)

anew -browsefld.f

INTERNAL

0 value hwndOwner
0 value pidlRoot
0 value pszDisplayName
0 value lpszTitle
0 value ulFlags
0 value lpfn
0 value lParam
0 value iImage

create BROWSEINFO
here 0 , to hwndOwner
here 0 , to pidlRoot
here 0 , to pszDisplayName
here 0 , to lpszTitle
here 0 , to ulFlags
here 0 , to lpfn
here 0 , to lParam
here 0 , to iImage


\ Browsing for directory.
  0x0001 constant BIF_RETURNONLYFSDIRS    \ For finding a folder to start document searching
\ 0x0002 constant BIF_DONTGOBELOWDOMAIN   \ For starting the Find Computer
\ 0x0004 constant BIF_STATUSTEXT          \ Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if
                                          \ this flag is set.  Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the
                                          \ rest of the text.  This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets
                                          \ all three lines of text.
\ 0x0008 constant BIF_RETURNFSANCESTORS   \ ???
  0x0010 constant BIF_EDITBOX             \ Add an editbox to the dialog
  0x0020 constant BIF_VALIDATE            \ insist on valid result (or CANCEL)
  0x0040 constant BIF_NEWDIALOGSTYLE      \ Use the new dialog layout with the ability to resize
                                          \ Caller needs to call OleInitialize() before using this API
\ 0x0080 constant BIF_BROWSEINCLUDEURLS   \ Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)
\ 0x0100 constant BIF_UAHINT              \ Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX
\ 0x0200 constant BIF_NONEWFOLDERBUTTON   \ Do not add the "New Folder" button to the dialog.  Only applicable with BIF_NEWDIALOGSTYLE.
\ 0x0400 constant BIF_NOTRANSLATETARGETS  \ don't traverse target as shortcut
\ 0x1000 constant BIF_BROWSEFORCOMPUTER   \ Browsing for Computers.
\ 0x2000 constant BIF_BROWSEFORPRINTER    \ Browsing for Printers
\ 0x4000 constant BIF_BROWSEINCLUDEFILES  \ Browsing for Everything
\ 0x8000 constant BIF_SHAREABLE           \ sharable resources displayed (remote shares, requires BIF_USENEWUI)
\ BIF_NEWDIALOGSTYLE BIF_EDITBOX or constant BIF_USENEWUI

\ message from browser
  1 constant BFFM_INITIALIZED
\ 2 constant BFFM_SELCHANGED
\ 3 constant BFFM_VALIDATEFAILEDA \ lParam:szPath ret:1(cont),0(EndDialog)
\ 4 constant BFFM_VALIDATEFAILEDW \ lParam:wzPath ret:1(cont),0(EndDialog)
\ 5 constant BFFM_IUNKNOWN        \ provides IUnknown to client. lParam: IUnknown*

\ messages to browser
\ WM_USER 100 + constant BFFM_SETSTATUSTEXTA
\ WM_USER 101 + constant BFFM_ENABLEOK
  WM_USER 102 + constant BFFM_SETSELECTIONA
\ WM_USER 103 + constant BFFM_SETSELECTIONW
\ WM_USER 104 + constant BFFM_SETSTATUSTEXTW
\ WM_USER 105 + constant BFFM_SETOKTEXT
\ WM_USER 106 + constant BFFM_SETEXPANDED

Library OLE32.dll
1 PROC OleInitialize
1 PROC CoTaskMemFree
1 PROC SHBrowseForFolder
2 PROC SHGetPathFromIDList
1 PROC PathIsDirectory
4 PROC SendMessage

\ callback for SHBrowseForFolder() to set the startup-folder in the dialog
4 callback: BrowseCallbackProc    { hwnd msg wParam lParam -- flag }
        msg BFFM_INITIALIZED =
        if   pszDisplayName @
             true BFFM_SETSELECTIONA hwnd call SendMessage drop
        then 0 ;

\ 4 callback &BrowseCallbackProc  BrowseCallbackProc

EXTERNAL

Library Shell32.dll
1 proc SHBrowseForFolder
2 proc SHGetPathFromIDList

: BrowseForFolder       ( lpszTitle pszFolder hwndOwner -- flag )

        hwndOwner !
        swap lpszTitle !

        \ if we have a valid Folder, than we need a callback for
        \ SHBrowseForFolder() to set the startup-folder in the dialog
        dup +null 1+ dup call PathIsDirectory
        if ['] BrowseCallbackProc else 0 then lpfn !

        dup dup pszDisplayName !

        BIF_RETURNONLYFSDIRS BIF_EDITBOX or BIF_VALIDATE or ( BIF_NEWDIALOGSTYLE or ) ulFlags !

        0 pidlRoot !
        0 lParam !

        \ OleInitialize() must be called if BIF_NEWDIALOGSTYLE flag is set
\       ulFlags @ BIF_NEWDIALOGSTYLE and
\       if 0 call OleInitialize drop then

        BROWSEINFO call SHBrowseForFolder dup>r
        call SHGetPathFromIDList
        if   zcount swap 1- c! true
        else drop false
        then r> Call CoTaskMemFree drop ; \ release memory

MODULE

\s test code

create test ," c:\temp\win32forth" MAX-PATH allot

: test-it ( -- )
        z" Choose a folder" test CONHNDL BrowseForFolder
        cr if test count type else ." aborted" then ;

test-it

[Win32forth-cvs] win32forth/src/lib Win32Help.f,1.2,1.3

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

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

Modified Files:
	Win32Help.f 
Log Message:
gah:Added declaration of proc to match STC version.

Index: Win32Help.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/Win32Help.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Win32Help.f	29 Aug 2005 15:56:28 -0000	1.2
--- Win32Help.f	31 Oct 2006 11:49:32 -0000	1.3
***************
*** 12,15 ****
--- 12,17 ----
  external
  
+ 4 proc WinHelp
+ 
  create help_file$ ," doc\hlp\win32.hlp" MAXSTRING allot-to
  

[Win32forth-cvs] win32forth-stc/src/lib MAPFILE.F,1.1,1.2

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

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

Modified Files:
	MAPFILE.F 
Log Message:
gah:Made MAP-FILE+ a synonym of FIELD+ and removed redundant DOES> from MAP-FILE to optimise performance and code size.

Index: MAPFILE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/lib/MAPFILE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** MAPFILE.F	29 Oct 2006 08:31:56 -0000	1.1
--- MAPFILE.F	31 Oct 2006 11:44:30 -0000	1.2
***************
*** 7,12 ****
  IN-APPLICATION
  
  : map-handle    ( -<name>- )
! \ *G Define a data structure to hold a mapped file
                  create
                       -1 ,                 \ hfile
--- 7,14 ----
  IN-APPLICATION
  
+ in-system \ Without the empty does part map-handle can go in the system space.
+ 
  : map-handle    ( -<name>- )
! \ *G Define a data structure to hold a mapped file.
                  create
                       -1 ,                 \ hfile
***************
*** 16,26 ****
                        0 ,                 \ hfileMaxLength
                        0 c, max-path allot \ hfileName
!                 does> ;
  
  
! : map-field+    ( n1 n2 -<name>- n3 )
!                 ( a1 -- a2 )
!                 CREATE over + swap ,            nostack1
!                 DOES>  @ + ;
  
  0   cell map-field+ >hfile
--- 18,27 ----
                        0 ,                 \ hfileMaxLength
                        0 c, max-path allot \ hfileName
!                       ;
  
  
! synonym map-field+ field+   ( compilation; n1 n2 -<name>- n3 execution; a1 -- a2 )
! 
! in-previous
  
  0   cell map-field+ >hfile

[Win32forth-cvs] win32forth-stc/src primutil.f,1.15,1.16

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

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

Modified Files:
	primutil.f 
Log Message:
gah:Added ALLOT-TO to primutil and Win32Help.f to lib

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** primutil.f	30 Oct 2006 09:15:14 -0000	1.15
--- primutil.f	31 Oct 2006 11:33:31 -0000	1.16
***************
*** 277,284 ****
  \ needed by array.f
  
! : reserve     ( n1 )
! \ *G Allot some bytes initialized to NULL.
                  0max here over allot swap erase ;
  
  \ ------------------------------------------------------------------------
  \       Some case insensitive version of search and compare
--- 277,289 ----
  \ needed by array.f
  
! : reserve       ( n -- )
! \ *G Allot n bytes initialized to NULL.
                  0max here over allot swap erase ;
  
+ : allot-to      ( n -- )
+ \ *G Extend the dictionary space of most recent word compiled to length n.
+                 last @ name>xt  >body here swap - - dup 0<
+                 abort" buffer is already too long!" allot ;
+ 
  \ ------------------------------------------------------------------------
  \       Some case insensitive version of search and compare
***************
*** 344,348 ****
  : 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)
--- 349,353 ----
  : 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 them will work correctly before the locks
  \ ** are initialised.
       ['] noop is (controllock)

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

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

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

Added Files:
	Win32Help.f 
Log Message:
gah:Added ALLOT-TO to primutil and Win32Help.f to lib

--- NEW FILE: Win32Help.f ---
\ $Id: Win32Help.f,v 1.1 2006/10/31 11:33:33 georgeahubert Exp $

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  Win32  Help system interface words
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

cr .( Loading Win32 Help system interface... )

anew -Win32Help.f

internal
external

4 proc WinHelp

create help_file$ ," doc\hlp\win32.hlp" MAXSTRING allot-to

: $help-file    ( a1 -- )                \ set the name of the current help file
                help_file$ 256 erase     \ pre-clear help filename
                count help_file$ place ; \ lay in new filename

: .help         ( -- )                  \ display the current help file string
                cr ." HELP file: " help_file$ count type
                cr ." Use: 'HELP-FILE <filename>' to select another help file. " ;

: help-file     ( -<filename>- )        \ specify a new help filename
                /parse-s$ $help-file ;

synonym set-help help-file

: $help         ( a1 -- )               \ help on a string
                1+                      \ help subject word
                HELP_PARTIALKEY         \ the command to the help system
                                        \ pointer to a help file string
                help_file$ 1+           \ the help file to use
                conHndl                 \ tell help its from our window
                call WinHelp drop ;

: #help         ( n1 -- )               \ help on a help context index number
                HELP_CONTEXT            \ the command to the help system
                help_file$ 1+           \ the help file to use
                conHndl                 \ tell help its from our window
                call WinHelp drop ;

: help          ( -<word>- )
                bl word $help ;         \ help subject word

: help-index    ( -- )
                0
                HELP_INDEX
                help_file$ 1+           \ the help file to use
                conHndl                 \ tell help its from our window
                call WinHelp drop ;

: help-on-help  ( -- )                  \ get help on windows help
                0
                HELP_HELPONHELP
                help_file$ 1+           \ the help file to use
                conHndl                 \ tell help its from our window
                call WinHelp drop ;

INTERNAL

: _help-release ( -- )                  \ release our marker to help system
                0                       \ NULL
                HELP_QUIT               \ the command to the help system
                0                       \ NULL pointer to a help file string
                conHndl
                call WinHelp drop ;

UNLOAD-CHAIN CHAIN-ADD-BEFORE _HELP-RELEASE       \ add to termination chain

EXTERNAL

MODULE

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.22, 1.23 gmeta-compiler.f, 1.8, 1.9 gversion.f, 1.2, 1.3

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

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

Modified Files:
	gkernel.f gmeta-compiler.f gversion.f 
Log Message:
arm: various updates; start of type system, improve optimisation, minor correction
 to float

Index: gmeta-compiler.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** gmeta-compiler.f	24 Oct 2006 12:41:54 -0000	1.8
--- gmeta-compiler.f	31 Oct 2006 00:06:53 -0000	1.9
***************
*** 495,505 ****
  \ -------------------------------------------------------
  
!  26 offset  link>name ( lfa -- nfa )
! -18 offset  name>ct    ( nfa -- ct )
!  18 offset  ct>name    ( ct -- nfa )
! -14 offset  name>xtptr ( nfa -- cfa-ptr )
! -10 offset  name>ffa   ( nfa -- ffa )
! -4  offset  n>ste      ( nfa -- ste )
! -2  offset  n>ofa      ( nfa -- ofa )
  
  variable ct-link ct-link off          \ list of cts
--- 495,509 ----
  \ -------------------------------------------------------
  
!  28 offset  link>name ( lfa -- nfa )
! -28 offset  name>link ( nfa -- lfa )
! -20 offset  name>ct   ( nfa -- ct )
!  20 offset  ct>name   ( ct -- nfa )
! -16 offset  name>xtptr ( nfa -- xt-ptr )
! 
! -2  offset  n>tfa    ( nfa -- tfa )
! -4  offset  n>ofa    ( nfa -- ofa )
! -6  offset  n>ste    ( nfa -- ste )
! -8  offset  n>vfa    ( nfa -- vfa )
! -12 offset  n>ffa    ( nfa -- ffa )
  
  variable ct-link ct-link off          \ list of cts
***************
*** 527,530 ****
--- 531,536 ----
                  -1 tsys-c, -1 tsys-c,                      \ ste
                  0 tsys-w,                                  \ ofa
+                 0 tsys-c,                                  \ typeflag
+                 0 tsys-c,                                  \ flag
                  tsys-here last-h !                         \ remember nfa
                  dup tsys-c, tsys-s, 0 tsys-c,              \ count byte nfa  name string
***************
*** 556,560 ****
          dup cell-                     \ comp field
          xt-xt-call, swap tsys-!     \ point at xt-call,
!         ct>name name>ffa xt-fptr swap tsys-!  \ update the ffa
          ;
          
--- 562,566 ----
          dup cell-                     \ comp field
          xt-xt-call, swap tsys-!     \ point at xt-call,
!         ct>name n>ffa xt-fptr swap tsys-!  \ update the ffa
          ;
          

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.22
retrieving revision 1.23
diff -C2 -d -r1.22 -r1.23
*** gkernel.f	28 Oct 2006 09:07:08 -0000	1.22
--- gkernel.f	31 Oct 2006 00:06:53 -0000	1.23
***************
*** 2293,2306 ****
  
  
!  26 offset  link>name ( lfa -- nfa )
! -26 offset  name>link ( nfa -- lfa )
! -18 offset  name>ct   ( nfa -- ct )
!  18 offset  ct>name   ( ct -- nfa )
! -14 offset  name>xtptr ( nfa -- xt-ptr )
  
! -2  offset  n>ofa    ( nfa -- ofa )
! -4  offset  n>ste    ( nfa -- ste )
! -6  offset  n>vfa    ( nfa -- vfa )
! -10 offset  n>ffa    ( nfa -- ffa )
  
  : name>xt   ( nfa -- xt ) name>xtptr @ ;    \ get the xt
--- 2293,2307 ----
  
  
!  28 offset  link>name ( lfa -- nfa )
! -28 offset  name>link ( nfa -- lfa )
! -20 offset  name>ct   ( nfa -- ct )
!  20 offset  ct>name   ( ct -- nfa )
! -16 offset  name>xtptr ( nfa -- xt-ptr )
  
! -2  offset  n>tfa    ( nfa -- tfa )
! -4  offset  n>ofa    ( nfa -- ofa )
! -6  offset  n>ste    ( nfa -- ste )
! -8  offset  n>vfa    ( nfa -- vfa )
! -12 offset  n>ffa    ( nfa -- ffa )
  
  : name>xt   ( nfa -- xt ) name>xtptr @ ;    \ get the xt
***************
*** 2422,2425 ****
--- 2423,2433 ----
  \ ---------------------------- Defining Words --------------------------------
  
+ 1 constant tval
+ 2 constant tvar 
+ 3 constant tcon 
+ 4 constant tusr 
+ 5 constant tdef
+ 6 constant tloc
+ 
  : mov-tos,#n  ( n -- )                          \ generate a mov eax, # n
              sync-code                         \ generate pending code
***************
*** 2442,2447 ****
              mov-tos,#n ;
  
! : dogen     ( xt <-name-> -- )                \ generate do code
              header                            \ header
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
              ofa-calc                          \ length calculation
--- 2450,2456 ----
              mov-tos,#n ;
  
! : dogen     ( xt type-of-name <-name-> -- )   \ generate do code
              header                            \ header
+             last @ n>tfa c!                   \ set the type
              here mov-ecx,#n xt-jmp,             \ name -> mov ecx, # here | jmp xt
              ofa-calc                          \ length calculation
***************
*** 2453,2457 ****
              ( -- n )                          \ run time
              >system                           \ constant value in system space
!             ['] doval dogen ,
              dp>
              ['] (comp-cons) compiles-last     \ make the defined word compile this
--- 2462,2466 ----
              ( -- n )                          \ run time
              >system                           \ constant value in system space
!             ['] doval tcon dogen ,
              dp>
              ['] (comp-cons) compiles-last     \ make the defined word compile this
***************
*** 2461,2465 ****
  
  0 1 in/out : create    ( -<name>- )           \ pointer
!             ['] dovar dogen
  \            ['] (comp-create) compiles-last   \ doesn't work because of DOES> needs fixed
              ;
--- 2470,2474 ----
  
  0 1 in/out : create    ( -<name>- )           \ pointer
!             ['] dovar tvar dogen
  \            ['] (comp-create) compiles-last   \ doesn't work because of DOES> needs fixed
              ;
***************
*** 2474,2478 ****
  
  0 1 in/out : value     ( n -<name>- )         \ self fetching value
!             ['] doval dogen ,
              ['] (comp-val) compiles-last      \ make the defined word compile this
              ;
--- 2483,2487 ----
  
  0 1 in/out : value     ( n -<name>- )         \ self fetching value
!             ['] doval tval dogen ,
              ['] (comp-val) compiles-last      \ make the defined word compile this
              ;
***************
*** 3514,3517 ****
--- 3523,3528 ----
                  -1 c, -1 c,                   \ ste
                  0 w,                          \ ofa
+                 0 c,                          \ tfa -- typeflag
+                 0 c,                          \ flag
                  here last !                   \ nfa is last
                  ", 0 c, align                 \ nfa
***************
*** 3559,3563 ****
  : 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
              ;
--- 3570,3574 ----
  : header    ( -<name>- )                      \ build a header
              code-align                        \ align code section, temporary
!             parse-word "header
              latestxt @ to ofa                 \ for length calculations of the code generated
              ;
***************
*** 3577,3581 ****
  
  : user      ( n -<name>- )                    \ create a user variable
!             ['] dousr dogen ,
              ;
  
--- 3588,3592 ----
  
  : user      ( n -<name>- )                    \ create a user variable
!             ['] dousr tusr dogen ,
              ;
  
***************
*** 4555,4559 ****
                  (;noname)
                  postpone unnest        \ extra ret to stop see (ret ret is end of definition)
!                 latestxt @ ;           \ return the xt
  
  |: ;name        ( -- )                 \ ; for :
--- 4566,4571 ----
                  (;noname)
                  postpone unnest        \ extra ret to stop see (ret ret is end of definition)
!                 latestxt @
!                 ;
  
  |: ;name        ( -- )                 \ ; for :
***************
*** 5348,5351 ****
--- 5360,5364 ----
                    >local
                    "header                             \ build a header
+                   tloc last @ n>tfa c!                \ mark as a local
                    local>
                    localstk cells [ local-ptrs cell- ] literal \ table is zero offset

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

[Win32forth-cvs] win32forth-stc/src float.f, 1.2, 1.3 optliterals.f, 1.6, 1.7

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

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

Modified Files:
	float.f optliterals.f 
Log Message:
arm: various updates; start of type system, improve optimisation, minor correction
 to float

Index: float.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/float.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** float.f	25 Oct 2006 10:13:32 -0000	1.2
--- float.f	31 Oct 2006 00:06:31 -0000	1.3
***************
*** 387,391 ****
  : FTO
                  state @                 \ compiletime: ( FS: n - ) ( -<name_fvalue>- )
!                 if      postpone [']  postpone _fto
                  else    '  _fto         \ runtime:     ( FS: n - ) ( 'fvalue - )
                  then    ; IMMEDIATE
--- 387,392 ----
  : FTO
                  state @                 \ compiletime: ( FS: n - ) ( -<name_fvalue>- )
! \                if      postpone [']  postpone _fto
!                 if      ' postpone literal postpone _fto
                  else    '  _fto         \ runtime:     ( FS: n - ) ( 'fvalue - )
                  then    ; IMMEDIATE

Index: optliterals.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** optliterals.f	30 Oct 2006 09:15:14 -0000	1.6
--- optliterals.f	31 Oct 2006 00:06:31 -0000	1.7
***************
*** 9,13 ****
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk at win32forth.org)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
--- 9,13 ----
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk.yahoo @ schneider-busch.de)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
***************
*** 32,39 ****
  \ ------------------------------------------------------------------------
  
! cr .( Loading Constants & literals optimisation )
  
  also optimise definitions
  
  100 stack lits
  
--- 32,51 ----
  \ ------------------------------------------------------------------------
  
! cr .( Loading optimiser [literals]...)
! 
! [undefined] optimise [if] 
!   vocabulary optimise
!   : xt-inline,    ( xt -- )                       \ inline the xt
!                 dup >name n>ofa                 \ get the length
!                 w@ copy-code ;                  \ and copy the code
! [then]
  
  also optimise definitions
  
+ :noname drop postpone cell  postpone + ; compiles-for cell+
+ :noname drop postpone -cell postpone + ; compiles-for cell-
+ :noname drop 1 postpone literal postpone - ; dup compiles-for 1-
+ :noname drop 1 postpone literal postpone + ; dup compiles-for 1+ compiles-for char+
+ 
  100 stack lits
  
***************
*** 43,71 ****
  reset-stack-chain chain-add reset-lits
  
! : mov-n[ebp],eax { n }       macro[ mov   n [ebp], eax           ]macro ;
! : movzx-eax,n { addr -- }    macro[ movzx eax, byte addr         ]macro ;
! : mov-n[ebp],#n { n off }    macro[ mov   off [ebp], dword # n   ]macro ;
! : lea-ebp,n[ebp] { n }       macro[ lea   ebp, n [ebp]           ]macro ;
! : mov-eax,n   { addr }       macro[ mov   eax, addr              ]macro ;
! : mov-eax,n[ebp] { off }     macro[ mov   eax, off [ebp]         ]macro ;
  
! : pop-eax     { }             0 mov-eax,n[ebp]   4 lea-ebp,n[ebp] ;
! : push-eax    { }            -4 mov-n[ebp],eax  -4 lea-ebp,n[ebp] ;
  
! : shl-eax,n   { n }            macro[ shl   eax, n                 ]macro ;
! : shr-eax,n   { n }            macro[ shr   eax, n                 ]macro ;
! : and-eax,#n  { n } n -1 <> if macro[ and   eax, # n               ]macro then ;
! : or-eax,#n   { n }       n if macro[ or    eax, # n               ]macro then ;
! : xor-eax,#n  { n }       n if macro[ xor   eax, # n               ]macro then ;
! : mov-n,eax   { n }            macro[ mov   n , eax                ]macro ;
! : add-n,eax   { n }            macro[ add   n , eax                ]macro ;
! : mov-n,#n    { addr n }       macro[ mov   addr , dword # n       ]macro ;
! : add-n,#n    { addr n }  n if macro[ add   addr , dword # n       ]macro then ;
! : add-eax,#n  { n }       n if macro[ add   eax, # n               ]macro then ;
! : sub-eax,#n  { n }            n negate add-eax,#n ;
! : mov-n,al    { n }            macro[ mov   n , al                 ]macro ;
! : mov-n,#c    { addr n }       macro[ mov   addr , # n             ]macro ;
! : loop-add    { n }            macro[ add   [esp], dword # n jno 0 ]macro ;
! : setcc       { }              macro[ cmp   eax, # 1  sbb eax, eax ]macro ;
  
  : litstack ( n xt -- )                    \ stack literal
--- 55,123 ----
  reset-stack-chain chain-add reset-lits
  
! 0 value std-delay
! : std-adjust ( -- )                      \ generate delayed stack adjust
!            std-delay if
!               macro[ lea   ebp, std-delay negate cells [ebp] ]macro
!            0 to std-delay
!            then ;
  
! : std+n    { n }                         \ adjust stack
!            macro[ lea   ebp, n negate cells [ebp] ]macro ;
  
! \ addressing the data stack
! \ std[0] refers to top of stack (eax in this case)
! \ std[-1] is next left (as in a stack diagram)
! \ std[1] is a new right stack entry
! 
! macro: std[] ( n -- )                    \ generate code to address stack entry n
!            dup if
!              dup 0< if 1+ then
!              negate cells [ebp]
!            else drop eax then ;m
! 
! macro: std[-1] -1 std[] ;m               \ next of stack
! macro: std[0]   0 std[] ;m               \ top of stack
! macro: std[1]   1 std[] ;m               \ new on stack
! 
! 
! : mov-tos,n[ebp] { off }     macro[ mov   eax, off [ebp]         ]macro ;
! : mov-n[ebp],tos { off }     macro[ mov   off [ebp], eax         ]macro ;
! 
! macro: std[],# std[] , dword # ;m   
! 
! : #n->std[]  { n off }
!             n if
!               n -1 = if macro[ or    off std[],# n ]macro
!               else macro[ mov   off std[],# n   ]macro
!               then
!             else macro[ and    off std[],# n ]macro
!             then ;
!             
! : pop-tos     { }             0 mov-tos,n[ebp]   -1 std+n ;
! : push-tos    { }            -4 mov-n[ebp],tos    1 std+n ;
! 
! macro: tos,#n    ( n )       eax, # ;m \ macro: supports asm fragments
! 
! : var->tos      { var }     macro[ mov   eax, var               ]macro ;
! : cvar->tos     { var }     macro[ movzx eax, byte var          ]macro ;
! : #n->tos       ( n )    >r macro[ mov   r@ tos,#n              ]macro r>drop ;
! : tos->var      { var }     macro[ mov   var , eax              ]macro ;
! : tos->cvar     { var }     macro[ mov   var , al               ]macro ;
! : #n->var       { var n }   macro[ mov   var , dword # n        ]macro ;
! : #n->cvar      { var c }   macro[ mov   var , byte # c         ]macro ;
! 
! : add-v,tos      { var }     macro[ add   var , eax              ]macro ;
! : add-v,#n       { var n } n if   macro[ add   var , dword # n        ]macro  then ;
! : add-tos,#n     ( n )     dup if >r macro[ add   r@ tos,#n              ]macro r>drop else drop then ;
! : sub-tos,#n     ( n )    >r macro[ sub   r@ tos,#n              ]macro r>drop ;
! : shl-tos,#n     ( n )    >r macro[ shl   r@ tos,#n              ]macro r>drop ;
! : shr-tos,#n     ( n )    >r macro[ shr   r@ tos,#n              ]macro r>drop ;
! : and-tos,#n     ( n )    >r macro[ and   r@ tos,#n              ]macro r>drop ;
! : or-tos,#n      ( n )    >r macro[ or    r@ tos,#n              ]macro r>drop ;
! : xor-tos,#n     ( n )    >r macro[ xor   r@ tos,#n              ]macro r>drop ;
! : not-tos        ( -- )      macro[ not   eax                    ]macro ;
! 
! : loop-add    { n }          macro[ add   [esp], dword # n jno 0 ]macro ;
! : setcc       { }            macro[ cmp   eax, # 1  sbb eax, eax ]macro ;
  
  : litstack ( n xt -- )                    \ stack literal
***************
*** 84,96 ****
             in-sync @ 0= if               \ recursing?
               in-sync on                  \ no, so set
               lits>0? dup if               \ anything to do?
!                lits spop >r               \ save last entry (it's eax)
!                -4 mov-n[ebp],eax          \ save eax
                 lits sdepth 0 ?do          \ do for n-1 entries
!                  lits spop over negate i + cells
!                  mov-n[ebp],#n            \ generate a move
                 loop
!                cells negate lea-ebp,n[ebp] \ adjust stack
!                r> mov-tos,#n               \ load eax
               else drop
               then
--- 136,148 ----
             in-sync @ 0= if               \ recursing?
               in-sync on                  \ no, so set
+              std-adjust
               lits>0? dup if               \ anything to do?
!                -4 mov-n[ebp],tos          \ save tos
!                lits spop #n->tos          \ load tos
                 lits sdepth 0 ?do          \ do for n-1 entries
!                  lits spop over i - 
!                  #n->std[]               \ generate a move
                 loop
!                std+n                     \ adjust stack
               else drop
               then
***************
*** 110,118 ****
  ' uniopt compiles-for not
  ' uniopt compiles-for 0<>
! ' uniopt compiles-for 0<
! ' uniopt compiles-for 0>
  ' uniopt compiles-for cells
  
! \ ' binopt compiles-for <>
  ' binopt compiles-for <
  ' binopt compiles-for >
--- 162,170 ----
  ' uniopt compiles-for not
  ' uniopt compiles-for 0<>
! ' uniopt compiles-for 0<         
! ' uniopt compiles-for 0>         
  ' uniopt compiles-for cells
  
! ' binopt compiles-for <>
  ' binopt compiles-for <
  ' binopt compiles-for >
***************
*** 127,155 ****
  : litstart ( xt -- n )                    \ drop the xt, get constant
             drop lits spop sync-code ;
! 
! : opt@     ( xt -- ) lits>0? if litstart push-eax mov-eax,n   else xt-inline, then ;
! : optc@    ( xt -- ) lits>0? if litstart push-eax movzx-eax,n else xt-inline, then ;
  : optpick  ( xt -- ) lits>0? if
!                        litstart push-eax cells dup if
!                          mov-eax,n[ebp]
                         else drop then
                       else xt-inline, then ;
  
! : opt+     ( xt -- ) lits=1?  if litstart add-eax,#n        else binopt then ;
! : opt-     ( xt -- ) lits=1?  if litstart sub-eax,#n        else binopt then ;
! : optlshift ( xt -- ) lits=1? if litstart shl-eax,n         else binopt then ;
! : optrshift ( xt -- ) lits=1? if litstart shr-eax,n         else binopt then ;
! : optand   ( xt -- ) lits=1?  if litstart and-eax,#n        else binopt then ;
! : optor    ( xt -- ) lits=1?  if litstart or-eax,#n         else binopt then ;
! : optxor   ( xt -- ) lits=1?  if litstart xor-eax,#n        else binopt then ;
! : opt=     ( xt -- ) lits=1?  if litstart sub-eax,#n setcc  else binopt then ;
! : opt<>    ( xt -- ) lits=1?  if litstart sub-eax,#n setcc
!                      macro[ not eax ]macro                  else binopt then ;
  
  : opt!     ( xt -- )
             lits=1? if
!              litstart mov-n,eax pop-eax
             else lits>1? if
!              drop lits s2pop mov-n,#n
               else
                 xt-inline,
--- 179,206 ----
  : litstart ( xt -- n )                    \ drop the xt, get constant
             drop lits spop sync-code ;
!            
! : opt@     ( xt -- ) lits>0? if litstart push-tos var->tos   else xt-inline, then ;
! : optc@    ( xt -- ) lits>0? if litstart push-tos cvar->tos else xt-inline, then ;
  : optpick  ( xt -- ) lits>0? if
!                        litstart push-tos cells dup if
!                          mov-tos,n[ebp]
                         else drop then
                       else xt-inline, then ;
  
! : opt+     ( xt -- ) lits=1?  if litstart add-tos,#n        else binopt then ;
! : opt-     ( xt -- ) lits=1?  if litstart sub-tos,#n        else binopt then ;
! : optlshift ( xt -- ) lits=1? if litstart shl-tos,#n        else binopt then ;
! : optrshift ( xt -- ) lits=1? if litstart shr-tos,#n        else binopt then ;
! : optand   ( xt -- ) lits=1?  if litstart and-tos,#n        else binopt then ;
! : optor    ( xt -- ) lits=1?  if litstart or-tos,#n         else binopt then ;
! : optxor   ( xt -- ) lits=1?  if litstart xor-tos,#n        else binopt then ;
! : opt=     ( xt -- ) lits=1?  if litstart sub-tos,#n setcc  else binopt then ;
! : opt<>    ( xt -- ) lits=1?  if litstart sub-tos,#n setcc not-tos else binopt then ;
  
  : opt!     ( xt -- )
             lits=1? if
!              litstart tos->var pop-tos
             else lits>1? if
!              drop lits s2pop #n->var
               else
                 xt-inline,
***************
*** 157,166 ****
             then
             ;
! 
  : opt+!    ( xt -- )
             lits=1? if
!              litstart add-n,eax pop-eax
             else lits>1? if
!              drop lits s2pop add-n,#n
               else
                 xt-inline,
--- 208,217 ----
             then
             ;
!            
  : opt+!    ( xt -- )
             lits=1? if
!              litstart add-v,tos pop-tos
             else lits>1? if
!              drop lits s2pop add-v,#n
               else
                 xt-inline,
***************
*** 171,177 ****
  : optc!    ( xt -- )
             lits=1? if
!              litstart mov-n,al pop-eax
             else lits>1? if
!              drop lits s2pop mov-n,#c
               else
                 xt-inline,
--- 222,228 ----
  : optc!    ( xt -- )
             lits=1? if
!              litstart tos->cvar pop-tos
             else lits>1? if
!              drop lits s2pop #n->cvar
               else
                 xt-inline,
***************
*** 179,183 ****
             then
             ;
! 
  ' litstack compiles-for literal
  ' litsync is sync-code
--- 230,234 ----
             then
             ;
!            
  ' litstack compiles-for literal
  ' litsync is sync-code
***************
*** 200,206 ****
  
  
- :noname drop postpone cell  postpone + ; compiles-for cell+
- :noname drop postpone -cell postpone + ; compiles-for cell-
- :noname drop 1 postpone literal postpone + ; dup compiles-for 1+ compiles-for char+
- 
  previous definitions
--- 251,253 ----

[Win32forth-cvs] win32forth-stc gkernel.exe,1.23,1.24

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

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

Modified Files:
	gkernel.exe 
Log Message:
arm: various updates; start of type system, improve optimisation, minor correction
 to float

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.23
retrieving revision 1.24
diff -C2 -d -r1.23 -r1.24
Binary files /tmp/cvskdqrS3 and /tmp/cvs10ko2W differ

[Win32forth-cvs] win32forth-610old/htm p-relnotes.6.10.htm, 1.6, 1.7

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

Update of /cvsroot/win32forth/win32forth-610old/htm
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25290/win32forth-610old/htm

Modified Files:
	p-relnotes.6.10.htm 
Log Message:
gah:Modified Locals-init to not check stack depth to fix bug reported by Elko Tchernev.

Index: p-relnotes.6.10.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth-610old/htm/p-relnotes.6.10.htm,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** p-relnotes.6.10.htm	25 Aug 2006 14:12:30 -0000	1.6
--- p-relnotes.6.10.htm	30 Oct 2006 12:01:40 -0000	1.7
***************
*** 147,150 ****
--- 147,152 ----
  isn't found. Also it correctly finds an earlier version of old name (if it's in the search order) where the two names are the same and the current and context vocabularies are also the same. </p>
  
+ <p><b>LOCALS-INIT </b>  has been modified not to throw an error when used in control structures, since this was causing problems when values where placed on the stack by the program, while compiling. </p>
+ 
  <h2>New Applications</h2>
  <ul>

[Win32forth-cvs] win32forth-610old/src/kernel fkernel.f, 1.7, 1.8 version.f, 1.6, 1.7

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

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

Modified Files:
	fkernel.f version.f 
Log Message:
gah:Modified Locals-init to not check stack depth to fix bug reported by Elko Tchernev.

Index: fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-610old/src/kernel/fkernel.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** fkernel.f	24 Aug 2006 11:44:07 -0000	1.7
--- fkernel.f	30 Oct 2006 12:01:42 -0000	1.8
***************
*** 5065,5069 ****
  
  |: LOCALS-INIT ( -- )                          \ init, check if locals validly used
! 	?csp				       \ make sure not used inside control structures
          ?comp                                  \ must be compiling
          PARMS THROW_LOCALSTWICE ?THROW        \ and not used before in the definition
--- 5065,5069 ----
  
  |: LOCALS-INIT ( -- )                          \ init, check if locals validly used
! \	?csp				       \ make sure not used inside control structures
          ?comp                                  \ must be compiling
          PARMS THROW_LOCALSTWICE ?THROW        \ and not used before in the definition
***************
*** 5880,5882 ****
  \ Prad~
  
- 

[Win32forth-cvs] win32forth/doc p-relnotes.6.10.htm,1.5,1.6

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

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

Modified Files:
	p-relnotes.6.10.htm 
Log Message:
gah:Modified Locals-init to not check stack depth to fix bug reported by Elko Tchernev.

Index: p-relnotes.6.10.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/doc/p-relnotes.6.10.htm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** p-relnotes.6.10.htm	25 Aug 2006 14:13:34 -0000	1.5
--- p-relnotes.6.10.htm	30 Oct 2006 12:01:42 -0000	1.6
***************
*** 147,150 ****
--- 147,152 ----
  isn't found. Also it correctly finds an earlier version of old name (if it's in the search order) where the two names are the same and the current and context vocabularies are also the same. </p>
  
+ <p><b>LOCALS-INIT </b>  has been modified not to throw an error when used in control structures, since this was causing problems when values where placed on the stack by the program, while compiling. </p>
+ 
  <h2>New Applications</h2>
  <ul>

[Win32forth-cvs] win32forth/src/kernel fkernel.f,1.40,1.41

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

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

Modified Files:
	fkernel.f 
Log Message:
gah:Modified Locals-init to not check stack depth to fix bug reported by Elko Tchernev.

Index: fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v
retrieving revision 1.40
retrieving revision 1.41
diff -C2 -d -r1.40 -r1.41
*** fkernel.f	10 Oct 2006 11:11:25 -0000	1.40
--- fkernel.f	30 Oct 2006 12:01:43 -0000	1.41
***************
*** 5194,5198 ****
  
  |: LOCALS-INIT ( -- )                          \ init, check if locals validly used
!         ?csp                                   \ make sure not used inside control structures
          ?comp                                  \ must be compiling
          PARMS THROW_LOCALSTWICE ?THROW         \ and not used before in the definition
--- 5194,5198 ----
  
  |: LOCALS-INIT ( -- )                          \ init, check if locals validly used
! \        ?csp                                   \ make sure not used inside control structures
          ?comp                                  \ must be compiling
          PARMS THROW_LOCALSTWICE ?THROW         \ and not used before in the definition

[Win32forth-cvs] win32forth/src/lib task.f,1.13,1.14

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

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

Modified Files:
	task.f 
Log Message:
gah:Modified to use in-previous

Index: task.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/task.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** task.f	16 Oct 2006 11:22:22 -0000	1.13
--- task.f	30 Oct 2006 09:17:53 -0000	1.14
***************
*** 237,241 ****
                  create  (make-lock) drop ;
  
! in-application
  
  internal
--- 237,241 ----
                  create  (make-lock) drop ;
  
! in-previous
  
  internal
***************
*** 309,313 ****
  forget-chain chain-add trim-locks
  
! in-application
  
  module
--- 309,313 ----
  forget-chain chain-add trim-locks
  
! in-previous
  
  module

[Win32forth-cvs] win32forth-stc/src POINTER.F, 1.3, 1.4 extend.f, 1.14, 1.15 forget.f, 1.1, 1.2 optliterals.f, 1.5, 1.6 primutil.f, 1.14, 1.15

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

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

Modified Files:
	POINTER.F extend.f forget.f optliterals.f primutil.f 
Log Message:
gah:Marker Anew and Mark (but not forget) working.

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** primutil.f	28 Oct 2006 09:07:08 -0000	1.14
--- primutil.f	30 Oct 2006 09:15:14 -0000	1.15
***************
*** 46,50 ****
  in-system
  
! : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
  : DEPRECATED                    ; immediate     \ *** to be done ***
--- 46,50 ----
  in-system
  
! \ : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
  : DEPRECATED                    ; immediate     \ *** to be done ***
***************
*** 149,153 ****
  
  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
  
  in-application
--- 149,153 ----
  
  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
  
  in-application

Index: forget.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/forget.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** forget.f	21 Sep 2006 16:26:33 -0000	1.1
--- forget.f	30 Oct 2006 09:15:14 -0000	1.2
***************
*** 1,45 ****
! \ NFORGET.F
! \ nforget.f beta 2003/02/13 rbs Various changes as documented below
! \ -rbs 10/24/02 added trim-WinLibs and trim-WinProcs to a new post-forget-chain
! 
! \ -rbs new DO-MARK does not generate redef warnings when marked word is
! \ executed, also resets vocabulary to ONLY FORTH ALSO DEFINITIONS.
! \ -rbs do-marker changed to reset voc also December 10th, 2002
  
! \ -rbs new DO-MARK does not generate redef warnings when marked word is
! \ executed, also resets vocabulary to ONLY FORTH ALSO DEFINITIONS.
  
! \ This is a modified version of FORGET.F for dual dictionaries,
! \ by Stephen M. Brault.
  
! \ Received: 05 Feb 96 05:26:38 EST
! \     From: "Stephen M. Brault" <721...@co...>
  
! \ February 5th, 1996 - 22:43 tjz
! \ Renamed _TRIM? to SYS-TRIM? which describes its function.
! \ Renamed TRIM to FULL-TRIM, to avoid a name conflict with the original
! \ simple version of TRIM which is used in other areas of the system, and
! \ takes slightly different parameters.
  
! \ Notice that TRIM? is deferred, so its function can be changed to make
! \ FULL-TRIM trim things other than the dictionary if desired.
  
! cr .( Loading Forget Wordset...)
  
! \ FORGET limitations:
! \ 1) You cannot directly forget an IN-SYSTEM word since
! \ it would require extra work to determine the new DP.
! \ You can indirectly forget an IN-SYSTEM word by forgetting
! \ an earlier IN-APPLICATION word.
  
! variable fence                          \ cannot forget below this address
  
! : sys-trim?     ( nfa addr -- f )       \ TRUE if forgetting nfa removes addr from dict
!         tuck sys-origin dup sys-size + between
!         if                              \ addr is IN-SYSTEM or TRANSIENT
!                 name>link sys-here         \ so use nfa as trim address
!         else                            \ addr is IN-APPLICATION
!                 name>xt app-here          \ so use cfa as trim address
!         then    between ;               \ ?Won't work across the 2Gb line
  
  defer trim? ' sys-trim? is trim?
--- 1,71 ----
! \ $Id$
  
! \ --------------------------- Change Block -------------------------------
! \
! \
! \ ------------------------- End Change Block -----------------------------
! \
! \ Experimental: a fully optimising, STC based, ANS Forth compliant kernel
! \
! \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk at win32forth.org)
! \                       George Hubert (georgeahubert at yahoo.co.uk)
! \
! \ 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.,
! \ 675 Mass Ave, Cambridge, MA 02139, USA.
! \
! \ ------------------------------------------------------------------------
! \
! \ Marker Empty and Anew
! \
! \ ------------------------------------------------------------------------
  
! cr .( Loading Forget Wordset...)
  
! \ NOTE
! \ 1) Forget no longer works.
! \ 2) Markers now reset the user area.
  
! \ Structure of Mark and Marker pfa
  
! 0   cell field+ >me
!     cell field+ >pre-adp
!     cell field+ >pre-cdp
!     cell field+ >pre-sdp
!     cell field+ >pre-kdp
!     cell field+ >pre-user
! 0        field+ >forget-extra drop
  
! variable fence                          \ cannot forget below this address
  
! : in-space?     ( addr ?dp -- f )
! \ *G Returns true if addr is between the origin and top of the space represented
! \ ** by ?dp (adp, cdp, sdp, kdp or any transient space created by the user).
!                 dup @ swap 2 cells+ @ between ;
  
! : (sys-trim?)   ( nfa addr -- addr pre-?dp ?dp-top )
! \ Previous dp top of dp of the correct space for addr ( or 0 -1 if not in any
! \ dictionary space).
!                 swap name>xt >body
!                 over adp in-space? if >pre-adp @ adp 2 cells+ @ exit then
!                 over cdp in-space? if >pre-cdp @ cdp 2 cells+ @ exit then
!                 over sdp in-space? if >pre-sdp @ sdp 2 cells+ @ exit then
!                 over kdp in-space? if >pre-kdp @ kdp 2 cells+ @ exit then
!                 drop 0 -1 ; \ dirty trick
  
! : sys-trim?     ( nfa addr -- f )
! \ *G TRUE if forgetting nfa removes addr from dict.
!                 (sys-trim?) between ;
  
  defer trim? ' sys-trim? is trim?
***************
*** 65,107 ****
          repeat  dup sys-chain-link full-trim ;
  
! : trim-defer    ( nfa -- nfa )          \ trim deferred word list to nfa
!         dup defer-list full-trim
!         defer-list
!         begin   @ ?dup
!         while   2dup cell- @
!                 trim?                   \ if forgetting IS word
!                 if      dup cell+ @     \ revert to default
!                         over cell- !
!                 then
!         repeat ;
! 
! forget-chain chain-add trim-defer
! 
! : trim-handles  ( nfa -- nfa )          \ trim handles list
!         dup handles-list full-trim ;
! 
! forget-chain chain-add trim-handles
  
! : trim-WinLibs
!     winlib-link
!     begin   @ dup
!     while   dup here >
!             if dup @ dup winlib-link ! winlib-last !
!             else drop exit
!             then
!     repeat drop ;
  
! post-forget-chain chain-add trim-WinLibs
  
  : trim-WinProcs
!     winproc-link
!     begin   @ dup
!     while   dup here >
!             if dup @ dup winproc-link ! winproc-last !
!             else drop exit
!             then
!     repeat drop ;
  
! post-forget-chain chain-add trim-WinProcs
  
  : vtrim ( nfa voc-thread -- ) \ trim VOC-THREAD back to nfa
--- 91,121 ----
          repeat  dup sys-chain-link full-trim ;
  
! \ : trim-defer    ( nfa -- nfa )          \ trim deferred word list to nfa
! \         dup defer-list full-trim
! \         defer-list
! \         begin   @ ?dup
! \         while   2dup cell- @
! \                 trim?                   \ if forgetting IS word
! \                 if      dup cell+ @     \ revert to default
! \                         over cell- !
! \                 then
! \         repeat ;
! \
! \ forget-chain chain-add trim-defer
! \
! \ : trim-handles  ( nfa -- nfa )          \ trim handles list
! \         dup handles-list full-trim ;
! \
! \ forget-chain chain-add trim-handles
  
! : trim-WinLibs    ( nfa -- nfa )
!           dup winlib-link full-trim winlib-link @ winlib-last ! ;
  
! forget-chain chain-add trim-WinLibs
  
  : trim-WinProcs
!           dup winproc-link full-trim winproc-link @ winproc-last ! ;
  
! forget-chain chain-add trim-WinProcs
  
  : vtrim ( nfa voc-thread -- ) \ trim VOC-THREAD back to nfa
***************
*** 110,206 ****
          loop    2drop ;
  
! : (forget) ( cfa -- )   \ assumes count follows name
!         dup app-here u>                 \ if in system area
!         over @ ['] FORTH @ <> and         \ but not a vocabulary
!         abort" in system or transient dictionary"
!         dup cell+ ResetSrcInfo
!         >name
!         dup fence @ 1- trim? abort" in protected dictionary"
!         voc-link 2dup full-trim
!         begin   @ ?dup
!         while   2dup vlink>voc vtrim
!         repeat
          forget-chain do-chain   \ do forget-chain before trimming it
          trim-chains
          context #vocs cells+ context
          do      dup i @ trim?
!                 if      [ ' forth vcfa>voc ] literal i !
                  then
!                 cell +loop
!         dup name>link sdp !          \ update SYS-HERE
!         name>xt dup dp @ u<        \ if new address is in application space
!         IF      dp !             \ then update HERE
!           post-forget-chain do-chain \ post-forget chain
!         ELSE    drop
!         THEN
!         voc-also                \ reset look-aside table if present
          ;
  
! : forget ( -<name>xt- )
          bl word count
!         current @ search-wordlist ?missing ( cfa ) (forget) ;
  
! : do-mark ( -- )        \ mark must redefine the name that was forgotten
! \ -rbs modified to reset vocabs and not generate redef warnings when marked
! \ word is executed.
!         does>   { does-adr \ mark-name$ -- }
!                 MAXSTRING LocalAlloc: mark-name$
!                 s" mark " mark-name$ place
!                 does-adr body> dup >name nfa-count mark-name$ +place
!                 (forget)
! \ -rbs
! \                forth definitions
! s" ONLY FORTH ALSO DEFINITIONS" evaluate
! WARNING @ WARNING OFF
!                 mark-name$ count evaluate
! WARNING !
!                 ;
  
! : mark  ( -<name>xt- )
!         >application create save-source do-mark application> ;
  
! \ January 27th, 1999 - 11:27 tjz
! \ modified MARKER to preserve and restore the search order
  
  : do-marker ( -- )
!         does> dup>r @ (forget)
!         r> cell+ dup @ current !                        \ restore current
!         cell+ context #vocs cells move ;                \ restore context search list
  
! : marker ( -<name>xt- ) ( ANS)
!         >application
!         WARNING @ WARNING OFF
!         create
!         WARNING !
!         save-source here body> ,
!         current @ ,                                     \ save current
!         context here #vocs cells allot #vocs cells move \ save context search list
!         do-marker
!         application> ;
  
! \  POSSIBLY                        ( "name" -- )
! \     Execute _name_ if it exists; otherwise, do nothing. Useful
! \     implementation factor of `ANEW`.
  
! : possibly  ( "name" -- )  parse-word find-name ?dup if name>xt execute then ;
  
! \  ANEW                            ( "name" -- )( Run: -- )
! \     Compiler directive used in the form: `ANEW _name_`. If the word
! \     _name_ already exists, it and all subsequent words are
! \     forgotten from the current dictionary, then a `MARKER` word
! \     _name_ is created. This is usually placed at the start of a
! \     file. When the code is reloaded, any prior version is
! \     automatically pruned from the dictionary.
! \
! \     Executing _name_ will also cause it to be forgotten, since
! \     it is a `MARKER` word.
  \
! \     Useful implementation factor of `EMPTY`.
! 
! : anew  ( "name" -- )( run: -- )  >in @ possibly >in ! marker ;
  
  here fence !
  
! 
! 
! 
--- 124,212 ----
          loop    2drop ;
  
! : (forget) ( pfa -- )
!         dup >me @
          forget-chain do-chain   \ do forget-chain before trimming it
          trim-chains
          context #vocs cells+ context
          do      dup i @ trim?
!                 if      [ ' forth >body ] literal i !
                  then
!                 cell +loop swap
!         dup >pre-adp @ adp !
!         dup >pre-cdp @ cdp !
!         dup >pre-sdp @ sdp !
!         dup >pre-kdp @ kdp !
!         >pre-user @ next-user !
!         voc-link 2dup full-trim
!         begin   @ ?dup
!         while   2dup vlink>voc
!                 vtrim
!         repeat  drop
! \        voc-also                \ reset look-aside table if present
          ;
  
! : forget ( -<name>- )
          bl word count
!         current @ search-wordlist ?missing
!         drop ." Forget no longer works. Use Marker or Anew instead" cr ;
  
! : Get-marking-info    ( -- user kdp sdp cdp adp )
!                       next-user @ kdp @ sdp @ cdp @ adp @ ;
  
! : Save-marking-info   ( user kdp sdp cdp adp -- )
!                       , , , , , ;
  
! : Save-search-order   ( -- )
!         get-current ,                          \ save current
!         get-order dup , 0 ?do , loop ;         \ save context search list
! 
! : (Restore-search-order) ( addr n -- wid1...widn )
!         -if swap dup @ >r cell+ swap 1- recurse r>
!         else 2drop then ;
! 
! : Restore-search-order ( addr -- )
!         >forget-extra dup @ set-current         \ restore current
!         cell+ dup @ dup>r swap cell+ swap
!         (Restore-search-order) r> set-order  ;  \ restore context search list
  
  : do-marker ( -- )
!         does> dup cell+ @ fence @ <
!         abort" Attempt to forget in protected part of the dictionary!"
!         dup Restore-search-order (forget) ;
  
! : mark  ( -<name>- )
!         in-previous in-system create last @ ,
!         get-current get-order only forth also definitions
!         Get-marking-info rot >forget-extra 2 cells+
!         get-order dup>r 0 ?do drop loop r> cells+ -rot save-marking-info
!         save-search-order set-order set-current
!         do-marker in-previous ;
  
! : marker ( -<name>- ) ( ANS)
!         in-previous in-system
! \        WARNING @ WARNING OFF
!         Get-marking-info create last @ , Save-marking-info
! \        WARNING !
! \        save-source here body> ,
!         save-search-order do-marker in-previous ;
  
! : POSSIBLY  ( "name" -- )
! \ *G Execute _name_ if it exists; otherwise, do nothing. Useful
! \ ** implementation factor of `ANEW`.
!   BL WORD FIND  ?dup AND IF  EXECUTE  THEN ;
  
! : ANEW  ( "name" -- )( Run: -- )
! \ *G     Compiler directive used in the form: `ANEW _name_`. If the word
! \ **     _name_ already exists, it and all subsequent words are
! \ **     forgotten from the current dictionary, then a `MARKER` word
! \ **     _name_ is created. This is usually placed at the start of a
! \ **     file. When the code is reloaded, any prior version is
! \ **     automatically pruned from the dictionary.
  \
! \ *P     Executing _name_ will also cause it to be forgotten, since
! \ **     it is a `MARKER` word.
!   >IN @ POSSIBLY  >IN ! MARKER ;
  
  here fence !
  
! \s

Index: extend.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** extend.f	28 Oct 2006 09:07:08 -0000	1.14
--- extend.f	30 Oct 2006 09:15:14 -0000	1.15
***************
*** 22,25 ****
--- 22,26 ----
      fload src\console\console2.f \ console i/o extracted from primutil.f
  sys-fload src\dotwords.f    \ dot support words
+ sys-FLOAD src\forget.f      \ forget words
      FLOAD src\paths.f       \ multi path support words
  sys-fload src\imageman.f    \ fsave, application & turnkey words
***************
*** 39,42 ****
--- 40,46 ----
      FLOAD src\registry.f    \ Win32 Registry support
  
+ here fence ! mark empty     \ Prevent forgetting anything before this
+                             \ move this down as newer files are added
+ 
  \     FLOAD src\lib\array.f       \ Array words
  \     FLOAD src\lib\binsearch.f   \ Binary search
***************
*** 53,57 ****
  
  \     FLOAD src\primhash.f    \ primitive hash functions for OOP later  *** to be done ***
- \ sys-FLOAD src\nforget.f     \ forget words                            *** to be done ***
  \ sys-FLOAD src\dbgsrc1.f     \ source level debugging support part one *** to be done ***
  
--- 57,60 ----

Index: POINTER.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/POINTER.F,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** POINTER.F	5 Oct 2006 08:46:14 -0000	1.3
--- POINTER.F	30 Oct 2006 09:15:13 -0000	1.4
***************
*** 9,14 ****
  \               [ phy_pointer ][ link ][ size_bytes ]  |
  
- in-application
- 
  internal
  
--- 9,12 ----
***************
*** 26,35 ****
  
  : Pointer       ( bytes -<name>- )               \ make a pointer "name"
!                 get-section 2>r in-application   \ always in app space
                  128 max                          \ at least 160 bytes
                  create 0 ,                       \ initialize to unallocated
                  PHEAD link,                      \ link into chain
                  ,                                \ lay in size in bytes
!                 2r> set-section does>            \ back to where we came from
                  dup @ if @ exit then             \ ok, straight fetch
                  dup (pointerlock)
--- 24,33 ----
  
  : Pointer       ( bytes -<name>- )               \ make a pointer "name"
!                 in-previous in-application       \ always in app space
                  128 max                          \ at least 160 bytes
                  create 0 ,                       \ initialize to unallocated
                  PHEAD link,                      \ link into chain
                  ,                                \ lay in size in bytes
!                 in-previous does>                \ back to where we came from
                  dup @ if @ exit then             \ ok, straight fetch
                  dup (pointerlock)
***************
*** 41,59 ****
                         abort" Failed to allocate POINTER" ;
  
! \ Forgetting and decompiling to be done.
! \ in-system
! \
! \ : TRIM-POINTERS ( a1 -- a1 )
! \                 PHEAD
! \                 BEGIN   @ ?DUP
! \                 WHILE   2DUP TRIM?
! \                         IF      DUP CELL- @ ?DUP
! \                                 IF      RELEASE
! \                                 THEN
! \                         THEN
! \                 REPEAT  DUP PHEAD FULL-TRIM ;
! \
! \ forget-chain chain-add trim-pointers
! \
  \ : (.Pointer)    ( pfa -- )
  \                 dup 2 cells+ @ 10 U,.R ."  bytes at: "
--- 39,60 ----
                         abort" Failed to allocate POINTER" ;
  
! \ Decompiling to be done.
! 
! in-system
! 
! internal
! 
! : TRIM-POINTERS ( a1 -- a1 )
!                 PHEAD
!                 BEGIN   @ ?DUP
!                 WHILE   2DUP TRIM?
!                         IF      DUP CELL- @ ?DUP
!                                 IF      RELEASE
!                                 THEN
!                         THEN
!                 REPEAT  DUP PHEAD FULL-TRIM ;
! 
! forget-chain chain-add trim-pointers
! 
  \ : (.Pointer)    ( pfa -- )
  \                 dup 2 cells+ @ 10 U,.R ."  bytes at: "
***************
*** 91,94 ****
--- 92,97 ----
  external
  
+ in-previous
+ 
  : %UnPointer    ( cfa -- )      \ deallocate pointer given the cfa
                  IsPointer? >BODY DUP @ 0<>                  \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu)
***************
*** 124,128 ****
                  drop postpone dup ' >body postpone literal postpone (resizepointer) ;
  
! \ in-system
  
  \ These words need to be compile\interpret words
--- 127,131 ----
                  drop postpone dup ' >body postpone literal postpone (resizepointer) ;
  
! in-system
  
  \ These words need to be compile\interpret words
***************
*** 158,162 ****
                  MAXSTRING Pointer ;
  
! in-application
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 161,165 ----
                  MAXSTRING Pointer ;
  
! in-previous
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Index: optliterals.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** optliterals.f	28 Oct 2006 09:07:08 -0000	1.5
--- optliterals.f	30 Oct 2006 09:15:14 -0000	1.6
***************
*** 53,71 ****
  : push-eax    { }            -4 mov-n[ebp],eax  -4 lea-ebp,n[ebp] ;
  
! : shl-eax,n   { n }          macro[ shl   eax, n                 ]macro ;
! : shr-eax,n   { n }          macro[ shr   eax, n                 ]macro ;
! : and-eax,#n  { n }          macro[ and   eax, # n               ]macro ;
! : or-eax,#n   { n }          macro[ or    eax, # n               ]macro ;
! : xor-eax,#n  { n }          macro[ xor   eax, # n               ]macro ;
! : mov-n,eax   { n }          macro[ mov   n , eax                ]macro ;
! : add-n,eax   { n }          macro[ add   n , eax                ]macro ;
! : mov-n,#n    { addr n }     macro[ mov   addr , dword # n       ]macro ;
! : add-n,#n    { addr n }     macro[ add   addr , dword # n       ]macro ;
! : add-eax,#n  { n }          macro[ add   eax, # n               ]macro ;
! : sub-eax,#n  { n }          n negate add-eax,#n ;
! : mov-n,al    { n }          macro[ mov   n , al                 ]macro ;
! : mov-n,#c    { addr n }     macro[ mov   addr , # n             ]macro ;
! : loop-add    { n }          macro[ add   [esp], dword # n jno 0 ]macro ;
! : setcc       { }            macro[ cmp   eax, # 1  sbb eax, eax ]macro ;
  
  : litstack ( n xt -- )                    \ stack literal
--- 53,71 ----
  : push-eax    { }            -4 mov-n[ebp],eax  -4 lea-ebp,n[ebp] ;
  
! : shl-eax,n   { n }            macro[ shl   eax, n                 ]macro ;
! : shr-eax,n   { n }            macro[ shr   eax, n                 ]macro ;
! : and-eax,#n  { n } n -1 <> if macro[ and   eax, # n               ]macro then ;
! : or-eax,#n   { n }       n if macro[ or    eax, # n               ]macro then ;
! : xor-eax,#n  { n }       n if macro[ xor   eax, # n               ]macro then ;
! : mov-n,eax   { n }            macro[ mov   n , eax                ]macro ;
! : add-n,eax   { n }            macro[ add   n , eax                ]macro ;
! : mov-n,#n    { addr n }       macro[ mov   addr , dword # n       ]macro ;
! : add-n,#n    { addr n }  n if macro[ add   addr , dword # n       ]macro then ;
! : add-eax,#n  { n }       n if macro[ add   eax, # n               ]macro then ;
! : sub-eax,#n  { n }            n negate add-eax,#n ;
! : mov-n,al    { n }            macro[ mov   n , al                 ]macro ;
! : mov-n,#c    { addr n }       macro[ mov   addr , # n             ]macro ;
! : loop-add    { n }            macro[ add   [esp], dword # n jno 0 ]macro ;
! : setcc       { }              macro[ cmp   eax, # 1  sbb eax, eax ]macro ;
  
  : litstack ( n xt -- )                    \ stack literal
***************
*** 114,118 ****
  ' uniopt compiles-for cells
  
! ' binopt compiles-for <>
  ' binopt compiles-for <
  ' binopt compiles-for >
--- 114,118 ----
  ' uniopt compiles-for cells
  
! \ ' binopt compiles-for <>
  ' binopt compiles-for <
  ' binopt compiles-for >
***************
*** 144,147 ****
--- 144,149 ----
  : optxor   ( xt -- ) lits=1?  if litstart xor-eax,#n        else binopt then ;
  : opt=     ( xt -- ) lits=1?  if litstart sub-eax,#n setcc  else binopt then ;
+ : opt<>    ( xt -- ) lits=1?  if litstart sub-eax,#n setcc
+                      macro[ not eax ]macro                  else binopt then ;
  
  : opt!     ( xt -- )
***************
*** 195,198 ****
--- 197,201 ----
  ' optc!    compiles-for c!
  ' opt=     compiles-for =
+ ' opt<>    compiles-for <>
  
  

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

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

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

Modified Files:
	task.f 
Log Message:
gah:Marker Anew and Mark (but not forget) working.

Index: task.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/lib/task.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** task.f	28 Oct 2006 13:20:58 -0000	1.1
--- task.f	30 Oct 2006 09:15:15 -0000	1.2
***************
*** 275,279 ****
                  create  (make-lock) drop ;
  
! in-application
  
  internal
--- 275,279 ----
                  create  (make-lock) drop ;
  
! in-previous
  
  internal
***************
*** 329,333 ****
  
  initialization-chain chain-add init-system-locks
! \s ========================STC DOESN'T HAVE FORGET YET====================================
  \ -------------------- Forgetting Locks -----------------------------
  
--- 329,333 ----
  
  initialization-chain chain-add init-system-locks
! 
  \ -------------------- Forgetting Locks -----------------------------
  
***************
*** 347,351 ****
  forget-chain chain-add trim-locks
  
! in-application
  
  module
--- 347,351 ----
  forget-chain chain-add trim-locks
  
! in-previous
  
  module

[Win32forth-cvs] win32forth-stc/src/lib MAPFILE.F,NONE,1.1

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

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

Added Files:
	MAPFILE.F 
Log Message:
- Ported Mapfile.f

--- NEW FILE: MAPFILE.F ---
\ $Id: MAPFILE.F,v 1.1 2006/10/29 08:31:56 dbu_de Exp $
\ MAPFILE.F             File Memory Mapping             by Tom Zimmer
\ arm 02/01/2005 21:42:24 DOMAP , instead of DOMAP COMPILE,

cr .( Loading File Memory Mapping...)

IN-APPLICATION

: map-handle    ( -<name>- )
\ *G Define a data structure to hold a mapped file
                create
                     -1 ,                 \ hfile
                     -1 ,                 \ hfileMapping
                      0 ,                 \ hfileAddress
                      0 ,                 \ hfileLength
                      0 ,                 \ hfileMaxLength
                      0 c, max-path allot \ hfileName
                does> ;


: map-field+    ( n1 n2 -<name>- n3 )
                ( a1 -- a2 )
                CREATE over + swap ,            nostack1
                DOES>  @ + ;

0   cell map-field+ >hfile
    cell map-field+ >hfileMapping
    cell map-field+ >hfileAddress
    cell map-field+ >hfileLength
    cell map-field+ >hfileMaxLength
max-path map-field+ >hfileName
drop

: create-file-map ( map-handle -- )
                dup >hfile @ -1 = abort" File must first be OPENED!"
                >r                      \               the file handle
                0                       \ *MapName      no name is specified
                r@ >hfileMaxLength @    \ MaxSizeLow    default or specified low size
                0                       \ MaxSizeHi     zero high part
                PAGE_READWRITE          \ fdwProtect    a read and writable file
                0                       \ psa           no security
                r@ >hfile @             \               the file handle
                Call CreateFileMapping r> >hfileMapping ! ;

: map-name      ( a1 n1 map-handle -- )
                >r 127 min r> >hfileName dup 128 erase place ;

: map-view-file ( map-handle -- )
                dup >hfileMapping @ -1 =
                abort" File must first be OPENED and MAPPED!"
                >r
                0                       \ amount of file to map=all of it
                0 0                     \ starting address of file
                FILE_MAP_WRITE
                r@ >hfileMapping @
                call MapViewOfFile ?dup 0=
                IF      Call GetLastError
                        cr ." Map-View Error: " . abort
                ELSE    r@ >hfileAddress !
                THEN    r>drop ;

: flush-view-file ( map-handle -- f1 )  \ flush the file to disk
                dup  >hfileLength  @
                swap >hfileAddress @
                Call FlushViewOfFile 0= ;

: unmap-view-file ( map-handle -- f1 )
                >hfileAddress @
                Call UnmapViewOfFile 0= ;

: close-map-file ( map-handle -- f1 )
                dup >hfile @ -1 =
                IF       drop 0
                ELSE       dup  unmap-view-file >r
                           dup  >hfileMapping @ call CloseHandle 0= >r
                        -1 over >hfileMapping !
                           dup  >hfile        @ call CloseHandle 0= >r
                        -1 swap >hfile        !
                        r> r> or r> or
                THEN    ;

: open-map-file ( a1 n1 map-handle -- f1 )
                >r
                r@ close-map-file drop
                r@ map-name
                r@ >hfileName count r/w open-file
                -IF     nip
                ELSE    swap    r@ >hfile !
                                r@ >hfile @ file-size 2drop
                                r@ >hfileLength !
                                r@ create-file-map
                                r@ map-view-file
                THEN    r>drop ;

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Shared memory functions
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: close-share   ( memory_pointer handle -- )
                call CloseHandle drop
                Call UnmapViewOfFile drop ;

0 value i-was-first

: open-share    ( z"name" length -- memory_pointer handle )
                FALSE to i-was-first
                over
                FALSE
                FILE_MAP_WRITE
                call OpenFileMapping ?dup 0=
                IF
                                           \ *MapName   no name is specified
                                           \ MaxSizeLow shared memory size
                        dup to i-was-first \ save size as a flag
                        0                  \ MaxSizeHi  zero high part
                        PAGE_READWRITE     \ fdwProtect a read and writable file
                        0                  \ psa        no security
                        -1                 \            the file handle
                        Call CreateFileMapping
                ELSE    nip nip
                THEN
                -IF      >r
                        0                  \ amount of file to map=all of it
                        0 0                \ starting offset into file
                        FILE_MAP_WRITE
                        r@ call MapViewOfFile ?dup 0=
                        IF      r> Call CloseHandle drop
                                0 FALSE
                        ELSE                \ -- mapped_address
                                i-was-first \ if first, erase buffer
                                IF      dup i-was-first erase
                                THEN
                                r>         \ -- mapped_address file_handle
                        THEN
                ELSE    drop 0 FALSE       \ failed, return failure flag
                THEN    ;

\s Test

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       simple memory file mapping example
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

map-handle ahndl

: mapfile       ( -<name>- -- a1 n1 )   \ map file name into memory
                /parse-word count ahndl open-map-file
                abort" Failed to open and map the file!"
                ahndl >hfileAddress @
                ahndl >hfileLength  @ ;

: unmapfile     ( -- )                  \ unmap and close the file
                ahndl close-map-file drop ;

: mapfile-test  ( -<name>- -- )
                cr ." mapfile-test:" cr
                mapfile 40 min dump unmapfile ;

mapfile-test src\lib\mapfile.f

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       shared memory example
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

0 value share-hndl
0 value share-ptr

: share         ( -- )
                z" SharedFile" 4096 open-share ?dup 0=
                abort" Failed to open shared memory"
                to share-hndl
                to share-ptr ;

: unshare       ( -- )
                share-ptr share-hndl close-share
                0 to share-ptr
                0 to share-hndl ;

: .share        ( -- )
                share-ptr 0= abort" Nothing shared!"
                share-ptr 40 dump ;

: share-test    ( -- )
                cr ." share-test:" cr
                share .share
                40 0 do i dup share-ptr + c! loop
                .share unshare ;

share-test

[Win32forth-cvs] win32forth-stc/src multithr.f, 1.2, NONE task.f, 1.4, NONE

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

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

Removed Files:
	multithr.f task.f 
Log Message:
gah:Moved task.f and multithr.f to lib folder

--- task.f DELETED ---

--- multithr.f DELETED ---

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

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

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

Added Files:
	multithr.f task.f 
Log Message:
gah:Moved task.f and multithr.f to lib folder

--- NEW FILE: task.f ---
\ $Id: task.f,v 1.1 2006/10/28 13:20:58 georgeahubert Exp $

\ task.f beta 5.01.0 14/03/2003 20:33:36 arm Callback changes to use assembler

cr .( Loading Task Support...)

\ *D doc
\ *! p-task W32F Task
\ *T Using the Task Wordset

\ *P The multi-tasker is not loaded in the system by default so the file TASK.F in the lib
\ ** folder should be included in any program that multi-tasks, unless using the file
\ ** MULTITHR.F (also in the lib folder) which includes it automatically.
\ *P Multi-tasking in Win32Forth is accomplished by using the Windows\_® \d multi-tasker.
\ ** This is a pre-emptive multi-tasker.

\ *S The Task Control Block

\ *P The task control block (also known as task-block or TCB) is a small structure either
\ ** alloted in the dictionary or allocated on the heap containing information about a task.
\ *B The xt and parameter variables are set when the task-block is created.
\ *B The stop flag can be set by other tasks and is used to signal the task that it has
\ ** been asked to finish.
\ *B The ID is set when the task is created and is valid only until the task terminates.
\ *B The handle is set when the task is created and is valid until it is closed by the
\ ** API CloseHandle function, even after the task has terminated. The operating system
\ ** does not free the OS resources allocated to a task until all handles (except for
\ ** the pseudohandle returned by the API GetCurrentThread) are closed and
\ ** the task has terminated. Programs should close the handle as soon as it's no longer
\ ** needed (if it's never used close it at the start of the task word).

\ *S The User Area

\ *P When a task is created the operating system allocates a stack for the task.
\ ** Win32Forth splits this stack into three regions, a return stack, a User area
\ ** and a data stack. The address of this User area is stored in thread local
\ ** storage so that callbacks have access to the correct User area for the task
\ ** (Versions prior to V6.05 always used the main task's User area for callbacks).
\ ** When a task starts the contents of the User area are undefined except
\ *B Base is set to decimal.
\ *B The exception handler is set so the task exits if an exception is thrown, returning
\ ** the error code to the operating system.
\ *B TCB is set to the task control block of the task.
\ *B RP0 is set to the base of the return stack.
\ *B SP0 is set to the base of the data stack.
\ *P All other User variables used by a task should be explicitly set before use.
\ ** If the task uses floating-point words then FINIT should be called first.

\ *S Glossary

\ -------------------- Task Control Block Offsets --------------------

cell checkstack
cell field+ task>parm     ( task-block -- addr )             \ W32F    Task
\ *G Convert the task-block address into the address of the thread parameter
cell field+ task>id       ( task-block -- addr )             \ W32F    Task
\ *G Convert the task-block address into the address of the thread id
cell field+ task>handle   ( task-block -- addr )             \ W32F    Task
\ *G Convert the task-block address into the address of the thread handle
cell field+ task>stop     ( task-block -- addr )             \ W32F    Task
\ *G Convert the task-block address into the address of the the stop flag
drop

: task>parm@    ( task-block -- parm )                       \ W32F    Task
\ *G Fetch the parameter from the task-block.
                task>parm @ ;

\ -------------------- Task Start Initialisation --------------------

1 proc ExitThread as exit-task     ( n -- )                  \ W32F    Task
\ *G Exit the current task returning the value n to the operating system, which can be retrieved
\ ** by calling GetExitCodeThread. The stacks and user area for the thread are freed and
\ ** DLLs are detatched. If the thread is the last active thread of the process then the
\ ** process is terminated.

: (task)        ( parm cfa -- )                 \ helper routine
                catch                           \ execute cfa and catch errors gah 27nov03
                exit-task                       \ and exit the thread, never returns
                ;

\ ===========================ITC ONLY=====================================================

\ cfa-code BEGIN-TASK ( -- )                      \ thread management. init a new thread/task
\                 push    ebp                     \ save regs
\                 push    ebx
\                 push    edi
\                 push    esi
\                 mov     ebp, esp
\                 call    TASK-ENTRY              \ setup stacks, error-handler etc (in kernel)
\                 mov     eax, 5 cells [ebp]      \ get task block
\                 mov     TCB [UP] , eax          \ save in TCB
\                 mov     ebx, 4 [eax]            \ parameter
\                 push    ebx                     \ save it
\                 mov     ebx, 0 [eax]            \ cfa = tos
\                 mov     eax, # ' (task)         \ get helper entry point
\                 exec    c;                      \ go do it
\
\ -------------------- Task Management  --------------------
\
\ : (create-task) ( thread state -- flag )        \ create a task
\                 swap                            \ state addr
\                 dup task>stop off               \ turn off stop flag
\                 dup>r                           \ put address of task on rstack
\                 task>id                         \ threadid pointer
\                 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
\                 r> task>handle !                \ save in threadid
\                 0<> ;                           \ and set the flag, true=ok

\ ===========================STC ONLY=====================================================

code begin-task ( -- )                          \ thread management. init a new thread/task
                push    ebp                     \ save regs
                push    ebx
                push    edi
                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;

\ -------------------- Task Management  --------------------

: (create-task) ( addr state -- flag )          \ create a task
                swap                            \ state addr
                dup task>stop off               \ turn off stop flag
                dup>r                           \ put address of task on rstack
                task>id                         \ threadid pointer
                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
                r> task>handle !                \ save in threadid
                0<> ;                           \ and set the flag, true=ok

\ ========================================================================================

: create-task   ( task-block -- flag )                       \ W32F    Task
\ *G Create a new task which is suspended. Flag is true if successful.
                CREATE_SUSPENDED (create-task) ;

: run-task      ( task-block -- flag )                       \ W32F    Task
\ *G Create a new task and run it. Flag is true if successful.
                0 (create-task) ;

: suspend-task  ( task-block -- flag )                       \ W32F    Task
\ *G Suspend a task. Flag is true if successful.
                task>handle @                   \ point at thread handle
                call SuspendThread -1 <> ;      \ true=0K

: resume-task   ( task-block -- flag )                       \ W32F    Task
\ *G Resume a task. Flag is true if successful.
                task>handle @                   \ point at thread handle
                call ResumeThread -1 <> ;       \ true=0K

: stop-task     ( task-block -- )                            \ W32F    Task
\ *G Set the stop flag of the task block to true.
                task>stop on ;                  \ stop flag

: task-sleep    ( n -- )                                     \ W32F    Task
\ *G Suspend the current task for at least n msec. If n is INFINITE (-1) the task is suspended
\ ** forever.
                call Sleep drop ;

: (task-block)  ( parm cfa-task addr -- len )                \ W32F    Task
\ *G Build a task block at the supplied address, initialise the parameter and xt and
\ ** return the size of the task block.
                dup>r !                         \ cfa
                r@ cell+ !                      \ parameter for the task
                r> 2 cells+ 0 over !            \ 0 threadid
                cell+ 0 over !                  \ thread handle
                cell+ 0 swap !                  \ flag
                5 cells
                ;

: task-block    ( parm cfa-task -- addr )                    \ W32F    Task
\ *G Build a task block in the dictionary, initialise the parameter and xt and return
\ ** the address of the block.
                here >r                         \ return this block's address
                ,                               \ cfa to execute as task
                ,                               \ parameter for task (extracted later)
                0 ,                             \ threadid
                0 ,                             \ thread handle
                0 ,                             \ stop flag
                r> ;                            \ return structure

: task-stop?    ( task-block -- flag )                       \ W32F    Task
\ *G Flag is true if stop-task has been set by another task. In this case the task should
\ ** do any necessary clean-up and exit.
                task>stop @ ;                   \ check, exit if stop set

\ -------------------- Task Lock Definitions --------------------

internal

variable lock-list lock-list off               \ list of locks gah

6 cells constant lock-size

external

\ *S Locking Resources

\ *P Since the multi-tasker is pre-emptive it is sometimes necessary to restrict access
\ ** to resources to a single task to prevent inteference between different tasks.
\ ** Win32Forth provides a set of words for efficiently locking sections of code.
\ ** The system also contains some locks used internally that are transparent to the user.

\ *S Glossary

: lock          ( lock -- )                                  \ W32F     Lock
\ *G If another thread owns the lock wait until it's free,
\ ** then if the lock is free claim it for this thread,
\ ** then increment the lock count.
                call EnterCriticalSection drop ;

: unlock        ( lock -- )                                  \ W32F     Lock
\ *G Decrement the lock count and free the lock if the resultant count is zero.
                call LeaveCriticalSection drop ;

winver winnt4 < [if]
\ sorry, TryEnterCriticalSection() is only avaible for NT4 and later !!!

: trylock       ( lock -- fl )
                lock true ;

internal

: init-lock     ( lock -- )
                call InitializeCriticalSection drop ;

[else]

: trylock       ( lock -- fl )                                \ W32F    Lock
\ *G \b For NT4, w2k and XP; \d
\ ** If the lock is owned by another thread return false. \n
\ ** If the lock is free claim it for this thread,
\ ** then increment the lock count and return true. \n
\ ** \b For Win9x, and NT<4; \d
\ ** Perform the action of LOCK and return true.
                call TryEnterCriticalSection 0<> ;

internal

: init-lock     ( lock -- )     \ Initialise a lock
                0 swap call InitializeCriticalSectionAndSpinCount drop ;

[then]

external

: (make-lock)   ( -- lock )                                   \ W32F    Lock
\ *G Make a new lock, and return it's identifier.
                here dup
                lock-size ( 6 cells ) allot
                lock-list link, \ add to list of locks
                init-lock \ Initialise the critical section
                ;

in-system

: make-lock     ( compiling: -<name>-  --  runtime: -- lock ) \ W32F    Lock
\ *G Create a new lock. When executed the lock returns it's identifier.
                create  (make-lock) drop ;

in-application

internal

: init-lock-from-list ( addr -- )  \ Initialise a lock given address of link
                lock-size - init-lock ;

: init-locks          ( -- )       \ Initialise all the locks
                ['] init-lock-from-list lock-list do-link ;

initialization-chain chain-add init-locks

\ -------------------- Task Specific Overrides --------------------
\ Memory locks, see kernel & primutil memory words. See also controls and generic for locking
\ of dialog linking and control subclasssing

make-lock mem-lock                      \ to make memory allocation thread safe
make-lock control-lock                  \ to make control subclassing thread safe
make-lock dialog-lock                   \ to make linking dialogs thread safe
make-lock classname-lock                \ to make unique window class naming thread safe
make-lock pointer-lock                  \ to make allocating pointers thread safe
make-lock dyn-lock                      \ to make new$ thread safe

: _memlock         ( -- )  mem-lock       lock   ;   \ for overriding defered lock memory word
: _memunlock       ( -- )  mem-lock       unlock ;   \ for overriding defered unlock memory word
: _controllock     ( -- )  control-lock   lock   ;   \ for overriding deferred lock subclassing word
: _controlunlock   ( -- )  control-lock   unlock ;   \ for overriding deferred unlock subclassing word
: _dialoglock      ( -- )  dialog-lock    lock   ;   \ for overriding deferred lock dialog linking word
: _dialogunlock    ( -- )  dialog-lock    unlock ;   \ for overriding deferred unlock dialog linking word
: _classnamelock   ( -- )  classname-lock lock   ;   \
: _classnameunlock ( -- )  classname-lock unlock ;
: _pointerlock     ( -- )  pointer-lock   lock   ;
: _pointerunlock   ( -- )  pointer-lock   unlock ;
: _dynlock         ( -- )  dyn-lock       lock   ;
: _dynunlock       ( -- )  dyn-lock       unlock ;


: init-system-locks  ( -- )                   \ initialize system locks for multitasking
               ['] _memlock         is (memlock)
               ['] _memunlock       is (memunlock)
               ['] _controllock     is (controllock)
               ['] _controlunlock   is (controlunlock)
               ['] _dialoglock      is (dialoglock)
               ['] _dialogunlock    is (dialogunlock)
               ['] _classnamelock   is (classnamelock)
               ['] _classnameunlock is (classnameunlock)
               ['] _pointerlock     is (pointerlock)
               ['] _pointerunlock   is (pointerunlock)
               ['] _dynlock         is (dynlock)
               ['] _dynunlock       is (dynunlock) ;

init-system-locks

initialization-chain chain-add init-system-locks
\s ========================STC DOESN'T HAVE FORGET YET====================================
\ -------------------- Forgetting Locks -----------------------------

\ *S WARNING
\ *P Before using FORGET or executing MARKER words unlock any locks which are
\ ** about to be forgotten to avoid memory leaks AND exit any threads which will be
\ ** forgotten to avoid \b CRASHING !! YOU HAVE BEEN WARNED \d

in-system

: delete-locks ( nfa link -- nfa )     \ delete lock if created after nfa
              2dup trim? if lock-size - call DeleteCriticalSection then drop ;

: trim-locks ( nfa -- nfa )
             ['] delete-locks lock-list do-link dup lock-list full-trim ;

forget-chain chain-add trim-locks

in-application

module

\ *Z

--- NEW FILE: multithr.f ---
\ $Id: multithr.f,v 1.1 2006/10/28 13:20:58 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/doc p-block.htm,1.1,1.2

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

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

Modified Files:
	p-block.htm 
Log Message:
gah:Updated docs

Index: p-block.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/doc/p-block.htm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** p-block.htm	17 Oct 2006 08:52:18 -0000	1.1
--- p-block.htm	28 Oct 2006 11:01:13 -0000	1.2
***************
*** 38,41 ****
--- 38,50 ----
  blockfile. <br />
  <b>&nbsp;NOTE </b>&nbsp;set-blockfile does not close the current blockfile.
+ </p><p>A sample block file BANNER.BLK has been included for your examination. <br />
+ type the following commands after loading BLOCK.F <br />
+ <br />
+ &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;OPEN-BLOCKFILE DEMOS\BANNER.BLK
+ &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;1 7 THRU
+ <br />
+ This will load and run a simple demo. <br />
+ <br />
+ Type DEMO again to run it again after it has been loaded.
  </p><h2>Glossary
  </h2><pre><b><a name="0">&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;1024 constant b/buf &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;\ W32F &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;Block extra

[Win32forth-cvs] win32forth/src/lib BLOCK.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-serv927/win32forth/src/lib

Modified Files:
	BLOCK.F 
Log Message:
gah:Updated docs

Index: BLOCK.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/BLOCK.F,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** BLOCK.F	17 Oct 2006 08:52:19 -0000	1.5
--- BLOCK.F	28 Oct 2006 10:58:58 -0000	1.6
***************
*** 28,41 ****
  \ ** \b NOTE \d set-blockfile does not close the current blockfile.
  
! \ A sample block file BANNER.BLK has been included for your examination.
! \
! \ type the following commands after loading BLOCK.F
! \
! \         OPEN-BLOCKFILE BANNER.BLK
! \         1 7 THRU
! \
! \ This will load and run a simple demo.
! \
! \ Type DEMO again to run it again after it has been loaded.
  
  only forth also definitions
--- 28,40 ----
  \ ** \b NOTE \d set-blockfile does not close the current blockfile.
  
! \ *P A sample block file BANNER.BLK has been included for your examination. \n
! \ ** type the following commands after loading BLOCK.F \n
! \ ** \n
! \ **         OPEN-BLOCKFILE DEMOS\BANNER.BLK
! \ **         1 7 THRU
! \ ** \n
! \ ** This will load and run a simple demo. \n
! \ ** \n
! \ ** Type DEMO again to run it again after it has been loaded.
  
  only forth also definitions

[Win32forth-cvs] win32forth/demos BANNER.BLK,NONE,1.1

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

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

Added Files:
	BANNER.BLK 
Log Message:
gah:Added Banner.blk demo

--- NEW FILE: BANNER.BLK ---
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \                                                               \ BANNER.SEQ    Compliments of F83X   mod to sequential by Tom Z                                                                CREATE CHAR-MATRIX              \ build the character generator HEX (  ) 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C,            ( !) 20 C, 20 C, 20 C, 20 C, 20 C, 00 C, 20 C, 00 C,            ( ") 50 C, 50 C, 50 C, 00 C, 00 C, 00 C, 00 C, 00 C,            ( #) 50 C, 50 C, F8 C, 50 C, F8 C, 50 C, 50 C, 00 C,            ( $) 20 C, 78 C, A0 C, 70 C, 28 C, F0 C, 20 C, 00 C,            ( %) C0 C, C8 C, 10 C, 20 C, 40 C, 98 C, 18 C, 00 C,            ( &) 40 C, A0 C, A0 C, 40 C, A8 C, 90 C, 68 C, 00 C,            ( ') 30 C, 30 C, 10 C, 20 C, 00 C, 00 C, 00 C, 00 C,            ( () 20 C, 40 C, 80 C, 80 C, 80 C, 40 C, 20 C, 00 C,            (  ) 20 C, 10 C, 08 C, 08 C, 08 C, 10 C, 20 C, 00 C,            ( *) 20 C, a8 C, 70 C, 20 C, 70 C, a8 C, 20 C, 00 C,                                                                        \                                                                   ( +) 00 C, 20 C, 20 C, 70 C, 20 C, 20 C, 00 C, 00 C,            ( ,) 00 C, 00 C, 00 C, 30 C, 30 C, 10 C, 20 C, 00 C,            ( -) 00 C, 00 C, 00 C, 70 C, 00 C, 00 C, 00 C, 00 C,            ( .) 00 C, 00 C, 00 C, 00 C, 00 C, 30 C, 30 C, 00 C,            ( /) 00 C, 08 C, 10 C, 20 C, 40 C, 80 C, 00 C, 00 C,            ( 0) 70 C, 88 C, 98 C, A8 C, C8 C, 88 C, 70 C, 00 C,            ( 1) 20 C, 60 C, 20 C, 20 C, 20 C, 20 C, 70 C, 00 C,            ( 2) 70 C, 88 C, 08 C, 30 C, 40 C, 80 C, F8 C, 00 C,            ( 3) F8 C, 10 C, 20 C, 30 C, 08 C, 88 C, 70 C, 00 C,            ( 4) 10 C, 30 C, 50 C, 90 C, F8 C, 10 C, 10 C, 00 C,            ( 5) F8 C, 80 C, F0 C, 08 C, 08 C, 88 C, 70 C, 00 C,            ( 6) 38 C, 40 C, 80 C, F0 C, 88 C, 88 C, 70 C, 00 C,            ( 7) F8 C, 08 C, 10 C, 20 C, 40 C, 40 C, 40 C, 00 C,            ( 8) 70 C, 88 C, 88 C, 70 C, 88 C, 88 C, 70 C, 00 C,                                                                        \                                                                   ( 9) 70 C, 88 C, 88 C, 78 C, 08 C, 10 C, E0 C, 00 C,            ( :) 00 C, 60 C, 60 C, 00 C, 60 C, 60 C, 00 C, 00 C,            ( ;) 00 C, 60 C, 60 C, 00 C, 60 C, 60 C, 40 C, 00 C,            ( <) 10 C, 20 C, 40 C, 80 C, 40 C, 20 C, 10 C, 00 C,            ( =) 00 C, 00 C, F8 C, 00 C, F8 C, 00 C, 00 C, 00 C,            ( >) 40 C, 20 C, 10 C, 08 C, 10 C, 20 C, 40 C, 00 C,            ( ?) 70 C, 88 C, 10 C, 20 C, 20 C, 00 C, 20 C, 00 C,            ( @) 70 C, 88 C, A8 C, B8 C, B0 C, 80 C, 78 C, 00 C,            ( A) 20 C, 70 C, 88 C, 88 C, F8 C, 88 C, 88 C, 00 C,            ( B) F0 C, 88 C, 88 C, F0 C, 88 C, 88 C, F0 C, 00 C,            ( C) 70 C, 88 C, 80 C, 80 C, 80 C, 88 C, 70 C, 00 C,            ( D) F0 C, 48 C, 48 C, 48 C, 48 C, 48 C, F0 C, 00 C,            ( E) F8 C, 80 C, 80 C, F0 C, 80 C, 80 C, F8 C, 00 C,            ( F) F8 C, 80 C, 80 C, F0 C, 80 C, 80 C, 80 C, 00 C,                                                                        \                                                                   ( G) 78 C, 80 C, 80 C, 80 C, 98 C, 88 C, 78 C, 00 C,            ( H) 88 C, 88 C, 88 C, F8 C, 88 C, 88 C, 88 C, 00 C,            ( I) 70 C, 20 C, 20 C, 20 C, 20 C, 20 C, 70 C, 00 C,            ( J) 08 C, 08 C, 08 C, 08 C, 08 C, 88 C, 78 C, 00 C,            ( K) 88 C, 90 C, A0 C, C0 C, A0 C, 90 C, 88 C, 00 C,            ( L) 80 C, 80 C, 80 C, 80 C, 80 C, 80 C, F8 C, 00 C,            ( M) 88 C, D8 C, A8 C, A8 C, 88 C, 88 C, 88 C, 00 C,            ( N) 88 C, 88 C, C8 C, A8 C, 98 C, 88 C, 88 C, 00 C,            ( O) 70 C, 88 C, 88 C, 88 C, 88 C, 88 C, 70 C, 00 C,            ( P) F0 C, 88 C, 88 C, F0 C, 80 C, 80 C, 80 C, 00 C,            ( Q) 70 C, 88 C, 88 C, 88 C, A8 C, 90 C, 68 C, 00 C,            ( R) F0 C, 88 C, 88 C, F0 C, A0 C, 90 C, 88 C, 00 C,            ( S) 70 C, 88 C, 80 C, 70 C, 08 C, 88 C, 70 C, 00 C,            ( T) F8 C, 20 C, 20 C, 20 C, 20 C, 20 C, 20 C, 00 C,                                                                        \                                                                   ( U) 88 C, 88 C, 88 C, 88 C, 88 C, 88 C, 70 C, 00 C,            ( V) 88 C, 88 C, 88 C, 88 C, 88 C, 50 C, 20 C, 00 C,            ( W) 88 C, 88 C, 88 C, A8 C, A8 C, D8 C, 88 C, 00 C,            ( X) 88 C, 88 C, 50 C, 20 C, 50 C, 88 C, 88 C, 00 C,            ( Y) 88 C, 88 C, 50 C, 20 C, 20 C, 20 C, 20 C, 00 C,            ( Z) F8 C, 08 C, 10 C, 20 C, 40 C, 80 C, F8 C, 00 C,            ( [) 78 C, 40 C, 40 C, 40 C, 40 C, 40 C, 78 C, 00 C,            ( \) 00 C, 80 C, 40 C, 20 C, 10 C, 08 C, 00 C, 00 C,            ( ]) F0 C, 10 C, 10 C, 10 C, 10 C, 10 C, F0 C, 00 C,            ( ^) 00 C, 00 C, 20 C, 50 C, 88 C, 00 C, 00 C, 00 C,            ( _) 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, 00 C, F8 C,                                                                        DECIMAL                                                         CREATE BITS     ( --- a1 )                                                      128 C, 64 C, 32 C, 16 C, 8 C, 4 C, 2 C, 1 C,    \                                                               : BIT           ( N1 --- F1 ) BITS + C@ AND 0= 1+ ;             : LC>UC         ( c -- )      DUP 96 128 WITHIN   32 AND - ;    : BANNER        ( a n -- )                                                      BOUNDS   8 0                                                    DO      CR      2DUP                                                   ?DO      I C@    127 AND LC>UC   32 -                                    8 *     CHAR-MATRIX +   J + C@                                  7 0                                                             DO      DUP I BIT                                                       IF      ASCII #                                                 ELSE    BL                                                      THEN    EMIT                                            LOOP DROP                                               LOOP                                                    LOOP    2DROP ;                                 \                                                               : DEMO          ( --- )         \ print demonstration message                   CLS CR                                                          s" WELCOME"     BANNER                                          s" TO FORTH"    BANNER                                          2 SECONDS                                                       CLS CR                                                          s" BANNER"      BANNER                                          s" PROGRAM"     BANNER                                          s" FROM F83X"   BANNER ;                        dbg DEMO                                                                                                                                                                                                                                                                                                                                                                                        

[Win32forth-cvs] win32forth-stc/src/lib BLOCK.F, NONE, 1.1 CTYPE.F, NONE, 1.1 ENUM.F, NONE, 1.1 SoundVolume.f, NONE, 1.1 array.f, NONE, 1.1 binsearch.f, NONE, 1.1

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

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

Added Files:
	BLOCK.F CTYPE.F ENUM.F SoundVolume.f array.f binsearch.f 
Log Message:
Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f

--- NEW FILE: CTYPE.F ---
\ $Id: CTYPE.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $

( ctype.f )
( C-ish ctype macros, rendered in FORTH )
( Placed in the public domain on 8aug96, by Jim Schneider )

\ August 9th, 1996 - 10:35 tjz slight modifications for Win32Forth

cr .( Loading C-ish ctype macros... )

anew -ctype.f

INTERNAL

in-application

0x01 constant ctype_upper         ( upper case letters )
0x02 constant ctype_lower         ( lower case letters )
0x04 constant ctype_digit         ( digit characters )
0x08 constant ctype_ws            ( white space )
0x10 constant ctype_punct         ( punctuation characters )
0x20 constant ctype_hex           ( hexadecimal digits )
0x40 constant ctype_control       ( control characters )
0x80 constant ctype_graph         ( is printable [ie., "graphic"] )

create ctype_array
0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x048 c, ( 0x00-0x07 )
0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x040 c, 0x040 c, ( 0x08-0x0f )
0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, ( 0x10-0x17 )
0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, ( 0x18-0x1f )
0x088 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x20-0x27 )
0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x28-0x2f )
0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, ( 0x30-0x37 )
0x0a4 c, 0x0a4 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x38-0x3f )
0x090 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x081 c, ( 0x40-0x47 )
0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, ( 0x48-0x4f )
0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, ( 0x50-0x57 )
0x081 c, 0x081 c, 0x081 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x58-0x5f )
0x090 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x082 c, ( 0x60-0x67 )
0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, ( 0x68-0x6f )
0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, ( 0x70-0x77 )
0x082 c, 0x082 c, 0x082 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x040 c, ( 0x78-0x7f )

: ctype@ ( n -- x )
        dup 0x7f > over 0< or if drop ctype_control else ctype_array + c@ then ;

EXTERNAL

: is-alpha ( n -- flag )
        ctype@ [ ctype_upper ctype_lower or ] literal and 0<> ;

: is-lower ( n -- flag )
        ctype@ ctype_lower and 0<> ;

: is-upper ( n -- flag )
        ctype@ ctype_upper and 0<> ;

: is-digit ( n -- flag )
        ctype@ ctype_digit and 0<> ;

: is-hex ( n -- flag )
        ctype@ ctype_hex and 0<> ;

: is-space ( n -- flag )
        ctype@ ctype_ws and 0<> ;

: is-forth-space ( n -- flag )
        ctype@ [ ctype_ws ctype_control or ] literal and 0<> ;

: is-punct ( n -- flag )
        ctype@ ctype_punct and 0<> ;

: is-alnum ( n -- flag )
        ctype@ [ ctype_upper ctype_lower ctype_digit or or ] literal and 0<> ;

: is-print ( n -- flag )
        ctype@ ctype_graph and 0<> ;

: is-graph ( n -- flag )
        ctype@ [ ctype_punct ctype_upper ctype_lower ctype_digit or or or ]
        literal and 0<> ;

: is-cntrl ( n -- flag )
        ctype@ ctype_control and 0<> ;

: tolower ( n -- n' )
        dup is-upper if [ char a char A - ] literal + then ;

: toupper ( n -- n' )
        dup is-lower if [ char A char a - ] literal + then ;

in-previous

MODULE

\s some test's

cr 'a' is-alpha [if] .( ok ) [else] .( error ) [then]
cr '1' is-alpha [if] .( error ) [else] .( ok ) [then]

cr '1' is-digit [if] .( ok ) [else] .( error ) [then]
cr 'a' is-digit [if] .( error ) [else] .( ok ) [then]

cr 'a' is-lower [if] .( ok ) [else] .( error ) [then]
cr 'A' is-lower [if] .( error ) [else] .( ok ) [then]

cr 'A' is-upper [if] .( ok ) [else] .( error ) [then]
cr 'a' is-upper [if] .( error ) [else] .( ok ) [then]

cr 'a' toupper is-upper [if] .( ok ) [else] .( error ) [then]
cr 'A' tolower is-lower [if] .( ok ) [else] .( error ) [then]


--- NEW FILE: ENUM.F ---
\ $Id: ENUM.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $

anew -enum.f

in-system

internal

: not-a-comment?	( addr cnt -- f )
                2dup s" \" compare 0<> -rot  \ not a \ comment ?
                     s" //" compare 0<>  and \ not a // comment
		;

external

1 value enum-increment
\ *G Increment for \i enums \d.
\ ** Note: In the Win32Forth Version 6.xx this value was called \i increment \d
\ ** and it was in the \i HIDDEN \d directory.

100 value enum-value
\ *G Start value for \i enums \d.

: enum: ( -- )
\ *G Create a list of constants until terminating ;
\ ** Note \i enum: \d will set \i enum-increment \d to 1 after executing.
        begin   begin   >in @ bl word swap >in ! c@ 0=
                while   refill 0=                           \ get more stuff
                        abort" Enum: - missing terminating ;"
                repeat  >in @ bl word
                count s" ;" compare     \ done enumerating if ; found
        while   dup >in ! bl word count
                2dup not-a-comment?
                if      number? 			\ if a number
			if	drop Constant		\ allow setting specific value
				drop	( >in )
			else	2drop 	( from number? )
				>in ! enum-value Constant       \ create a constant value
				enum-increment +to enum-value
                        then
                else    2drop >in ! interpret                 \ is a comment
                then
        repeat  drop 1 to enum-increment ;    \ restore default

in-previous

module

\s Test

0 to enum-value         \ set start value
2 to enum-increment     \ set increment
enum:   foo1            \ create the constant's
        foo2
        foo3 ;

cr foo1 .
cr foo2 .
cr foo3 .

--- NEW FILE: binsearch.f ---
\ $Id: binsearch.f,v 1.1 2006/10/28 09:07:08 dbu_de Exp $
\
\ Binary Search by Charles Melice

cr .( Loading Binary Search... )

anew -binsearch.f

internal
external

DEFER GET-KEY    ( index array -- key )
\ *G \i array \d sorted array of anything. \n
\ ** \i index \d index \n
\ ** \i key \d the value at array[index]

DEFER B-COMPARE  ( key1 key2 -- result )
\ *G if key1 < key2, return -1 \n
\ ** if key1 > key2, return +1 \n
\ ** else return 0.

: BSEARCH       ( key array count -- index flag )
\ *G When the key is not found, returns the position of the nearest greater key.
\ ** Can be used to insert a new key in the sorted array.
\ **
\ ** \i count \d count of elements in array. \n
\ ** \i array \d SORTED array of anything. \n
\ ** \i key \d the key we are searching for. \n
\ ** \i flag \d TRUE if key was found. \n
\ ** \i index \d effective else virtual key position in array. \n
                1- 0 0 LOCALS| mid lo hi array key |
        BEGIN   lo hi <= WHILE
                lo hi + 2/ TO mid
                key mid array GET-KEY B-COMPARE
                CASE   -1 OF  mid 1- TO hi   ENDOF
                        1 OF  mid 1+ TO lo   ENDOF
                        0 OF  mid TRUE EXIT  ENDOF
                ENDCASE
        REPEAT  lo hi MAX \ this computes the insertion point
                FALSE ;

\ A non-local version by Wil Baden.
\ : UNDER       ( x y z -- z y )
\                 ROT DROP  SWAP ;
\
\ : BSEARCH     ( key array count -- index flag )
\                 SWAP >R                        ( key count)( R: array)
\                 0 SWAP                         ( key lo hi)
\
\                 BEGIN  2dup < WHILE
\                     3dup +  2/  TUCK           ( . . . mid key mid)
\                     R@ GET-KEY B-COMPARE       ( . . . mid flag)
\                     0> IF  1+ UNDER               \  mid 1+ to lo
\                     ELSE   NIP                    \  mid to hi
\                     THEN
\                 REPEAT                         ( key lo hi)
\
\                 NIP TUCK                       ( index key index)
\                 R> GET-KEY B-COMPARE 0= ;

module

\s Test.

nostack

create array
    here
    0 , 3 , 12 , 23 , 45 , 66 , 88 ,
    here swap - cell / constant NELEM

:noname  ( a b -- res )
    2dup > If 2drop 1 Exit Then < ; IS B-COMPARE

:noname ( index array -- key )
    swap cells + @ ; IS GET-KEY

: TEST  ( key -- )
    array NELEM bsearch cr
    IF ." FOUND = " ELSE ." NOT FOUND, insert = " THEN . cr ;

checkstack

cr 12 test
cr 13 test


--- NEW FILE: SoundVolume.f ---
\ SoundVolume.f
\
\ Written: by Dirk Busch
\ Licence: Public Domain

anew -SoundVolume.f

library winmm.dll

internal
external

\ -----------------------------------------------------------------------------
\ Turn the sound on and off
\ -----------------------------------------------------------------------------

: volume!       ( left-sound-volume right-sound-volume -- )     \ W32F  sound
\ *G Set the volume level of the waveform-audio output device.
        depth 2 >=
        if 0max 99 min 65535 100 */ 65536 * swap
           0max 99 min 65535 100 */ +
           0 Call waveOutSetVolume drop
        else cr ." No enough parameters !!! "
        then ;

: volume@       ( -- left-sound-volume right-sound-volume )     \ W32F  sound
\ *G Retrieves the current volume level of the waveform-audio output device.
        { \ sound-volume --  }
        &of sound-volume 0 call waveOutGetVolume MMSYSERR_NOERROR =
        if   sound-volume word-split
        else 0 0
        then ;

: sound?        ( -- f )        \ W32F  sound
\ *G Check if sound is on.
        volume@ 0> swap 0> or ;

internal

0 value volume-left
0 value volume-right

external

: SoundOn       ( -- )          \ W32F  sound
\ *G Turn the sound back on after turning it off.
        sound? 0=
        if   volume-left volume-right volume!
             0 to volume-right 0 to volume-left
        then ;

: SoundOff      ( -- )          \ W32F  sound
\ *G Turn sound off.
        sound?
        if   volume@ to volume-right to volume-left
             0 0 volume!
        then ;

: SoundOnOff    ( -- )          \ W32F  sound
\ *G Toggle sound
        sound? 0=
        if   SoundOn
        else SoundOff
        then ;

module

\ *Z

--- NEW FILE: array.f ---
\ $Id: array.f,v 1.1 2006/10/28 09:07:08 dbu_de Exp $

cr .( Loading Array words... )

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ One dimensional Array words - Indices are counted from zero.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

anew -array.f

internal
external

in-application

: byte-array    ( n1 -<name>- )         \ compile time
                ( -- a1 )               \ runtime
                create 1+ reserve ;

: word-array    ( n1 -<name>- )         \ compile time
                ( -- a1 )               \ runtime
                create 1+ 2* reserve ;

: long-array    ( n1 -<name>- )         \ compile time
                ( -- a1 )               \ runtime
                create 1+ cells reserve ;

: double-array  ( n1 -<name>- )         \ compile time
                ( -- a1 )               \ runtime
                create 1+ 2* cells reserve ;

: #byte-array   ( n1 -<name>- )         \ compile time          8-bits
                ( n1 -- byte )          \ runtime
                create 1+ reserve
                does> + c@ ;

: ^#byte-array  ( a1 -<name>- )         \ compile time          8-bits
                ( n1 -- byte )          \ runtime
                create ,
                does> @ + c@ ;

: #word-array   ( n1 -<name>- )         \ compile time          16-bits
                ( n1 -- word )          \ runtime
                create 1+ 2* reserve
                does> swap 2* + w@ ;

: ^#word-array  ( n1 -<name>- )         \ compile time          16-bits
                ( n1 -- word )          \ runtime
                create ,
                does> @ swap 2* + w@ ;

: #long-array   ( n1 -<name>- )         \ compile time          32-bits
                ( n1 -- long )          \ runtime
                create 1+ cells reserve
                does> swap cells+ @ ;

: ^#long-array  ( a1 -<name>- )         \ compile time          32-bits
                ( n1 -- long )          \ runtime
                create ,
                does> @ swap cells+ @ ;

: #double-array ( n1 -<name>- )         \ compile time          2 x 32-bits
                ( n1 -- long )          \ runtime
                create 1+ 2* cells reserve
                does> swap 2* cells+ 2@ ;

: ^#double-array ( a1 -<name>- )        \ compile time          2 x 32-bits
                ( n1 -- long )          \ runtime
                create ,
                does> @ swap 2* cells+ 2@ ;

in-system

: b#->          ( n1 n2 -<name>- )      \ store byte n1 into element n2
                                        \ of byte array
                ' >body state @
                if      POSTPONE literal
                        POSTPONE +
                        POSTPONE c!
                else    + c!
                then    ; immediate

: b#+>          ( n1 n2 -<name>- )      \ store byte n1 into element n2
                                        \ of byte array
                ' >body state @
                if      POSTPONE literal
                        POSTPONE +
                        POSTPONE c+!
                else    + c+!
                then    ; immediate

: w#->          ( n1 n2 -<name>- )      \ store word n1 into element n2
                                        \ of word array
                ' >body state @
                if      POSTPONE 2*
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE w!
                else    swap 2* + w!
                then    ; immediate

: w#+>          ( n1 n2 -<name>- )      \ store word n1 into element n2
                                        \ of word array
                ' >body state @
                if      POSTPONE 2*
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE w+!
                else    swap 2* + w+!
                then    ; immediate

: l#->          ( n1 n2 -<name>- )      \ store long n1 into element n2
                                        \ of long array
                ' >body state @
                if      POSTPONE cells
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE !
                else    swap cells+ !
                then    ; immediate

: l#+>          ( n1 n2 -<name>- )      \ store long n1 into element n2
                                        \ of long array
                ' >body state @
                if      POSTPONE cells
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE +!
                else    swap cells+ +!
                then    ; immediate

: d#->          ( n1 n2 -<name>- )      \ store long n1 into element n2
                                        \ of double array
                ' >body state @
                if      POSTPONE 2*
                        POSTPONE cells
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE 2!
                else    swap 2* cells+ 2!
                then    ; immediate

: d#+>          ( n1 n2 -<name>- )      \ store long n1 into element n2
                                        \ of double array
                ' >body state @
                if      POSTPONE 2*
                        POSTPONE cells
                        POSTPONE literal
                        POSTPONE +
                        POSTPONE 2+!
                else    swap 2* cells+ 2+!
                then    ; immediate

in-application

module


--- NEW FILE: BLOCK.F ---
\ $Id: BLOCK.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $
\ BLOCK.F       Tom's Forth virtual block system.       by Tom Zimmer

cr .( Loading BLOCK...)

\ *D doc
\ *! p-block W32F block
\ *T Using the Block Wordset

\ *P Win32Forth implements a virtual block system, based on the ANSI standard Block
\ ** and Block extension wordsets. \n
\ ** The block words are not loaded by default and have to be included. The file
\ ** BLOCK.F is in the lib folder (some older versions of W32F placed it in the extras
\ ** folder). \n
\ ** The constants B/BUF, and #BUFFERS control the block size, and the number of
\ ** buffers the system uses.  These are defaulted to 1024 byte blocks, and
\ ** 8 buffers.  A true LRU (least recently used) buffer allocation mechanism
\ ** is used, implemented as a bubble up buffer stack.  The least recently used
\ ** buffer is always on the bottom of the stack.  As buffers are used or
\ ** re-used, they are bubbled immediately up to the top of the stack, destined
\ ** to settle to the bottom of the stack if the same record is not accessed
\ ** again. \n Blocks are stored in a blockfile (normally with the .blk extension,
\ ** although some forths use .fb) which is set by the words set-blockfile,
\ ** open-blockfile or create-blockfile and closed by close-blockfile. Only one
\ ** blockfile is active at any one time, open-blockfile and create-blockfile
\ ** automatically close the current one prior to setting themselves as the current
\ ** blockfile. \n
\ ** \b NOTE \d set-blockfile does not close the current blockfile.

\ *P A sample block file BANNER.BLK has been included for your examination. \n
\ ** type the following commands after loading BLOCK.F \n
\ ** \n
\ **         OPEN-BLOCKFILE DEMOS\BANNER.BLK
\ **         1 7 THRU
\ ** \n
\ ** This will load and run a simple demo. \n
\ ** \n
\ ** Type DEMO again to run it again after it has been loaded.

only forth also definitions

IN-APPLICATION

\ needs 486asm.f                        \ load assembler if needed

\ *S Glossary

        1024 constant b/buf                    \ W32F         Block extra
\ *G Length of each block.
          64 constant c/l                      \ W32F         Block extra
\ *G Number of characters per line.
           8 constant #buffers                 \ W32F         Block extra
\ *G Number of block buffers.
          -1    value blockhandle              \ W32F         Block extra
\ *G The handle of the current block file, or -1 if no current block file.

variable blk        ( -- a-addr )              \ ANSI         Block
\ *G a-addr is the address of a cell containing zero or the number of the mass-storage
\ ** block being interpreted. If BLK contains zero, the input source is not a block
\ ** and can be identified by SOURCE-ID, if SOURCE-ID is available. An ambiguous
\ ** condition exists if a program directly alters the contents of BLK.
variable scr        ( -- a-addr )              \ ANSI         Block ext
\ *G a-addr is the address of a cell containing the block number of the block most
\ ** recently listed.

INTERNAL                                \ internal definitions

variable cur_buffer#                    \ current buffer # of current block
         cur_buffer# off

#buffers cells constant buflen

variable rec_array b/buf #buffers  * allot      \ an array of blocks
variable rec#s            buflen     allot      \ block # array
variable rec#updt         buflen     allot      \ Update flags
variable rec#use          buflen     allot      \ block bubbleup stack
variable rec#fil          buflen     allot      \ hcb for each block

                                        \ n1 = buffer number
                                        \ a1 = address of buffer
: buf#>bufaddr  ( n1 --- a1 )         \ Calculate address a1 of buffer n1.
        b/buf * rec_array + ;

                                        \ n1 = buffer number
                                        \ a1 = buffer address
: >rec#s        ( n1 --- a1 )           \ return the buffer n1's record addr
        rec#s +cells ;

                                        \ n1 = buffer number
                                        \ a1 = buffer address
: >rec#updt     ( n1 --- a1 )           \ return the buffer n1's update addr
        rec#updt +cells ;

                                        \ n1 = buffer number
                                        \ a1 = buffer address
: >rec#fil      ( n1 --- a1 )           \ return the buffer n1's file addr
        rec#fil +cells ;

: chkfil        ( n1 --- n1 f1 )        \ verify file in bufer n1 is current
        dup dup 8 =
        if      drop false exit
        else    >rec#fil @ blockhandle =
        then    ;

: bubbleup      ( n1 --- )              \ move buffer # n1 to end of list
        >r rec#use #buffers r@ lscan dup 0=
        abort" Buffer# number not in buffer list"
        1- cells >r dup cell+ swap r> move  \ move list down except first
        r> rec#use buflen + cell - ! ;      \ stuff first at end of list.

                                        \ n1 = block we are looking for
                                        \ n2 = buffer #
                                        \ f1 = do we have it?, true if we do
: ?gotrec       ( n1 --- <n2> f1 )      \ Do we have block n1 in memory?
        rec#s #buffers rot lscan nip
        #buffers swap - ( tos is buffer # with matching block #)
        chkfil
        if      true
        else    drop false
        then    ;
                                        \ n1 = block to positon to
: pos_block    ( n1 --- )               \ Set file pointer to block pos n1
        0max b/buf * 0 blockhandle reposition-file drop ;

                                        \ a1 = destination address of read
                                        \ n1 = block number to read
: read_block    ( a1 n1 --- )           \ read block n1 to address a1
        pos_block
        b/buf blockhandle read-file swap b/buf <> or
        abort" Error reading block" ;

                                        \ n1 = buffer number
                                        \ n2 = block number to write
: write_block  ( n1 n2 --- )            \ write block n1 to disk
        pos_block
        dup buf#>bufaddr
        b/buf rot >rec#fil @ write-file
        abort" Error writing block, probably out of disk space." ;

EXTERNAL        \ externally available definitions

                                \ u = block #
                                \ a-addr = bufadr
: save-buffers      ( -- )                     \ ANSI         Block
\ *G Transfer the contents of each updated block buffer to mass storage.
\ ** Mark all buffers as unmodified.
        #buffers 0                              \ through all the buffers
        do      rec#use @ >r                    \ find a buffer
                r@ bubbleup                     \ bump to highest priority
                r@ cur_buffer# !                \ set current buffer var
                r@ >rec#updt dup @              \ check update flag
                if      off                     \ clear update flag
                        r@ dup >rec#s @         \ get block #
                        write_block             \ write it
                else    drop                    \ discard, already cleared
                then    r>drop
        loop    ;

: buffer            ( u -- a-addr )            \ ANSI         Block
\ *G a-addr is the address of the first character of the block buffer assigned to block u.
\ ** The contents of the block are unspecified. An ambiguous condition exists if u is not
\ ** an available block number. \n
\ ** If block u is already in a block buffer, a-addr is the address of that block buffer. \n
\ ** If block u is not already in memory and there is an unassigned buffer, a-addr is the
\ ** address of that block buffer. \n
\ ** If block u is not already in memory and there are no unassigned block buffers,
\ ** unassign a block buffer. If the block in that buffer has been UPDATEd, transfer
\ ** the block to mass storage. a-addr is the address of that block buffer.
\ ** At the conclusion of the operation, the block buffer pointed to by a-addr is
\ ** the current block buffer and is assigned to u.
        dup ?gotrec                     \ check if already present
        if      >r drop                 \ buffer already assigned, save it
        else
                rec#use @ >r                 \ assign LRU buffer
                r@ >rec#updt dup @           \ check update flag
                if      off                  \ clear update flag
                        r@ dup >rec#s @      \ get block #
                        write_block          \ write it
                else    drop                 \ discard, already cleared
                then
                r@ >rec#s   !        \ set block #
                blockhandle r@ >rec#fil !    \ set the file hcb
        then
        r@ bubbleup                     \ bump to highest priority
        r@ cur_buffer# !                \ set current buffer var
        r> buf#>bufaddr ;               \ calc buffer addr

: empty-buffers     ( -- )                     \ ANSI         Block ext
\ *G Unassign all block buffers. Do not transfer the contents of any updated
\ ** block buffer to mass storage.
        rec_array b/buf #buffers * erase
        rec#s    buflen -1 fill
        rec#updt buflen erase
        rec#fil  buflen erase
        rec#use  #buffers 0
        do      i over ! cell+     \ initialize the bubbleup stack
        loop
        drop ;

: flush             ( -- )                     \ ANSI         Block
\ *G Perform the function of SAVE-BUFFERS, then unassign all block buffers.
        save-buffers
        empty-buffers ;

: update            ( -- )                     \ ANSI         Block
\ *G Mark the current block buffer as modified. An ambiguous condition exists if there
\ ** is no current block buffer. \n
\ ** Update does not write the block to the disc.
        cur_buffer# @ >rec#updt on ;

                                       \ u = block # to get
                                       \ a-addr is address of block # u
: block             ( u -- a-addr )            \ ANSI         Block
\ *G a-addr is the address of the first character of the block buffer assigned to
\ ** mass-storage block u. An ambiguous condition exists if u is not an available
\ ** block number. \n
\ ** If block u is already in a block buffer, a-addr is the address of that block buffer.  \n
\ ** If block u is not already in memory and there is an unassigned block buffer,
\ ** transfer block u from mass storage to an unassigned block buffer. a-addr is
\ ** the address of that block buffer. \n
\ ** If block u is not already in memory and there are no unassigned block buffers, unassign
\ ** a block buffer. If the block in that buffer has been UPDATEd, transfer the block to
\ ** mass storage and transfer block u from mass storage into that buffer. a-addr is the
\ ** address of that block buffer. \n
\ ** At the conclusion of the operation, the block buffer pointed to by a-addr is the
\ ** current block buffer and is assigned to u.
        dup ?gotrec
        if      nip dup >r buf#>bufaddr
                r@ cur_buffer# ! r> bubbleup
        else    blockhandle 0< abort" No file open"
                dup buffer dup rot read_block
        then    ;

: list              ( u -- )                   \ ANSI         Block ext
\ *G Display block u in the console in a 16 line format. Store u in SCR. \n
\ ** An error occurs if u is greater than the number of blocks in the current blockfile.
        dup scr !
        block b/buf bounds
        do      cr i c/l type
        c/l +loop    ;

: wipe              ( u -- )                   \ W32F         Block extra
\ *G Erase the specified block to blanks.
        buffer b/buf blank update ;

: set-blockfile     ( fileid -- )              \ W32F         Block extra
\ *G Make fileid the current blockfile.
        to blockhandle ;

\ ----------------------------------------------------------------
\ The following words add capabities for dealing with blocks.
\ See the documentation for what they do.
\ ----------------------------------------------------------------

warning off

: evaluate      ( a1 n1 -- )
        blk off evaluate ;

: save-input    ( -- xxx 8 )
        save-input
        blk @ swap 1+ ;

: restore-input ( xxx 8 -- f1 )
        swap blk ! 1-
        restore-input >r
        blk @ 0>
        if      blk @ block b/buf (source) 2! \ force back to block
        then    r> ;

: refill        ( -- f1 )
        blk @ 0=
        if      refill
        else    >in off
                blockhandle to source-id \ ?loading on
                blk @ 1+ b/buf block (source) 2!
                true
        then    ;

: \     ( -- )
        blk @ 0=
        if      postpone \
        else    >in @ c/l / 1+ c/l * >in !
        then    ; immediate

warning on

: blkmessage    ( n1 -- )
        blk @ 0>
        if      base @ >r
                cr ." Error: " pocket count type space
                dup -2 =
                if      drop msg @ count type
                else    ." Error # " .
                then
                cr ." Block: " blk @ .
                ." at Line: " >in @ c/l / .
                cr blk @ block >in @ c/l / c/l * + c/l type
                blk off   \ reset BLK cause noone else does!!!
                r> base !
        else    _message
        then    ;

' blkmessage is message

\ ----------------------------------------------------------------
\ -------- End of extended capabilities --------------------------
\ ----------------------------------------------------------------

: load              ( i*x u -- j*x )           \ ANSI         Block
\ *G Save the current input-source specification. Store u in BLK (thus making block
\ ** u the input source and setting the input buffer to encompass its contents), set
\ ** >IN to zero, and interpret. When the parse area is exhausted, restore the prior
\ ** input source specification. Other stack effects are due to the words LOADed.
\ ** An ambiguous condition exists if u is zero or is not a valid block number.
        { loadblk \ incntr outcntr -- }
        save-input dup 1+ dup to incntr
                              to outcntr
        begin  >r -1 +to incntr  incntr  0= until
        loadblk blk !
        >in off
        blockhandle to source-id \ ?loading on
        blk @ block b/buf (source) 2!
        interpret
        begin  r> -1 +to outcntr outcntr 0= until
        restore-input drop ;

: thru              ( i*x u1 u2 -- j*x )       \ ANSI         Block ext
\ *G LOAD the mass storage blocks numbered u1 through u2 in sequence. Other stack
\ ** effects are due to the words LOADed.
        1+ swap
        ?do     i load
        loop    ;

: close-blockfile   ( -- )                     \ W32F         Block extra
\ *G Close the current blockfile, flushing any updated buffers. Set the current blockfile
\ ** to no file.
        blockhandle -1 <>
        if      flush
                blockhandle      \ Roderick Mcban - February 11th, 2002
                close-file drop
        then    -1 to blockhandle ;

: open-blockfile    ( "<spaces>'filename'" )   \ W32F         Block extra
\ *G Close the current blockfile. Open the file and make it the current block file.
        close-blockfile
        /parse-word count r/w open-file abort" Failed to open Block File"
        set-blockfile
        empty-buffers ;

: create-blockfile  ( u "<spaces>'filename'" ) \ W32F         Block extra
\ *G Close the current blockfile. Create a file of u blocks long, initialise the
\ ** blocks to blanks and make it the current blockfile.
        close-blockfile
        /parse-word count r/w create-file
        abort" Failed to create Block File"
        set-blockfile
        dup b/buf m* blockhandle resize-file
        abort" Unable to create a file of that size"
        empty-buffers
        0
        do      i wipe
        loop
        flush ;

: #blocks           ( -- u )                   \ W32F         Block extra
\ *G u is the number of blocks in the current blockfile.
        blockhandle file-size drop b/buf um/mod nip ;

\ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
\ initialization of the block system
\ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

empty-buffers           \ Initialize the virtual memory arrays interpretively

INTERNAL        \ another internal definitions

: virtual-init  ( --- ) \ and during the system startup initialization
        -1 to blockhandle
        empty-buffers ;

initialization-chain chain-add virtual-init

MODULE          \ end of the module

get-current checkstack also environment definitions

true constant BLOCK
true constant BLOCK-EXT

previous set-current

\ *Z

[Win32forth-cvs] win32forth-stc gkernel.exe,1.22,1.23

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

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

Modified Files:
	gkernel.exe 
Log Message:
Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.22
retrieving revision 1.23
diff -C2 -d -r1.22 -r1.23
Binary files /tmp/cvsj5LiJA and /tmp/cvsyr5Yuu differ

[Win32forth-cvs] win32forth-stc/src extend.f, 1.13, 1.14 optinline.f, 1.3, 1.4 optliterals.f, 1.4, 1.5 primutil.f, 1.13, 1.14

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

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

Modified Files:
	extend.f optinline.f optliterals.f primutil.f 
Log Message:
Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** primutil.f	25 Oct 2006 10:13:32 -0000	1.13
--- primutil.f	28 Oct 2006 09:07:08 -0000	1.14
***************
*** 13,17 ****
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk.yahoo @ schneider-busch.de)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
--- 13,17 ----
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk at win32forth.org)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
***************
*** 42,53 ****
  in-application
  
! : NOSTACK1                      ; immediate     \ *** to be done ***
! : DEPRECATED                    ; immediate     \ *** to be done ***
  : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
! : DPR-WARNING-ON                ; immediate     \ *** to be done ***
! : DPR-WARNING-OFF               ; immediate     \ *** to be done ***
! 0 value DPR-WARNING?            \ null value      *** to be done ***
  : CHECKSTACK                    ; immediate     \ *** to be done ***
  
  \ ------------------------------------------------------------------------
--- 42,59 ----
  in-application
  
! 0 value DPR-WARNING?            \ null value      *** to be done ***
! 
! in-system
! 
  : ANEW          BL WORD DROP    ; immediate     \ *** to be done ***
  : IS-DEFAULT    BL WORD 2DROP   ; immediate     \ *** to be done ***
! : DEPRECATED                    ; immediate     \ *** to be done ***
! : DPR-WARNING-ON  1 to DPR-WARNING? ; immediate \ *** to be done ***
! : DPR-WARNING-OFF 0 to DPR-WARNING? ; immediate \ *** to be done ***
! : NOSTACK                       ; immediate     \ *** to be done ***
! : NOSTACK1                      ; immediate     \ *** to be done ***
  : CHECKSTACK                    ; immediate     \ *** to be done ***
+ : dbg ' execute                 ; immediate     \ *** to be done ***
+ : ?COMP                         ; immediate     \ *** to be done ***
  
  \ ------------------------------------------------------------------------
***************
*** 100,103 ****
--- 106,112 ----
                  does> 2@ ;
  
+ : 2+!           ( d1 a1 -- )            \ double accumulate
+                 dup>r 2@ d+ r> 2! ;
+ 
  ' dpl       alias dp-location
  ' postpone  alias compile
***************
*** 120,123 ****
--- 129,136 ----
                  over offset + ;
  
+ : ascii    char          state @ if postpone literal then ; immediate
+ : alt      char 4096  or state @ if postpone literal then ; immediate
+ : ctrl     char   31 and state @ if postpone literal then ; immediate
+ 
  \ ------------------------------------------------------------------------
  \ -------------------------- Chain definitions ---------------------------
***************
*** 153,157 ****
                  reset-stack-chain do-chain ; is reset-stacks \ install in kernel word
  
! \ ---------------- Operating System Checking --------------------------
  
  1 PROC GetVersionEx
--- 166,172 ----
                  reset-stack-chain do-chain ; is reset-stacks \ install in kernel word
  
! \ ------------------------------------------------------------------------
! \ ---------------- Operating System Checking -----------------------------
! \ ------------------------------------------------------------------------
  
  1 PROC GetVersionEx
***************
*** 207,215 ****
  winver-init
  
- in-system
- 
  \ ------------------------------------------------------------------------
  \ ------------------------------------------------------------------------
  
  : (viewinfo)    ( nfa -- line# addr )
  \ *G Find source for word.
--- 222,230 ----
  winver-init
  
  \ ------------------------------------------------------------------------
  \ ------------------------------------------------------------------------
  
+ in-system
+ 
  : (viewinfo)    ( nfa -- line# addr )
  \ *G Find source for word.
***************
*** 231,234 ****
--- 246,250 ----
  
  \ ------------------------------------------------------------------------
+ \ Conditional compiling
  \ ------------------------------------------------------------------------
  
***************
*** 255,263 ****
  in-application
  
! \ needed by ansfile.
  
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \       Some case insensitive version of search and compare
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
  \ enhanced caps-search for source string > 255 bytes
--- 271,289 ----
  in-application
  
! \ ------------------------------------------------------------------------
! \ Some memory allocation words...
! \ ------------------------------------------------------------------------
  
! \ needed by array.f
! 
! : reserve     ( n1 )
! \ *G Allot some bytes initialized to NULL.
!                 0max here over allot swap erase ;
! 
! \ ------------------------------------------------------------------------
  \       Some case insensitive version of search and compare
! \ ------------------------------------------------------------------------
! 
! \ needed by ansfile.f
  
  \ enhanced caps-search for source string > 255 bytes
***************
*** 301,307 ****
                  st1 count st2 count compare ;
  
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \       Locking for Windows
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
  defer (controllock)
--- 327,333 ----
                  st1 count st2 count compare ;
  
! \ ------------------------------------------------------------------------
  \       Locking for Windows
! \ ------------------------------------------------------------------------
  
  defer (controllock)
***************
*** 336,339 ****
--- 362,389 ----
  initialization-chain chain-add init-system-locks-off
  
+ \ ------------------------------------------------------------------------
+ \  Delay Time Words
+ \ ------------------------------------------------------------------------
+ 
+ \ DEFER MS        ( n1 -- )
+ \ *G Delay n1 milli-seconds or forever if n1 = -1.
+ 
+ :noname         ( n1 -- )
+                 call Sleep drop ; is MS
+ 
+ : SECONDS       ( n1 -- )
+ \ *G Delay n1 seconds break when a key is pressed.
+                 0max 0
+                 ?do  10 0
+                      do   100 ms
+                           key?
+                           if   key drop
+                                unloop
+                                unloop
+                                EXIT
+                           then
+                      loop
+                 loop ;
+ 
  \s
  

Index: extend.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** extend.f	24 Oct 2006 12:41:42 -0000	1.13
--- extend.f	28 Oct 2006 09:07:08 -0000	1.14
***************
*** 39,42 ****
--- 39,49 ----
      FLOAD src\registry.f    \ Win32 Registry support
  
+ \     FLOAD src\lib\array.f       \ Array words
+ \     FLOAD src\lib\binsearch.f   \ Binary search
+ \     FLOAD src\lib\block.f       \ Block file support
+ \     FLOAD src\lib\ctype.f       \ C-ish ctype macros
+ \     FLOAD src\lib\enum.f        \ Enum support
+ \     FLOAD src\lib\SoundVolume.f \ Turn sound on/off
+ 
  .olly
  
***************
*** 51,57 ****
  \s
  
!                                                                         
  sys-FLOAD src\see.f
- sys-FLOAD src\ctype.f       \ 'c' style character typing
  sys-FLOAD src\res\resforth.h \ load the headerfile with a few constants
  sys-FLOAD src\debug.f
--- 58,63 ----
  \s
  
! 
  sys-FLOAD src\see.f
  sys-FLOAD src\res\resforth.h \ load the headerfile with a few constants
  sys-FLOAD src\debug.f

Index: optliterals.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** optliterals.f	28 Oct 2006 06:34:32 -0000	1.4
--- optliterals.f	28 Oct 2006 09:07:08 -0000	1.5
***************
*** 9,13 ****
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk.yahoo @ schneider-busch.de)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
--- 9,13 ----
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk at win32forth.org)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \

Index: optinline.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optinline.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** optinline.f	23 Oct 2006 14:28:50 -0000	1.3
--- optinline.f	28 Oct 2006 09:07:08 -0000	1.4
***************
*** 9,13 ****
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk.yahoo @ schneider-busch.de)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
--- 9,13 ----
  \
  \ Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com)
! \                       Dirk Busch    (dirk at win32forth.org)
  \                       George Hubert (georgeahubert at yahoo.co.uk)
  \
***************
*** 29,33 ****
  \
  \ Simple inline optimiser
! \ 
  \ Inlining increases the space required in the code sections by around
  \ 10%; but shows a 200% improvement in performance.
--- 29,33 ----
  \
  \ Simple inline optimiser
! \
  \ Inlining increases the space required in the code sections by around
  \ 10%; but shows a 200% improvement in performance.
***************
*** 42,46 ****
                  dup >name n>ofa                 \ get the length
                  w@ copy-code ;                  \ and copy the code
!                 
  previous definitions also optimise
  
--- 42,46 ----
                  dup >name n>ofa                 \ get the length
                  w@ copy-code ;                  \ and copy the code
! 
  previous definitions also optimise
  
***************
*** 49,53 ****
                    ['] xt-inline, compiles-last
                  then ;
!                 
  definitions
  
--- 49,53 ----
                    ['] xt-inline, compiles-last
                  then ;
! 
  definitions
  
***************
*** 61,65 ****
  ' (comp-cons) compiles-for -cell
  
! \ set the words we will inline  
  
  ' xt-inline, compiles-for cells
--- 61,65 ----
  ' (comp-cons) compiles-for -cell
  
! \ set the words we will inline
  
  ' xt-inline, compiles-for cells
***************
*** 71,173 ****
  ' xt-inline, compiles-for -cells
  ' xt-inline, compiles-for char+
! ' xt-inline, compiles-for drop       
  ' xt-inline, compiles-for dup
  ' xt-inline, compiles-for swap
! ' xt-inline, compiles-for over       
! ' xt-inline, compiles-for rot        
! ' xt-inline, compiles-for -rot       
! ' xt-inline, compiles-for ?dup       
! ' xt-inline, compiles-for nip        
! ' xt-inline, compiles-for tuck       
! ' xt-inline, compiles-for pick       
! ' xt-inline, compiles-for 2drop      
  ' xt-inline, compiles-for 2nip
! ' xt-inline, compiles-for 2dup       
! ' xt-inline, compiles-for 2swap      
! ' xt-inline, compiles-for 2over      
! ' xt-inline, compiles-for @          
! ' xt-inline, compiles-for !          
! ' xt-inline, compiles-for +!         
! ' xt-inline, compiles-for c@         
! ' xt-inline, compiles-for sc@        
  ' xt-inline, compiles-for c!
! ' xt-inline, compiles-for c+!        
! ' xt-inline, compiles-for w@         
! ' xt-inline, compiles-for sw@        
! ' xt-inline, compiles-for w!         
! ' xt-inline, compiles-for w+!        
! ' xt-inline, compiles-for 2@         
! ' xt-inline, compiles-for 2!         
  ' xt-inline, compiles-for 0=
  ' xt-inline, compiles-for not
! ' xt-inline, compiles-for 0<>        
! ' xt-inline, compiles-for 0<         
! ' xt-inline, compiles-for 0>         
! ' xt-inline, compiles-for =          
! ' xt-inline, compiles-for <>         
! ' xt-inline, compiles-for <          
! ' xt-inline, compiles-for >          
! ' xt-inline, compiles-for <=         
! ' xt-inline, compiles-for >=         
! ' xt-inline, compiles-for u<         
! ' xt-inline, compiles-for u>         
! ' xt-inline, compiles-for min        
! ' xt-inline, compiles-for max        
  ' xt-inline, compiles-for 0max
! ' xt-inline, compiles-for umin       
! ' xt-inline, compiles-for umax       
! ' xt-inline, compiles-for and        
! ' xt-inline, compiles-for or         
! ' xt-inline, compiles-for xor        
! ' xt-inline, compiles-for invert     
  ' xt-inline, compiles-for lshift
  ' xt-inline, compiles-for rshift
  ' xt-inline, compiles-for arshift
! ' xt-inline, compiles-for incr       
! ' xt-inline, compiles-for decr       
! ' xt-inline, compiles-for cincr      
! ' xt-inline, compiles-for cdecr      
! ' xt-inline, compiles-for on         
! ' xt-inline, compiles-for off        
! ' xt-inline, compiles-for toggle     
! ' xt-inline, compiles-for d=         
! ' xt-inline, compiles-for d0<        
! ' xt-inline, compiles-for d0=        
! ' xt-inline, compiles-for d<         
! ' xt-inline, compiles-for d>         
! ' xt-inline, compiles-for d<>        
! ' xt-inline, compiles-for +          
! ' xt-inline, compiles-for negate     
! ' xt-inline, compiles-for -          
! ' xt-inline, compiles-for under+     
! ' xt-inline, compiles-for abs        
! ' xt-inline, compiles-for 2*         
! ' xt-inline, compiles-for 2/         
! ' xt-inline, compiles-for u2/        
! ' xt-inline, compiles-for 1+         
! ' xt-inline, compiles-for 1-         
! ' xt-inline, compiles-for 2+         
! ' xt-inline, compiles-for 2-         
! ' xt-inline, compiles-for d2*        
! ' xt-inline, compiles-for d2/        
! ' xt-inline, compiles-for um*        
! ' xt-inline, compiles-for um/mod     
! ' xt-inline, compiles-for m*         
! ' xt-inline, compiles-for sm/rem     
! ' xt-inline, compiles-for *          
! ' xt-inline, compiles-for /mod       
! ' xt-inline, compiles-for /          
! ' xt-inline, compiles-for mod        
! ' xt-inline, compiles-for */         
! ' xt-inline, compiles-for */mod      
! ' xt-inline, compiles-for d+         
! ' xt-inline, compiles-for d-         
! ' xt-inline, compiles-for dnegate    
! ' xt-inline, compiles-for s>d        
! ' xt-inline, compiles-for d>s        
! ' xt-inline, compiles-for count      
! ' xt-inline, compiles-for wcount     
! ' xt-inline, compiles-for lcount     
! ' xt-inline, compiles-for zcount 
  ' xt-inline, compiles-for perform
  ' xt-inline, compiles-for bounds
--- 71,173 ----
  ' xt-inline, compiles-for -cells
  ' xt-inline, compiles-for char+
! ' xt-inline, compiles-for drop
  ' xt-inline, compiles-for dup
  ' xt-inline, compiles-for swap
! ' xt-inline, compiles-for over
! ' xt-inline, compiles-for rot
! ' xt-inline, compiles-for -rot
! ' xt-inline, compiles-for ?dup
! ' xt-inline, compiles-for nip
! ' xt-inline, compiles-for tuck
! ' xt-inline, compiles-for pick
! ' xt-inline, compiles-for 2drop
  ' xt-inline, compiles-for 2nip
! ' xt-inline, compiles-for 2dup
! ' xt-inline, compiles-for 2swap
! ' xt-inline, compiles-for 2over
! ' xt-inline, compiles-for @
! ' xt-inline, compiles-for !
! ' xt-inline, compiles-for +!
! ' xt-inline, compiles-for c@
! ' xt-inline, compiles-for sc@
  ' xt-inline, compiles-for c!
! ' xt-inline, compiles-for c+!
! ' xt-inline, compiles-for w@
! ' xt-inline, compiles-for sw@
! ' xt-inline, compiles-for w!
! ' xt-inline, compiles-for w+!
! ' xt-inline, compiles-for 2@
! ' xt-inline, compiles-for 2!
  ' xt-inline, compiles-for 0=
  ' xt-inline, compiles-for not
! ' xt-inline, compiles-for 0<>
! ' xt-inline, compiles-for 0<
! ' xt-inline, compiles-for 0>
! ' xt-inline, compiles-for =
! ' xt-inline, compiles-for <>
! ' xt-inline, compiles-for <
! ' xt-inline, compiles-for >
! ' xt-inline, compiles-for <=
! ' xt-inline, compiles-for >=
! ' xt-inline, compiles-for u<
! ' xt-inline, compiles-for u>
! ' xt-inline, compiles-for min
! ' xt-inline, compiles-for max
  ' xt-inline, compiles-for 0max
! ' xt-inline, compiles-for umin
! ' xt-inline, compiles-for umax
! ' xt-inline, compiles-for and
! ' xt-inline, compiles-for or
! ' xt-inline, compiles-for xor
! ' xt-inline, compiles-for invert
  ' xt-inline, compiles-for lshift
  ' xt-inline, compiles-for rshift
  ' xt-inline, compiles-for arshift
! ' xt-inline, compiles-for incr
! ' xt-inline, compiles-for decr
! ' xt-inline, compiles-for cincr
! ' xt-inline, compiles-for cdecr
! ' xt-inline, compiles-for on
! ' xt-inline, compiles-for off
! ' xt-inline, compiles-for toggle
! ' xt-inline, compiles-for d=
! ' xt-inline, compiles-for d0<
! ' xt-inline, compiles-for d0=
! ' xt-inline, compiles-for d<
! ' xt-inline, compiles-for d>
! ' xt-inline, compiles-for d<>
! ' xt-inline, compiles-for +
! ' xt-inline, compiles-for negate
! ' xt-inline, compiles-for -
! ' xt-inline, compiles-for under+
! ' xt-inline, compiles-for abs
! ' xt-inline, compiles-for 2*
! ' xt-inline, compiles-for 2/
! ' xt-inline, compiles-for u2/
! ' xt-inline, compiles-for 1+
! ' xt-inline, compiles-for 1-
! ' xt-inline, compiles-for 2+
! ' xt-inline, compiles-for 2-
! ' xt-inline, compiles-for d2*
! ' xt-inline, compiles-for d2/
! ' xt-inline, compiles-for um*
! ' xt-inline, compiles-for um/mod
! ' xt-inline, compiles-for m*
! ' xt-inline, compiles-for sm/rem
! ' xt-inline, compiles-for *
! ' xt-inline, compiles-for /mod
! ' xt-inline, compiles-for /
! ' xt-inline, compiles-for mod
! ' xt-inline, compiles-for */
! ' xt-inline, compiles-for */mod
! ' xt-inline, compiles-for d+
! ' xt-inline, compiles-for d-
! ' xt-inline, compiles-for dnegate
! ' xt-inline, compiles-for s>d
! ' xt-inline, compiles-for d>s
! ' xt-inline, compiles-for count
! ' xt-inline, compiles-for wcount
! ' xt-inline, compiles-for lcount
! ' xt-inline, compiles-for zcount
  ' xt-inline, compiles-for perform
  ' xt-inline, compiles-for bounds