win32forth-cvs — CVS Commit List

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

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

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

Modified Files:
	POINTER.F 
Log Message:
gah:Removed >APPLICATION and APPLICATION>

Index: POINTER.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/POINTER.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** POINTER.F	4 Oct 2006 12:00:03 -0000	1.1
--- POINTER.F	4 Oct 2006 15:54:53 -0000	1.2
***************
*** 26,30 ****
  
  : Pointer       ( bytes -<name>- )              \ make a pointer "name"
!                 >APPLICATION                    \ always in app space
                  128 max                         \ at least 160 bytes
                  create
--- 26,30 ----
  
  : Pointer       ( bytes -<name>- )              \ make a pointer "name"
!                 ( >APPLICATION )                   \ always in app space
                  128 max                         \ at least 160 bytes
                  create
***************
*** 32,36 ****
                  HERE  PHEAD @ ,  PHEAD !        \ link into chain
                  ,                               \ lay in size in bytes
!                 APPLICATION> does>                  \ back to where we came from
  
  \ cfa-func DoPointer  ( -- address )                  \ it's location
--- 32,36 ----
                  HERE  PHEAD @ ,  PHEAD !        \ link into chain
                  ,                               \ lay in size in bytes
!                 ( APPLICATION> ) does>                  \ back to where we came from
  
  \ cfa-func DoPointer  ( -- address )                  \ it's location

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.8,1.9

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

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

Modified Files:
	gkernel.f 
Log Message:
gah:Added Pointer.f and updated Task.f to match newest ITC version

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** gkernel.f	4 Oct 2006 10:27:37 -0000	1.8
--- gkernel.f	4 Oct 2006 12:00:04 -0000	1.9
***************
*** 2292,2296 ****
  
  : move-code ( addr -- ) count (move-code) ;     \ routine to move the code
!             
  \ -------------------- Vocabulary/header support -----------------------
  
--- 2292,2296 ----
  
  : move-code ( addr -- ) count (move-code) ;     \ routine to move the code
! 
  \ -------------------- Vocabulary/header support -----------------------
  
***************
*** 2386,2390 ****
  
  : xt-jmp,   ( xt -- ) $e9 xt-rel, ;           \ generate jump to xt on the stack
!             
  0 | value tail-call                           \ see exit for use
  
--- 2386,2390 ----
  
  : xt-jmp,   ( xt -- ) $e9 xt-rel, ;           \ generate jump to xt on the stack
! 
  0 | value tail-call                           \ see exit for use
  
***************
*** 2406,2410 ****
  
  : >body     ( xt -- body ) body-off + @ ;     \ get body of created word
!             
  gcode _lit
                  mov     -4 [ebp], eax
--- 2406,2410 ----
  
  : >body     ( xt -- body ) body-off + @ ;     \ get body of created word
! 
  gcode _lit
                  mov     -4 [ebp], eax
***************
*** 2432,2436 ****
  
  : (x-cons)  ( xt -- ) execute postpone literal ; \ execute & compile a literal
!             
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
--- 2432,2436 ----
  
  : (x-cons)  ( xt -- ) execute postpone literal ; \ execute & compile a literal
! 
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
***************
*** 2670,2676 ****
  
  : char      ( -- char ) parse-word drop c@ ;
!             
  : [char]    ( -- char ) char postpone literal ; immediate
!             
  : /parse    ( -- addr u )
              >in @ char swap >in ! dup '"' = over ''' =
--- 2670,2676 ----
  
  : char      ( -- char ) parse-word drop c@ ;
! 
  : [char]    ( -- char ) char postpone literal ; immediate
! 
  : /parse    ( -- addr u )
              >in @ char swap >in ! dup '"' = over ''' =
***************
*** 2725,2729 ****
  
  : "parse    ( -- addr len ) [char] " parse ;
!             
  : ",        ( a1 n1 -- )               \ compile a1,n1 at here (counted)
              here over c, over allot 1+ swap cmove ;
--- 2725,2729 ----
  
  : "parse    ( -- addr len ) [char] " parse ;
! 
  : ",        ( a1 n1 -- )               \ compile a1,n1 at here (counted)
              here over c, over allot 1+ swap cmove ;
***************
*** 5586,5589 ****
--- 5586,5590 ----
                  spcs spcs-max blank                    \ fill spaces buffer
  
+                 ['] temp$ is new$                      \ must be set until pointers inited
                  &cb-msg    off                         \ zero out pointers first time through
                  &cb-winmsg off

[Win32forth-cvs] win32forth-stc/src POINTER.F, NONE, 1.1 extend.f, 1.5, 1.6 primutil.f, 1.7, 1.8 task.f, 1.2, 1.3

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

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

Modified Files:
	extend.f primutil.f task.f 
Added Files:
	POINTER.F 
Log Message:
gah:Added Pointer.f and updated Task.f to match newest ITC version

Index: task.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/task.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** task.f	25 Sep 2006 11:57:53 -0000	1.2
--- task.f	4 Oct 2006 12:00:03 -0000	1.3
***************
*** 5,29 ****
  cr .( Loading Task Support...)
  
  \ -------------------- Task Control Block Offsets --------------------
  
! cell
! cell field+ task>parm     ( thread -- addr )             \ thread parameter
! cell field+ task>id       ( thread -- addr )             \ thread id
! cell field+ task>handle   ( thread -- addr )             \ thread handle
! cell field+ task>stop     ( thread -- addr )             \ the stop flag
  drop
  
! : task>parm@    ( task-block -- parm )         \ extract the parameter
                  task>parm @ ;
  
  \ -------------------- Task Start Initialisation --------------------
  
! 1 proc ExitThread  as exit-task     ( n -- )     \ exit the thread
  
  : (task)        ( parm cfa -- )                 \ helper routine
                  catch                           \ execute cfa and catch errors gah 27nov03
!                 Exit-Task                       \ and exit the thread, never returns
                  ;
  
  code begin-task ( -- )                          \ thread management. init a new thread/task
                  push    ebp                     \ save regs
--- 5,116 ----
  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
***************
*** 58,82 ****
                  0<> ;                           \ and set the flag, true=ok
  
! : create-task   ( addr -- flag )                \ create task suspended
                  CREATE_SUSPENDED (create-task) ;
  
! : run-task      ( addr -- flag )                \ create task running
                  0 (create-task) ;
  
! : suspend-task  ( addr -- flag )                \ suspend a task
                  task>handle @                   \ point at thread handle
                  call SuspendThread -1 <> ;      \ true=0K
  
! : resume-task   ( addr -- flag )                \ suspend a task
                  task>handle @                   \ point at thread handle
                  call ResumeThread -1 <> ;       \ true=0K
  
! : stop-task     ( addr -- )                     \ stop the task
                  task>stop on ;                  \ stop flag
  
! : task-sleep    ( n -- )                        \ sleep the task for n ms
                  call Sleep drop ;
  
! : (task-block)  ( parm cfa-task addr -- len )   \ build a task block at addr
                  dup>r !                         \ cfa
                  r@ cell+ !                      \ parameter for the task
--- 145,180 ----
                  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
***************
*** 87,91 ****
                  ;
  
! : task-block    ( parm cfa-task -- addr )       \ a task-block
                  here >r                         \ return this block's address
                  ,                               \ cfa to execute as task
--- 185,191 ----
                  ;
  
! : 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
***************
*** 96,100 ****
                  r> ;                            \ return structure
  
! : task-stop?    ( task-block -- )               \ pause, stop if we're told
                  task>stop @ ;                   \ check, exit if stop set
  
--- 196,202 ----
                  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
  
***************
*** 109,131 ****
  external
  
! : lock          ( lock -- )                    \ lock on a lock
                  call EnterCriticalSection drop ;
  
! : unlock        ( lock -- )                    \ unlock a lock
                  call LeaveCriticalSection drop ;
  
! : trylock       ( lock -- fl )                 \ try a lock
!                 call TryEnterCriticalSection 0<> ;  \ 0 -- lock is blocked
  
  internal
  
  : init-lock     ( lock -- )
                  0 swap call InitializeCriticalSectionAndSpinCount drop ;
  
  external
  
  in-system
  
! : make-lock       ( -<name>-  -- )                \ create a lock
                  create
                  here lock-size ( 6 cells ) allot  \ gah
--- 211,268 ----
  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
  
  in-system
  
! : make-lock     ( compiling: -<name>-  --  runtime: -- lock ) \ W32F    Lock
! \ *G Create a new lock. When executed the lock returns it's identifier.
                  create
                  here lock-size ( 6 cells ) allot  \ gah
***************
*** 137,143 ****
  internal
  
! : init-lock-from-list ( addr -- )    lock-size - init-lock ;
  
! : init-locks ['] init-lock-from-list lock-list do-link ;
  
  initialization-chain chain-add init-locks
--- 274,282 ----
  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
***************
*** 147,185 ****
  \ of dialog linking and control subclasssing
  
! make-lock mem-lock                      \ to make mem allocation thread safe
  make-lock control-lock                  \ to make control subclassing thread safe
! make-lock dialog-lock                   \ to make linling dialogs 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
  
! : 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)  ;
  
  init-system-locks
  
  initialization-chain chain-add init-system-locks
! 
  \ -------------------- Forgetting Locks -----------------------------
  
! \ WARNING 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 CRASHING !! YOU HAVE BEEN WARNED
! 
! module
! 
! \s
  
  in-system
! \s
  : delete-locks ( nfa link -- nfa )     \ delete lock if created after nfa
                2dup trim? if lock-size - call DeleteCriticalSection then drop ;
--- 286,337 ----
  \ 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 ;
***************
*** 194,195 ****
--- 346,348 ----
  module
  
+ \ *Z

--- NEW FILE: POINTER.F ---
\ $Id: POINTER.F,v 1.1 2006/10/04 12:00:03 georgeahubert Exp $

\ POINTER.F     External memory allocation and management   by Tom Zimmer
\ For STC G.Hubert Sunday, October 01 2006

cr .( Loading Memory Pointer...)

\ BODY          +0             +4      +8              |
\               [ phy_pointer ][ link ][ size_bytes ]  |

in-application

internal

VARIABLE PHEAD  PHEAD OFF

:NONAME         ( LINK --  )                     \ POINTERS-INIT
                CELL- OFF                        \ clear the pointer
                ; : POINTERS-INIT ( -- )         \ clear each pointer in turn
                    LITERAL [ !CSP ]             \ make sure CSP is adjusted
                    PHEAD DO-LINK ;              \ from noname above

initialization-chain chain-add pointers-init

external

: Pointer       ( bytes -<name>- )              \ make a pointer "name"
                >APPLICATION                    \ always in app space
                128 max                         \ at least 160 bytes
                create
                ( header DoPointer compile, ) 0 ,   \ initialize to unallocated
                HERE  PHEAD @ ,  PHEAD !        \ link into chain
                ,                               \ lay in size in bytes
                APPLICATION> does>                  \ back to where we came from

\ cfa-func DoPointer  ( -- address )                  \ it's location
                dup @ if @ exit then                  \ ok, straight fetch
                dup (pointerlock)
                @ if (pointerunlock) @ exit then  \ another task won the race
                dup 2 cells+ @ allocate 0=
                if     dup off                 \ set first cell to zeros
                       tuck swap ! (pointerunlock) exit
                then   (pointerunlock) 1-
                       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: "
\                 @ ?DUP
\                 IF      13 H.R
\                 ELSE    ." <unallocated>"
\                 THEN     ;
\
\ : .Pointer      ( cfa -- )
\                 ." POINTER " dup .name >body (.Pointer) ;
\
\ external
\
\ :NONAME         ( link -- )                      \ .POINTERS
\                 cr CELL-  dup>r (.Pointer) ."  for: " R> body> .NAME
\                 ; : .POINTERS ( -- )
\                     LITERAL [ !CSP ]             \ make sure CSP is adjusted
\                     PHEAD DO-LINK ;              \ from noname above
\
\ internal

\ : (IsPointer?)   ( plink -- plink )     \ check for valid pointer structure
\                  DUP @ Dopointer <>
\                  IF      DUP CR h.
\                          .name
\                          ." is NOT a valid POINTER structure!"
\                          ABORT
\                  THEN    ;

\ in-application

: IsPointer?    ( cfa -- cfa )  ; immediate                \ check for valid pointer structure
\ \in-system-ok     TURNKEYED? ?EXIT (IsPointer?) ; \ no point if this is turnkeyed

external

: %UnPointer    ( cfa -- )      \ deallocate pointer given the cfa
                IsPointer? >BODY DUP @ 0<>                  \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu)
                IF      DUP @ release            \ release the memory
                        off                      \ clear the memory pointer
                ELSE DROP
                THEN ;

: >POINTER      ( cfa -- ptr )      \ move to ptr
                IsPointer? >BODY 2 cells+ ;

: %SizeOf!      ( bytes cfa -- )    \ set the size of pointer "cfa"
                >POINTER ! ;

: %SizeOf@      ( cfa -- bytes )    \ get the size of pointer "cfa"
                >POINTER @ ;

: (ResizePointer)  ( size size pointer -- f )
                dup>r 2 cells+ !                \ first, adjust the size of the desired pointer
                r@ @ 0=
                IF      r>drop                  \ if it isn't allocated yet, just leave
                        drop FALSE              \ things went just fine.
                        EXIT                    \ April 15th, 1999 - 10:51 tjz corrected
                THEN
                r@ @ (pointerlock) realloc 0=
                if      r> ! FALSE
                else    drop r>drop TRUE
                then    (pointerunlock) ;


: ResizePointer ( size -<Pointer>- flag )       \ return FALSE if all went ok
                dup ' >body  (resizepointer) compilation>
                drop postpone dup ' >body postpone literal postpone (resizepointer) ;

\ in-system

\ These words need to be compile\interpret words


\ : UnPointer>    ( name -- )     \ deallocate a pointer name following
\                 ' STATE @
\                 IF      POSTPONE LITERAL
\                         POSTPONE %UNPOINTER
\                 ELSE    %UNPOINTER
\                 THEN    ; IMMEDIATE

: UnPointer>    ( name -- )     \ deallocate a pointer name following
                ' %unpointer compilation> drop ' postpone literal postpone %unpointer ;

: SizeOf!>      ( bytes | name -- ) \ set size of the following pointer
\                 ' STATE @
\                 IF      POSTPONE LITERAL
\                         POSTPONE %SIZEOF!
\                 ELSE    %SIZEOF!
\                 THEN    ; IMMEDIATE
                ' %sizeof! compilation> drop ' postpone literal postpone %sizeof! ;

: SizeOf@>      ( -<name>- bytes )  \ get size of the following pointer
\                 ' STATE @
\                 IF      POSTPONE LITERAL
\                         POSTPONE %SIZEOF@
\                 ELSE    %SIZEOF@
\                 THEN    ; IMMEDIATE
                ' %sizeof@ compilation> drop ' postpone literal postpone %sizeof@ ;

: named-new$    ( -<name>- )            \ a semi-static buffer of MAXSTRING length
                MAXSTRING Pointer ;

in-application

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\               Dynamic String Support Words
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ The dynamic string buffer is allocated when it is first used, and automatically
\ released when the program terminates.

32768 constant max-dyn-string           \ dynamic string space is this big (increased for tasks)

max-dyn-string Pointer dyn-ptr          \ the dynamic string buffer

0 value dyn-offset                      \ top of the dynamic string buffer

: DynAlloc      ( n1 -- a1 )            \ allocate space in dynamic buffer
                                        \ return a1 a buffer of n1 bytes
                dup
                max-dyn-string 16 / >    \ limit one string to 1/16 of total
                abort" Can't allocate a dynamic string this large"
                (dynlock) dyn-offset over + max-dyn-string >=
                if      0 to dyn-offset
                then    dyn-ptr dyn-offset + swap +to dyn-offset (dynunlock) ;

: _new$         ( -- a1 )               \ allocate the next MAXSTRING buffer
                MAXSTRING DynAlloc ;

: init-new$     ( -- )
                ['] _new$ is new$ ;

init-new$

initialization-chain chain-add init-new$

module

\ *Z


Index: extend.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** extend.f	24 Sep 2006 08:42:03 -0000	1.5
--- extend.f	4 Oct 2006 12:00:03 -0000	1.6
***************
*** 19,22 ****
--- 19,23 ----
  
  sys-FLOAD src\dis486.f      \ load the disassembler
+     FLOAD src\pointer.f     \ pointer support ( w/o forgetting and decompiling )
      fload src\callback.f    \ windows callback support
      fload src\exception.f   \ utility words to support windows exception handling
***************
*** 39,43 ****
  \     FLOAD src\paths.f       \ multi path support words                *** to be done ***
  \ sys-FLOAD src\nforget.f     \ forget words                            *** to be done ***
- \     FLOAD src\pointer.f     \ pointer support                         *** depends on nforget
  \ sys-FLOAD src\dbgsrc1.f     \ source level debugging support part one *** to be done ***
  
--- 40,43 ----

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** primutil.f	30 Sep 2006 15:17:33 -0000	1.7
--- primutil.f	4 Oct 2006 12:00:03 -0000	1.8
***************
*** 147,150 ****
--- 147,204 ----
                  reset-stack-chain do-chain ; is reset-stacks \ install in kernel word
  
+ \ ---------------- Operating System Checking --------------------------
+ 
+ 1 PROC GetVersionEx
+ 
+ 1 constant win95
+ 2 constant win98
+ 3 constant winme
+ 4 constant winnt351
+ 5 constant winnt4
+ 6 constant win2k
+ 7 constant winxp
+ 8 constant win2003
+ 
+ \ To check for a version, say Win2K or greater, try WINVER WIN2K >=
+ 
+ 0 value winver
+ 
+ : winver-init ( -- n )                \ get windows version
+             148 dup _localalloc dup>r !   \ set length of structure
+             r@ call GetVersionEx \ call os for version
+             0= abort" call failed"
+             r@ 4 cells+ @        \ get osplatformid
+             case
+               1 of                  \ 95, 98, and me
+                 r@ 2 cells+ @       \ minorversion
+                 case
+                   0  of win95 endof \ 95
+                   10 of win98 endof \ 98
+                   90 of winme endof \ me
+                 endcase
+               endof
+ 
+               2 of                  \ nt, 2k, xp
+                 r@ cell+ @          \ majorversion
+                 case
+                   3  of winnt351 endof \ nt351
+                   4  of winnt4 endof \ nt4
+                   5  of
+                      r@ 2 cells+ @  \ minor version
+                      case
+                        0 of win2k endof \ win2k
+                        1 of winxp endof \ winxp
+                        2 of win2003 endof \ 2003
+                      endcase
+                   endof
+                 endcase
+               endof
+             endcase to winver
+             r>drop _localfree
+             ;
+ 
+ initialization-chain chain-add winver-init
+ winver-init
+ 
  \ ------------------------------------------------------------------------
  \ ------------------------------------------------------------------------

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.7, 1.8 gmeta-fkernel.f, 1.1, 1.2

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

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

Modified Files:
	gkernel.f gmeta-fkernel.f 
Log Message:
arm: support dual code areas in system and application

Index: gmeta-fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-fkernel.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** gmeta-fkernel.f	21 Sep 2006 16:26:33 -0000	1.1
--- gmeta-fkernel.f	4 Oct 2006 10:27:37 -0000	1.2
***************
*** 52,61 ****
  512000 0x1000 naligned constant MINCODEMEM \ minimum size of kernel code dictionary
  512000 0x1000 naligned constant MINSYSMEM  \ minimum size of kernel system dictionary
!   1024 0x1000 naligned constant MINKODEMEM \ minimum size of kernel kode dictionary
  
  512000 0x1000 naligned  TO IMAGE-ASIZE  \ size of kernel application dictionary
  512000 0x1000 naligned  TO IMAGE-CSIZE  \ size of kernel data dictionary
  512000 0x1000 naligned  TO IMAGE-SSIZE  \ size of kernel system dictionary
!   1024 0x1000 naligned  TO IMAGE-KSIZE  \ size of kernel kode dictionary
  
  0                                       STD-HEADLEN + TO IMAGE-CSEP \ separations
--- 52,61 ----
  512000 0x1000 naligned constant MINCODEMEM \ minimum size of kernel code dictionary
  512000 0x1000 naligned constant MINSYSMEM  \ minimum size of kernel system dictionary
! 512000 0x1000 naligned constant MINKODEMEM \ minimum size of kernel kode dictionary
  
  512000 0x1000 naligned  TO IMAGE-ASIZE  \ size of kernel application dictionary
  512000 0x1000 naligned  TO IMAGE-CSIZE  \ size of kernel data dictionary
  512000 0x1000 naligned  TO IMAGE-SSIZE  \ size of kernel system dictionary
! 512000 0x1000 naligned  TO IMAGE-KSIZE  \ size of kernel kode dictionary
  
  0                                       STD-HEADLEN + TO IMAGE-CSEP \ separations

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** gkernel.f	1 Oct 2006 07:38:44 -0000	1.7
--- gkernel.f	4 Oct 2006 10:27:37 -0000	1.8
***************
*** 2155,2159 ****
  \   1     4     Address of the area (origin)
  \   2     8     Highest address of area (origin + length)
! \   4    16     Link of all the xDP areas; set in DP-LINK
  \   5    20     Counted name of the area
  \
--- 2155,2159 ----
  \   1     4     Address of the area (origin)
  \   2     8     Highest address of area (origin + length)
! \   4    16     Link of all the DP areas; set in DP-LINK
  \   5    20     Counted name of the area
  \
***************
*** 2164,2168 ****
  \  See also PDP and LDP (procs and locals data respectively)
  
! variable dp-link                 \ list of xdp structures
           0 dp-link !
  
--- 2164,2168 ----
  \  See also PDP and LDP (procs and locals data respectively)
  
! variable dp-link                 \ list of dp structures
           0 dp-link !
  
***************
*** 2173,2178 ****
  
  adp value dp                     \ data pointer defaults to app space
  
! \ ----------------- Switching dictionary words ---------------
  
  \ To switch between data areas, >DP saves and resets the data pointer.
--- 2173,2179 ----
  
  adp value dp                     \ data pointer defaults to app space
+ cdp value xdp                    \ xdp is the default code pointer
  
! \ ----------------- Switching section areas --------------------
  
  \ To switch between data areas, >DP saves and resets the data pointer.
***************
*** 2186,2196 ****
  \ used to save/restore the current value, and must be used in matching pairs.
  
! : in-application ( -- ) adp to dp ;   \ set the correct pointer
! : in-system      ( -- ) sdp to dp ;
  
  : in-app?       ( -- f ) dp adp = ;       \ if the dp is set to adp
  : in-sys?       ( -- f ) dp sdp = ;       \ if the dp is set to sdp
- : in-code?      ( -- f ) dp cdp = ;       \ if the dp is set to cdp
- : in-kode?      ( -- f ) dp kdp = ;       \ if the dp is set to kdp
  
  : >dp           ( dp -- )            \ nasty piece of code!
--- 2187,2198 ----
  \ used to save/restore the current value, and must be used in matching pairs.
  
! : get-section   ( -- n m ) dp xdp ;
! : set-section   ( n m -- ) to xdp to dp ;
! 
! : in-application ( -- ) adp cdp set-section ;   \ set the correct pointers
! : in-system      ( -- ) sdp kdp set-section ;
  
  : in-app?       ( -- f ) dp adp = ;       \ if the dp is set to adp
  : in-sys?       ( -- f ) dp sdp = ;       \ if the dp is set to sdp
  
  : >dp           ( dp -- )            \ nasty piece of code!
***************
*** 2209,2224 ****
  : >application  ( -- ) adp >dp exit ; \ select app dict, save prev dict
  : >system       ( -- ) sdp >dp exit ; \ select sys dict, save prev dict
! : >code         ( -- ) cdp >dp exit ; \ select code dict, save prev dict
! : >kode         ( -- ) kdp >dp exit ; \ select code dict, save prev dict
! 
! ' dp> alias system>
! ' dp> alias application>
! ' dp> alias code>
! ' dp> alias kode>
! 
! : app-origin    ( -- a1 ) adp cell+ @ ;
! : sys-origin    ( -- a1 ) sdp cell+ @ ;
! : code-origin   ( -- a1 ) cdp cell+ @ ;
! : kode-origin   ( -- a1 ) kdp cell+ @ ;
  
  : here          ( -- a1 ) dp @ ;                   \ next free byte
--- 2211,2215 ----
  : >application  ( -- ) adp >dp exit ; \ select app dict, save prev dict
  : >system       ( -- ) sdp >dp exit ; \ select sys dict, save prev dict
! : >code         ( -- ) xdp >dp exit ; \ select code dict, save prev dict
  
  : here          ( -- a1 ) dp @ ;                   \ next free byte
***************
*** 2229,2234 ****
  : mem-free      ( -- n1 ) dp 2 cells+ @ here - ;
  
! : ?memchk       ( n1 -- ) \ test to see if we have enough memory
!                 mem-free > if
                    dp 4 cells+ count temp$ place    \ name of the space
                    temp$ throw_outofmem nabort!
--- 2220,2225 ----
  : mem-free      ( -- n1 ) dp 2 cells+ @ here - ;
  
! : ?memchk       ( -- ) \ test to see if we have enough memory
!                 4096 mem-free > if
                    dp 4 cells+ count temp$ place    \ name of the space
                    temp$ throw_outofmem nabort!
***************
*** 2236,2240 ****
  
  : allot         ( n -- )                  \ allot n bytes
!                 dup 1024 + ?memchk dp +! ;
  
  : align         ( -- )                          \ align data space & pad
--- 2227,2231 ----
  
  : allot         ( n -- )                  \ allot n bytes
!                 ?memchk dp +! ;
  
  : align         ( -- )                          \ align data space & pad
***************
*** 2243,2247 ****
  
  : sys-addr?     ( a -- f )                \ is it a system address?
!                 sys-origin [ sdp 2 cells+ ] literal @ within ;
  
  : sys-warning-off ( -- ) \ disable warning for use of system words in application
--- 2234,2238 ----
  
  : sys-addr?     ( a -- f )                \ is it a system address?
!                 sdp cell+ 2@ swap within ;
  
  : sys-warning-off ( -- ) \ disable warning for use of system words in application
***************
*** 2269,2307 ****
                  next;
  
! : app-free      ( -- n1 ) >application  mem-free   application> ;
! : app-here      ( -- a )  adp @ ;
! : app-allot     ( n1 -- ) >application  allot      application> ;
! : app-align     ( -- )    >application  align      application> ;
  
! : sys-free      ( -- n1 ) >system       mem-free   system>      ;
  : sys-here      ( -- a )  sdp @ ;
! : sys-allot     ( n1 -- ) >system       allot      system>      ;
! : sys-,         ( n -- )  >system       ,          system>      ;
! : sys-w,        ( n -- )  >system       w,         system>      ;
! : sys-c,        ( n -- )  >system       c,         system>      ;
! : sys-align     ( -- )    >system       align      system>      ;
! 
! : kode-free     ( -- n1 ) >kode         mem-free   kode>        ;
! : kode-here     ( -- a )  kdp @ ;
! : kode-allot    ( n1 -- ) >kode         allot      kode>        ;
! : kode-,        ( n -- )  >kode         ,          kode>        ;
! : kode-c!       ( n -- )  >kode         c!         kode>        ;
! : kode-w,       ( n -- )  >kode         w,         kode>        ;
! : kode-c,       ( n -- )  >kode         c,         kode>        ;
! : kode-align    ( -- )    >kode         align      kode>        ;
  
! : code-free     ( -- n1 ) >code         mem-free   code>        ;
! : code-here     ( -- a )  cdp @ ;
! : code-allot    ( n1 -- ) >code         allot      code>        ;
! : code-,        ( n -- )  >code         ,          code>        ;
! : code-c!       ( n -- )  >code         c!         code>        ;
! : code-w!       ( n -- )  >code         w!         code>        ;
! : code-w,       ( n -- )  >code         w,         code>        ;
! : code-c,       ( n -- )  >code         c,         code>        ;
  \ : code-align    ( -- )    >code
  \                           cell allot                    \ align to 16byte boundary
  \                           here dup 16 naligned
! \                           swap - cell- allot       code>        ;
! : code-align    ( -- )    >code         align      code>        ;
  
  : break         $cc code-c, ; immediate
--- 2260,2283 ----
                  next;
  
! : app-free      ( -- n1 ) >application  mem-free   dp> ;
! : app-align     ( -- )    >application  align      dp> ;
  
! : sys-free      ( -- n1 ) >system       mem-free   dp> ;
  : sys-here      ( -- a )  sdp @ ;
! : sys-align     ( -- )    >system       align      dp> ;
  
! : code-free     ( -- n1 ) >code         mem-free   dp> ;
! : code-here     ( -- a )  xdp @ ;
! : code-allot    ( n1 -- ) >code         allot      dp> ;
! : code-,        ( n -- )  >code         ,          dp> ;
! : code-c!       ( n -- )  >code         c!         dp> ;
! : code-w!       ( n -- )  >code         w!         dp> ;
! : code-w,       ( n -- )  >code         w,         dp> ;
! : code-c,       ( n -- )  >code         c,         dp> ;
  \ : code-align    ( -- )    >code
  \                           cell allot                    \ align to 16byte boundary
  \                           here dup 16 naligned
! \                           swap - cell- allot       dp>        ;
! : code-align    ( -- )    >code         align      dp>        ;
  
  : break         $cc code-c, ; immediate
***************
*** 2459,2463 ****
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
! \            >system create , system>          \ create in system space
              header                            \
              postpone literal
--- 2435,2439 ----
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
! \            >system create , dp>          \ create in system space
              header                            \
              postpone literal
***************
*** 3560,3564 ****
              over class>sys or                 \ or is a class or object
              if >system else >application then \ then build the header in the same space
!             2000 ?memchk                      \ check avail mem
              _header-build                     \ build head in current
              dp> ;                             \ back to original dictionary pointer
--- 3536,3540 ----
              over class>sys or                 \ or is a class or object
              if >system else >application then \ then build the header in the same space
!             ?memchk                           \ check avail mem
              _header-build                     \ build head in current
              dp> ;                             \ back to original dictionary pointer
***************
*** 4828,4832 ****
  
  : #lexicon      ( #threads -<name>- -- )
!                 >application (voc) application> ;
  
  : lexicon       ( -- )                   \ like a vocabulary, but in app space
--- 4804,4810 ----
  
  : #lexicon      ( #threads -<name>- -- )
!                 get-section 2>r   \ save dp and xdp
!                 in-application (voc)   \ move to in-system
!                 2r> set-section ; \ and restore dp and xdp
  
  : lexicon       ( -- )                   \ like a vocabulary, but in app space
***************
*** 4834,4838 ****
  
  : #vocabulary   ( #threads -<name>- )
!                 >system (voc) system> ;
  
  : vocabulary    ( -- )
--- 4812,4818 ----
  
  : #vocabulary   ( #threads -<name>- )
!                 get-section 2>r   \ save dp and xdp
!                 in-system (voc)   \ move to in-system
!                 2r> set-section ; \ and restore dp and xdp
  
  : vocabulary    ( -- )
***************
*** 5103,5107 ****
  
  : sys-fload     ( -<filename>- )  \ load "filename" into system space
!                 >system fload system> ;
  
  \ ----------------------- Find name in vocabulary ---------------------------
--- 5083,5089 ----
  
  : sys-fload     ( -<filename>- )  \ load "filename" into system space
!                 get-section 2>r   \ save dp and xdp
!                 in-system fload   \ move to in-system
!                 2r> set-section ; \ and restore dp and xdp
  
  \ ----------------------- Find name in vocabulary ---------------------------
***************
*** 5719,5726 ****
  
  : new-sys-chain ( -- )
!                 >system
!                 new-chain
!                 system>
!                 ;
  
  |: ?sys-chain    ( chain_address xt -- chain_address xt )
--- 5701,5707 ----
  
  : new-sys-chain ( -- )
!                 get-section 2>r   \ save dp and xdp
!                 in-system new-chain   \ move to in-system
!                 2r> set-section ; \ and restore dp and xdp
  
  |: ?sys-chain    ( chain_address xt -- chain_address xt )

[Win32forth-cvs] win32forth-stc/src dis486.f, 1.3, 1.4 imageman.f, 1.2, 1.3

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

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

Modified Files:
	dis486.f imageman.f 
Log Message:
arm: support dual code areas in system and application

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** dis486.f	30 Sep 2006 23:22:26 -0000	1.3
--- dis486.f	4 Oct 2006 10:27:22 -0000	1.4
***************
*** 29,33 ****
  
  : code>name     ( addr -- nfa | 0 )
!                 dup code-origin cdp between 0= if
                    drop 0 exit                       \ it's zero if not in code section
                  then
--- 29,34 ----
  
  : code>name     ( addr -- nfa | 0 )
!                 dup cdp cell+ 2@ swap between 0= >r \ origin + highest addr for section
!                 dup kdp cell+ 2@ swap between 0= r> and if
                    drop 0 exit                       \ it's zero if not in code section
                  then

Index: imageman.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/imageman.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** imageman.f	23 Sep 2006 06:00:17 -0000	1.2
--- imageman.f	4 Oct 2006 10:27:22 -0000	1.3
***************
*** 740,743 ****
--- 740,759 ----
        ;
  
+ : area-len      ( n m -- n ) 2@ swap - ;         \ length of the section
+ : app-len       ( -- n ) adp area-len ;
+ : sys-len       ( -- n ) sdp area-len ;
+ : code-len      ( -- n ) cdp area-len ;
+ : kode-len      ( -- n ) kdp area-len ;
+ 
+ : PTABL          ( -- )
+                  cr ." -------" tab ." ---------" tab ."  ------" tab ." -------"
+                  ;
+ 
+ : PORIG          ( n -- )
+                  tab IMAGE-ORIGIN + 8 H.R ." h" ;
+ 
+ : PSIZE          ( n -- )
+                  tab 7 .r ;
+ 
  PREVIOUS DEFINITIONS ALSO VIMAGE
  
***************
*** 836,849 ****
  \ ---------------- In memory image handling ---------------------
  
- : PTABL          ( -- )
-                  cr ." -------" tab ." ---------" tab ."  ------" tab ." -------"
-                  ;
- 
- : PORIG          ( n -- )
-                  tab IMAGE-ORIGIN + 8 H.R ." h" ;
- 
- : PSIZE          ( n -- )
-                  tab 7 .r ;
- 
  : IMAGE-STATS    ( -- )                                  \ image statistics
                   tab-size 10 to tab-size
--- 852,855 ----
***************
*** 882,890 ****
                     0 0                           \ not saving sys header, set zero
                   ELSE
!                    KODE-HERE KODE-ORIGIN -       \ else current sys/header size
!                    SYS-HERE  SYS-ORIGIN  -       \ else current sys/header size
                   THEN
!                  APP-HERE  APP-ORIGIN  -         \ current app size
!                  CODE-HERE CODE-ORIGIN -         \ current code size
                   4DUP                            \ move to actuals
                   TO IMAGE-CACTUAL
--- 888,896 ----
                     0 0                           \ not saving sys header, set zero
                   ELSE
!                    kode-len                       \ else current sys/header size
!                    sys-len                       \ else current sys/header size
                   THEN
!                  app-len                         \ current app size
!                  code-len                        \ current code size
                   4DUP                            \ move to actuals
                   TO IMAGE-CACTUAL
***************
*** 893,901 ****
                   TO IMAGE-kACTUAL
                   4DUP + + + MALLOC TO IMAGE-PTR    \ allocate buffer
! 
!                  code-ORIGIN IMAGE-PTR ROT 2DUP + >R CMOVE \ move the app part, save next addr
!                  APP-ORIGIN         R> ROT 2DUP + >R CMOVE \ move the code part, save next addr
!                  SYS-ORIGIN         R> ROT 2DUP + >R CMOVE \ move the code part, save next addr
!                  KODE-ORIGIN        R> ROT           CMOVE \ move the system part (could be zero)
  
                   IMAGE-PTR           DUP TO IMAGE-CODEPTR   \ odd due to way built (app is at front)
--- 899,907 ----
                   TO IMAGE-kACTUAL
                   4DUP + + + MALLOC TO IMAGE-PTR    \ allocate buffer
!                  \ origin of section is at xdp cell+ @
!                  cdp cell+ @ IMAGE-PTR ROT 2DUP + >R CMOVE \ move the app part, save next addr
!                  adp cell+ @        R> ROT 2DUP + >R CMOVE \ move the code part, save next addr
!                  sdp cell+ @        R> ROT 2DUP + >R CMOVE \ move the code part, save next addr
!                  kdp cell+ @        R> ROT           CMOVE \ move the system part (could be zero)
  
                   IMAGE-PTR           DUP TO IMAGE-CODEPTR   \ odd due to way built (app is at front)

[Win32forth-cvs] win32forth-stc gkernel.exe,1.6,1.7

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

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

Modified Files:
	gkernel.exe 
Log Message:
arm: support dual code areas in system and application

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
Binary files /tmp/cvs1RE2d4 and /tmp/cvsPv0XAV differ

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

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

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

Modified Files:
	optv1.F 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: optv1.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/old/optv1.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** optv1.F	21 Dec 2004 00:19:11 -0000	1.1
--- optv1.F	3 Oct 2006 07:44:22 -0000	1.2
***************
*** 8,12 ****
  ---------------------
  
! Words of the form 
   : x ... 1 2 3 ... ;
  would normally compile
--- 8,12 ----
  ---------------------
  
! Words of the form
   : x ... 1 2 3 ... ;
  would normally compile
***************
*** 19,23 ****
  ------------------
  
! Words of the form 
   10 CONSTANT Y
   : X Y ;
--- 19,23 ----
  ------------------
  
! Words of the form
   10 CONSTANT Y
   : X Y ;
***************
*** 83,87 ****
                  mov     ecx, 0 [esi]              \ get count
                  lea     eax, 4 [esi]              \ point at first entry
!                 lea     esi, 0 [ecx*4] [esi]      \ point at entry n 
                  push    ebx                       \ save ebx
  @@1:            push    0 [eax]                   \ next constant
--- 83,87 ----
                  mov     ecx, 0 [esi]              \ get count
                  lea     eax, 4 [esi]              \ point at first entry
!                 lea     esi, 0 [ecx*4] [esi]      \ point at entry n
                  push    ebx                       \ save ebx
  @@1:            push    0 [eax]                   \ next constant
***************
*** 98,102 ****
                  mov     ecx, 0 [esi]              \ get count
                  lea     ebx, [ecx*4]              \ save it in ebx as cells
!                 sub     esp, ebx                  \ adjust stack 
                  mov     ebx, 0 [esi]              \ last value
                  add     esi, # 4                  \ first entry
--- 98,102 ----
                  mov     ecx, 0 [esi]              \ get count
                  lea     ebx, [ecx*4]              \ save it in ebx as cells
!                 sub     esp, ebx                  \ adjust stack
                  mov     ebx, 0 [esi]              \ last value
                  add     esi, # 4                  \ first entry
***************
*** 134,138 ****
                  0 opt-lasthere !
                  ;
!                 
  opt-chain-term chain-add opt-lastreset           \ add to term chain
  
--- 134,138 ----
                  0 opt-lasthere !
                  ;
! 
  opt-chain-term chain-add opt-lastreset           \ add to term chain
  
***************
*** 153,157 ****
                  then
                  ;
!                 
  opt-chain-term chain-add opt-genlit,              \ add to cleanup
  
--- 153,157 ----
                  then
                  ;
! 
  opt-chain-term chain-add opt-genlit,              \ add to cleanup
  
***************
*** 190,194 ****
                  dup
                  case
!                 
                    dup @ docon of                 \ n CONSTANT y to LIT N
                      opt-lastreset                \ reset last
--- 190,194 ----
                  dup
                  case
! 
                    dup @ docon of                 \ n CONSTANT y to LIT N
                      opt-lastreset                \ reset last
***************
*** 224,228 ****
              BEGIN   opt-scan                     \ read a word
              WHILE   SAVE-SRC FIND ?DUP
!               IF 
                  STATE @ =
                  IF opt-COMPILE,                  \ COMPILE TIME
--- 224,228 ----
              BEGIN   opt-scan                     \ read a word
              WHILE   SAVE-SRC FIND ?DUP
!               IF
                  STATE @ =
                  IF opt-COMPILE,                  \ COMPILE TIME
***************
*** 239,243 ****
              REPEAT DROP
              ;
!                 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \               Optimizer Control definitions
--- 239,243 ----
              REPEAT DROP
              ;
! 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \               Optimizer Control definitions
***************
*** 249,253 ****
                  TRUE  to optimising?
                  FALSE to opt-state
!                 defer@ interpret to prev-interpret
                  ['] opt-interpret is interpret ;
  
--- 249,253 ----
                  TRUE  to optimising?
                  FALSE to opt-state
!                 action-of interpret to prev-interpret
                  ['] opt-interpret is interpret ;
  

[Win32forth-cvs] win32forth/src/lib BLOCK.F, 1.3, 1.4 ScintillaLexer.f, 1.6, 1.7

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

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

Modified Files:
	BLOCK.F ScintillaLexer.f 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: BLOCK.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/BLOCK.F,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** BLOCK.F	30 Aug 2005 13:56:57 -0000	1.3
--- BLOCK.F	3 Oct 2006 07:44:22 -0000	1.4
***************
*** 213,217 ****
          if      refill
          else    >in off
!                 ?loading on
                  blk @ 1+ b/buf block (source) 2!
                  true
--- 213,217 ----
          if      refill
          else    >in off
!                 blockhandle to source-id \ ?loading on
                  blk @ 1+ b/buf block (source) 2!
                  true
***************
*** 250,254 ****
          loadblk blk !
          >in off
!         ?loading on
          blk @ block b/buf (source) 2!
          interpret
--- 250,254 ----
          loadblk blk !
          >in off
!         blockhandle to source-id \ ?loading on
          blk @ block b/buf (source) 2!
          interpret

Index: ScintillaLexer.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ScintillaLexer.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** ScintillaLexer.f	13 Aug 2006 07:59:00 -0000	1.6
--- ScintillaLexer.f	3 Oct 2006 07:44:22 -0000	1.7
***************
*** 80,83 ****
--- 80,85 ----
  ,{ [ ] }
  ,{ INCLUDE-FILE INCLUDED $FLOAD FLOAD SYS-FLOAD "FLOAD INCLUDE NEEDS }
+ ,{ REQUIRED REQUIRES }
+ ,{ ("LOADED?) "LOADED? LOADED? \LOADED- \LOADED }
  ,{ FSAVE TURNKEY APPLICATION }
  ,{ OK }

[Win32forth-cvs] win32forth/src 486ASM.F, 1.4, 1.5 Class.f, 1.23, 1.24 Comment.f, 1.2, 1.3 Utils.f, 1.12, 1.13

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

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

Modified Files:
	486ASM.F Class.f Comment.f Utils.f 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: Utils.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Utils.f,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Utils.f	25 Aug 2006 12:54:01 -0000	1.12
--- Utils.f	3 Oct 2006 07:44:22 -0000	1.13
***************
*** 494,498 ****
  
  : _stack-check  ( -- )
!                 ?loading 0=             \ if we are not loading
                  state @ or              \ or we are in compile state,
                                          \ then don't check stack depth change
--- 494,498 ----
  
  : _stack-check  ( -- )
!                 loading? 0=             \ if we are not loading
                  state @ or              \ or we are in compile state,
                                          \ then don't check stack depth change

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.23
retrieving revision 1.24
diff -C2 -d -r1.23 -r1.24
*** Class.f	18 Sep 2006 10:14:19 -0000	1.23
--- Class.f	3 Oct 2006 07:44:22 -0000	1.24
***************
*** 515,519 ****
                  here to ^Class
                  0 op!                           \ for error checking in runIvarRef
!                 ?loading
                  if      loadline @
                  else    -1
--- 515,519 ----
                  here to ^Class
                  0 op!                           \ for error checking in runIvarRef
!                 loading?
                  if      loadline @
                  else    -1

Index: Comment.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Comment.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Comment.f	13 Apr 2005 00:09:26 -0000	1.2
--- Comment.f	3 Oct 2006 07:44:22 -0000	1.3
***************
*** 23,27 ****
  : _comment      \ char --
                  multi-line?
!                 ?loading and
                  if      begin   source >in @ /string
                                  2 pick scan nip 0=
--- 23,27 ----
  : _comment      \ char --
                  multi-line?
!                 loading? and
                  if      begin   source >in @ /string
                                  2 pick scan nip 0=
***************
*** 32,36 ****
  : comment       \ -<char>-
                  char _comment ; immediate
!                 
  : (             [char] ) _comment ; immediate
  
--- 32,36 ----
  : comment       \ -<char>-
                  char _comment ; immediate
! 
  : (             [char] ) _comment ; immediate
  

Index: 486ASM.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/486ASM.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** 486ASM.F	6 Jul 2005 08:54:29 -0000	1.4
--- 486ASM.F	3 Oct 2006 07:44:22 -0000	1.5
***************
*** 1497,1501 ****
          ?inst-pre register generic-entry2 ?noimmed ?reg,r/m code-w,
          compile-fields ;
!         
  ( mov instruction )
  : mov-compile ( compile a mov instruction )
--- 1497,1501 ----
          ?inst-pre register generic-entry2 ?noimmed ?reg,r/m code-w,
          compile-fields ;
! 
  ( mov instruction )
  : mov-compile ( compile a mov instruction )
***************
*** 2074,2078 ****
  : /postfix? ( are we in postfix mode? )          \ rls March 3rd, 2002 - 11:13
          ( -- flag )
!         defer@ save-inst ['] noop = ;
  
  : /prefix? ( are we in prefix mode? )
--- 2074,2078 ----
  : /postfix? ( are we in postfix mode? )          \ rls March 3rd, 2002 - 11:13
          ( -- flag )
!         action-of save-inst ['] noop = ;
  
  : /prefix? ( are we in prefix mode? )
***************
*** 2094,2096 ****
  
  only forth definitions base !
- 

[Win32forth-cvs] win32forth/apps/Chess TOOLSET.F,1.7,1.8

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

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

Modified Files:
	TOOLSET.F 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: TOOLSET.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Chess/TOOLSET.F,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** TOOLSET.F	13 Dec 2005 21:45:08 -0000	1.7
--- TOOLSET.F	3 Oct 2006 07:44:22 -0000	1.8
***************
*** 102,107 ****
        MB_OK MB_ICONSTOP  or
        MB_TASKMODAL or
!       z" Error:" 
!       message$ 1+ 
        NULL call MessageBox drop
   ;
--- 102,107 ----
        MB_OK MB_ICONSTOP  or
        MB_TASKMODAL or
!       z" Error:"
!       message$ 1+
        NULL call MessageBox drop
   ;
***************
*** 131,135 ****
                  ELSE    ." Error # " .
                  THEN
!                 ?LOADING @
                  IF      BASE @ >R DECIMAL
                          CR ." File: "
--- 131,135 ----
                  ELSE    ." Error # " .
                  THEN
!                 LOADING?
                  IF      BASE @ >R DECIMAL
                          CR ." File: "
***************
*** 516,520 ****
      time-buf 2 + w! \ month
      time-buf 6 + w! \ day
!     hld-max hld  0  time-buf 
      r> LOCALE_SYSTEM_DEFAULT
      call GetDateFormat dup 0= abort" ldate failed" hld-count
--- 516,520 ----
      time-buf 2 + w! \ month
      time-buf 6 + w! \ day
!     hld-max hld  0  time-buf
      r> LOCALE_SYSTEM_DEFAULT
      call GetDateFormat dup 0= abort" ldate failed" hld-count
***************
*** 526,530 ****
  
  : ltime         ( time-buf - adr count )    \ time-buf must be filled
!     hld-max hld  0  time-buf 
      TIME_FORCE24HOURFORMAT  LOCALE_SYSTEM_DEFAULT
      call GetTimeFormat dup 0= abort" ltime failed" hld-count
--- 526,530 ----
  
  : ltime         ( time-buf - adr count )    \ time-buf must be filled
!     hld-max hld  0  time-buf
      TIME_FORCE24HOURFORMAT  LOCALE_SYSTEM_DEFAULT
      call GetTimeFormat dup 0= abort" ltime failed" hld-count
***************
*** 868,872 ****
  
  : SetEnvironmentVariable  ( zstr-EnvironmentVariable-name  buffer n - )
!    pad +place pad dup +null 1+  swap 
     call SetEnvironmentVariable drop
   ;
--- 868,872 ----
  
  : SetEnvironmentVariable  ( zstr-EnvironmentVariable-name  buffer n - )
!    pad +place pad dup +null 1+  swap
     call SetEnvironmentVariable drop
   ;
***************
*** 899,903 ****
  cr ' .ldate   is .date
  cr today  .ldate space .ltime
! .id-user cr 
  
  \ April 22nd, 2002 - 22:04 renamed box to msgbox
--- 899,903 ----
  cr ' .ldate   is .date
  cr today  .ldate space .ltime
! .id-user cr
  
  \ April 22nd, 2002 - 22:04 renamed box to msgbox
***************
*** 909,913 ****
      title$   place title$   +NULL
      r>
!     title$ 1+  message$ 1+ 
      NULL call MessageBox
   ;
--- 909,913 ----
      title$   place title$   +NULL
      r>
!     title$ 1+  message$ 1+
      NULL call MessageBox
   ;
***************
*** 1030,1034 ****
  
  : ndebug  ( - ) \ shows the normal stack while debugging
!      ['] .s-base is debug-.s ; 
  
  previous previous
--- 1030,1034 ----
  
  : ndebug  ( - ) \ shows the normal stack while debugging
!      ['] .s-base is debug-.s ;
  
  previous previous
***************
*** 1186,1190 ****
                  NULL
                  0
!                 key$ 1+  
                  r> \ root-key
                  Call RegCreateKeyEx
--- 1186,1190 ----
                  NULL
                  0
!                 key$ 1+
                  r> \ root-key
                  Call RegCreateKeyEx
***************
*** 1207,1215 ****
                  then    >r  drop >r
                  MAXCOUNTED reglen !             \ init max length of string
!                 reglen          
!                 ReturnedKey$ 1+ 
!                 regtype         
                  0
!                 r>              
                  r@
                  Call RegQueryValueEx
--- 1207,1215 ----
                  then    >r  drop >r
                  MAXCOUNTED reglen !             \ init max length of string
!                 reglen
!                 ReturnedKey$ 1+
!                 regtype
                  0
!                 r>
                  r@
                  Call RegQueryValueEx
***************
*** 1522,1524 ****
  \s
  
- 

[Win32forth-cvs] win32forth/src/kernel fkernel.f, 1.38, 1.39 version.f, 1.11, 1.12

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

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

Modified Files:
	fkernel.f version.f 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: fkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v
retrieving revision 1.38
retrieving revision 1.39
diff -C2 -d -r1.38 -r1.39
*** fkernel.f	18 Sep 2006 10:08:09 -0000	1.38
--- fkernel.f	3 Oct 2006 07:44:22 -0000	1.39
***************
*** 2074,2079 ****
  0 VALUE SOURCE-POSITION \ readded for cf32 port (Samstag, August 13 2005 dbu)
  
! \ Note: ?LOADING was defined as a variable in older w32f versions !!!
! : ?LOADING      ( -- flag )     \ are we loading?
                  source-id -1 0 between 0= ;
  
--- 2074,2080 ----
  0 VALUE SOURCE-POSITION \ readded for cf32 port (Samstag, August 13 2005 dbu)
  
! \ Renamed ?LOADING to LOADING? because ?LOADING was defined as a variable
! \ in older w32f versions (Dienstag, Oktober 03 2006 dbu).
! : LOADING?      ( -- flag )     \ are we loading?
                  source-id -1 0 between 0= ;
  
***************
*** 4276,4280 ****
  
  |: _HEADER-OPT ( -- )         \ optional fields
!                 ?LOADING IF                             \ if loading...
                    LOADFILE                              \ file
                    LOADLINE @                            \ line number
--- 4277,4281 ----
  
  |: _HEADER-OPT ( -- )         \ optional fields
!                 LOADING? IF                             \ if loading...
                    LOADFILE                              \ file
                    LOADLINE @                            \ line number
***************
*** 4861,4865 ****
  \ September 23rd, 2003 - dbu
  : LINKFILE      ( a1 -- ) \ link name a1 as current file IF LOADING ONLY !!
!                 ?LOADING
                  IF
                    MAXCOUNTED _LOCALALLOC      \ alloc local path buffer
--- 4862,4866 ----
  \ September 23rd, 2003 - dbu
  : LINKFILE      ( a1 -- ) \ link name a1 as current file IF LOADING ONLY !!
!                 LOADING?
                  IF
                    MAXCOUNTED _LOCALALLOC      \ alloc local path buffer
***************
*** 4908,4912 ****
                  LOADLINE !
                  TO LOADFILE
!                 ?LOADING
                  IF
                    LOADFILE COUNT CUR-FILE PLACE \ make current again
--- 4909,4913 ----
                  LOADLINE !
                  TO LOADFILE
!                 LOADING?
                  IF
                    LOADFILE COUNT CUR-FILE PLACE \ make current again
***************
*** 5372,5376 ****
  
  |: (TYPEMSG)    ( n addr len -- )
!                 ?LOADING IF CR SOURCE TYPE THEN          \ print source line if loading
                  CR >IN @ DUP (SOURCE) @ < +              \ adjust if not at end of line
                     POCKET C@ DUP>R - SPACES              \ spaces
--- 5373,5377 ----
  
  |: (TYPEMSG)    ( n addr len -- )
!                 LOADING? IF CR SOURCE TYPE THEN          \ print source line if loading
                  CR >IN @ DUP (SOURCE) @ < +              \ adjust if not at end of line
                     POCKET C@ DUP>R - SPACES              \ spaces
***************
*** 5388,5392 ****
                    IF 2 CELLS+ ?TYPE PTRNULL THEN         \ print the message, set ptr 2 null to stop loop
                  REPEAT
!                 ?LOADING IF
                    ." in file " LOADFILE ?TYPE
                    ." at line " LOADLINE @ .
--- 5389,5393 ----
                    IF 2 CELLS+ ?TYPE PTRNULL THEN         \ print the message, set ptr 2 null to stop loop
                  REPEAT
!                 LOADING? IF
                    ." in file " LOADFILE ?TYPE
                    ." at line " LOADLINE @ .
***************
*** 5401,5405 ****
                  DUP 1+ IF                                \ only do this for real errors, not -1 throw
                    S" Error" (TYPEMSG)                    \ mark the source line in error, error
!                   ?LOADING IF EDIT-ERROR THEN            \ edit if loading
                  else drop
                  THEN ;
--- 5402,5406 ----
                  DUP 1+ IF                                \ only do this for real errors, not -1 throw
                    S" Error" (TYPEMSG)                    \ mark the source line in error, error
!                   LOADING? IF EDIT-ERROR THEN            \ edit if loading
                  else drop
                  THEN ;

[Win32forth-cvs] win32forth/src/console WinBase.f,1.3,1.4

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

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

Modified Files:
	WinBase.f 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: WinBase.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/WinBase.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** WinBase.f	1 May 2005 06:27:41 -0000	1.3
--- WinBase.f	3 Oct 2006 07:44:22 -0000	1.4
***************
*** 98,102 ****
  
     : DefinedAbort,   \ compiles an ABORT" with the file name and line where defined
!         ?LOADING
          IF  S" Defined in file: "    TEMP$ PLACE
                LOADFILE COUNT         TEMP$ +PLACE
--- 98,102 ----
  
     : DefinedAbort,   \ compiles an ABORT" with the file name and line where defined
!         LOADING?
          IF  S" Defined in file: "    TEMP$ PLACE
                LOADFILE COUNT         TEMP$ +PLACE
***************
*** 164,168 ****
  \ returns handle to resource
  : GetResource ( a f -- handle)
!    2>R  LR_LOADFROMFILE 0 0 R> R> 
     NULL  Call LoadImage  DUP ?WinError ;
  
--- 164,168 ----
  \ returns handle to resource
  : GetResource ( a f -- handle)
!    2>R  LR_LOADFROMFILE 0 0 R> R>
     NULL  Call LoadImage  DUP ?WinError ;
  
***************
*** 243,245 ****
  return to the word that called it.
  ------------------------------------------------------  Comment;
- 

[Win32forth-cvs] win32forth fkernel.exe,1.37,1.38

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

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

Modified Files:
	fkernel.exe 
Log Message:
- Renamed ?LOADING into LOADING?
- Replaced DEFER@ with ACTION-OF
- and some other minor changes

Index: fkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth/fkernel.exe,v
retrieving revision 1.37
retrieving revision 1.38
diff -C2 -d -r1.37 -r1.38
Binary files /tmp/cvspRAgFK and /tmp/cvszLr2iE differ

[Win32forth-cvs] win32forth-stc/doc readme.txt,1.6,1.7

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

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

Modified Files:
	readme.txt 
Log Message:
gah:Updated since needs now works

Index: readme.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** readme.txt	1 Oct 2006 07:38:44 -0000	1.6
--- readme.txt	2 Oct 2006 11:49:22 -0000	1.7
***************
*** 66,70 ****
  2. Type
  
- fload src\task
  fload demos\taskdemo
  
--- 66,69 ----
***************
*** 75,80 ****
  2.Type
  
- fload src\task
- fload src\multithr
  fload demos\pardemo
  
--- 74,77 ----

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

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

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

Modified Files:
	multithr.f 
Log Message:
gah:Uncommented needs (now it works),

Index: multithr.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/multithr.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** multithr.f	26 Sep 2006 08:44:05 -0000	1.1
--- multithr.f	2 Oct 2006 11:47:50 -0000	1.2
***************
*** 6,10 ****
                    \ 19apr03 for Win32Forth 6.07 with kernel v501A gah
  
! \ needs task.f
  ((
  This system uses a simpel way to do parallel arithmetic.
--- 6,10 ----
                    \ 19apr03 for Win32Forth 6.07 with kernel v501A gah
  
! needs task.f
  ((
  This system uses a simpel way to do parallel arithmetic.

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

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

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

Modified Files:
	pardemo.f taskdemo.f 
Log Message:
gah:Uncommented needs (now it works),

Index: taskdemo.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/demos/taskdemo.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** taskdemo.f	26 Sep 2006 08:44:05 -0000	1.1
--- taskdemo.f	2 Oct 2006 11:46:51 -0000	1.2
***************
*** 1,5 ****
  \ $Id$
  
! \ needs task.f \ task demo code
  
  \ -------------------- Demonstrations  --------------------
--- 1,5 ----
  \ $Id$
  
! needs task.f \ task demo code
  
  \ -------------------- Demonstrations  --------------------

Index: pardemo.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/demos/pardemo.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** pardemo.f	26 Sep 2006 08:44:05 -0000	1.1
--- pardemo.f	2 Oct 2006 11:46:51 -0000	1.2
***************
*** 1,3 ****
! \ needs multithr.f  \ 10-4-99
  
  : ascii char state @ if postpone literal then ; immediate
--- 1,3 ----
! needs multithr.f  \ 10-4-99
  
  : ascii char state @ if postpone literal then ; immediate

[Win32forth-cvs] win32forth/src FLOAT.F,1.45,1.46

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

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

Modified Files:
	FLOAT.F 
Log Message:
gah:Corrected dexing.

Index: FLOAT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v
retrieving revision 1.45
retrieving revision 1.46
diff -C2 -d -r1.45 -r1.46
*** FLOAT.F	19 May 2006 15:46:14 -0000	1.45
--- FLOAT.F	2 Oct 2006 11:45:34 -0000	1.46
***************
*** 45,53 ****
  \ ** stack (implemented in the USER area for task safety).
  
! \ *P The floating-point words can be compiled as 8 bit (for speed) or 10 bit (for accuracy).
! \ ** The default when the system is built is 8 bit, but can be set to 10 bit (in src\extend.f) by
  \ ** altering the CONSTANT B/FLOAT and re-extending the system (using setup.exe).
  \ ** If the CONSTANT is not defined then the file automatically creates it and compiles
! \ ** the code for 10 bit floats.
  
  \ *P The only error that is thrown is for FP stack Underflow (error code -45);
--- 45,53 ----
  \ ** stack (implemented in the USER area for task safety).
  
! \ *P The floating-point words can be compiled as 8 byte (for speed) or 10 byte (for accuracy).
! \ ** The default when the system is built is 8 byte, but can be set to 10 byte (in src\extend.f) by
  \ ** altering the CONSTANT B/FLOAT and re-extending the system (using setup.exe).
  \ ** If the CONSTANT is not defined then the file automatically creates it and compiles
! \ ** the code for 10 byte floats.
  
  \ *P The only error that is thrown is for FP stack Underflow (error code -45);

[Win32forth-cvs] win32forth/doc p-float.htm,1.20,1.21

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

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

Modified Files:
	p-float.htm 
Log Message:
gah:Corrected doc.

Index: p-float.htm
===================================================================
RCS file: /cvsroot/win32forth/win32forth/doc/p-float.htm,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** p-float.htm	29 Aug 2006 10:31:46 -0000	1.20
--- p-float.htm	2 Oct 2006 11:44:29 -0000	1.21
***************
*** 1,6 ****
! <html>
  <head>
! <meta http-equiv="Content-Language" content="en-gb">
! <meta name="GENERATOR" content="dexh00">
  <meta name="ProgId" content="FrontPage.Editor.Document">
  <meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
--- 1,8 ----
! <?xml version="1.0"?>
! <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
!     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
! <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
  <head>
! <meta name="GENERATOR" content="dexh v03">
  <meta name="ProgId" content="FrontPage.Editor.Document">
  <meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
***************
*** 20,28 ****
  wordsets as well as a number of useful extra words. It uses a separate floating-point
  stack (implemented in the USER area for task safety).
! </p><p>The floating-point words can be compiled as 8 bit (for speed) or 10 bit (for accuracy).
! The default when the system is built is 8 bit, but can be set to 10 bit (in src\extend.f) by
  altering the CONSTANT B/FLOAT and re-extending the system (using setup.exe).
  If the CONSTANT is not defined then the file automatically creates it and compiles
! the code for 10 bit floats.
  </p><p>The only error that is thrown is for FP stack Underflow (error code -45);
  arithmetic operations which produce values too large to be represented use infinity,
--- 22,30 ----
  wordsets as well as a number of useful extra words. It uses a separate floating-point
  stack (implemented in the USER area for task safety).
! </p><p>The floating-point words can be compiled as 8 byte (for speed) or 10 byte (for accuracy).
! The default when the system is built is 8 byte, but can be set to 10 byte (in src\extend.f) by
  altering the CONSTANT B/FLOAT and re-extending the system (using setup.exe).
  If the CONSTANT is not defined then the file automatically creates it and compiles
! the code for 10 byte floats.
  </p><p>The only error that is thrown is for FP stack Underflow (error code -45);
  arithmetic operations which produce values too large to be represented use infinity,

[Win32forth-cvs] win32forth-stc/demos/benchmarks MM.F, NONE, 1.1 Testpde.f, NONE, 1.1 bench.f, NONE, 1.1 fsl_util.f, NONE, 1.1 matrix.f, NONE, 1.1 pde1.f, NONE, 1.1

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

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

Added Files:
	MM.F Testpde.f bench.f fsl_util.f matrix.f pde1.f 
Log Message:
- 3reverse and 4reverse added to the kernel
- MM benchmark added
- Moved the benchmarks into a seperate folder

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

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

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

\ Create a floating pt matrix to hold the grid values

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

\ Rectangular Region Boundary Values

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

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

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

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

\ Circular Region Boundary Values

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

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

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

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

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


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

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

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



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

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


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

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


fvariable temp 

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

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

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

	fdrop fdrop
;




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

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

only forth also definitions decimal

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

\ needs stc/float

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

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

create date$ 32 allot
create time$ 32 allot

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

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

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

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

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

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


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

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

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

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

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

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

0 value start-time

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

' time-reset alias timer-reset

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

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

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

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

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

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

fload pde1


--- NEW FILE: fsl_util.f ---
\ anew FSL-Utilities_1.04
\ fvariable t1

\ fsl_util.f            An auxiliary file for the Forth Scientific Library
\                       contains commonly needed definitions for Win32Forth.

\ dxor, dor, dand       double xor, or, and
\ sd*                   single * double = double_product
\ v: defines use( &     For defining and setting execution vectors
\ %                     Parse next token as a FLOAT
\ S>F  F>S              Conversion between (single) integer and float
\ F,                    Store FLOAT at (aligned) HERE
\ INTEGER DOUBLE FLOAT  For setting up ARRAY types
\ ARRAY DARRAY          For declaring static and dynamic arrays
\ }                     For getting an ARRAY or DARRAY element address
\ }MALLOC }FREE         Allocate and free dynamic arrays
\ &!                    For storing ARRAY aliases in a DARRAY
\ PRINT-WIDTH           The number of elements per line for printing arrays
\ }FPRINT               Print out a given array
\ Matrix                For declaring a 2-D array
\ }}                    gets a Matrix element address
\ }}MALLOC }}FREE       Allocate and free dynamic matrices
\ Public: Private: Reset_Search_Order   controls the visibility of words
\ |frame frame|             sets up/removes a local variable frame
\ a b c d e f g h           local FVARIABLE values
\ &a &b &c &d &e &f &g &h   local FVARIABLE addresses

\ This code conforms with ANS requiring:
\      1. The Floating-Point word set with separate floating stack
\      2. The Memory word set
\      3. The words \ pick tuck nip from Core Extensions
\      4. The word d+ from Double
\      5. The words defer is f# internal external module
\         and others which are implemented in Win32Forth,
\         marked by commented-out definitions and synonyms
\      6. The word anew which creates a marker, forgetting
\         everything after it if it already exists
\      7. The assembler to define D+C and UMD/MOD.
\
\ This code has an environmental dependency on CAPS being -1 ( ignore case )
\ which is the default in Win32Forth.

\ This code is released to the public domain Pierre Henri Michel., Abbat
\ February, 1998

\ March  8th, 2003 J.v.d.Ven: Optimized }} DSMATRIX using fmacro.f
\ March 10th, 2003 J.v.d.Ven: optimized DMMATRIX    using fmacro.f
\                             restored the old DSMATRIX which had no bug.
\ March 17th, 2003 J.v.d.Ven: Changed for the updated fmacro.f
\ March 31st, 2003 J.v.d.Ven: Changed UMD/MOD for the updated fmacro.f

\ needs fmacro.f


CR .( FSL_UTIL.F        V1.04          March 10th, 2003 )
( Modified from Skip Carter's fsl_util.seq 1.20 )

\ ====================== compilation control ===========================
\ for control of conditional compilation test code
FALSE VALUE TEST-CODE?
FALSE VALUE ?TEST-CODE           \ obsolete, for backward compatiblity

\ for control of conditional compilation of Dynamic Memory
TRUE CONSTANT HAS-MEMORY-WORDS?

\ for control of conditional compilation of dereferencing unallocated array error
FALSE CONSTANT DEBUG-ARRAYS?

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

\ FSL Non ANS words

\ umd/mod     ( uquad uddiv -- udquot udmod ) unsigned quad divided by double
\ umd*        ( ud1 ud2 -- qprod )            unsigned double multiply
\ d*          ( d1 d2   -- dprod )            double multiply

CODE UMD/MOD   ( uquad uddiv -- udquot udmod )
( Modified from F-PC )
        SUB     EBP, # 8
        MOV     [EBP], EDX      \ save user pointer
        MOV     4 [EBP], EDI    \ save base pointer
        MOV     ECX, EBX
        POP     EDX
        POP     EAX
        POP     EBX
        POP     EDI
        PUSH    ESI
        PUSH    EBP
        MOV     EBP, ESP
        MOV     ESI, 8 [EBP]
        MOV     EBP, ECX
        CMP     EBP, EAX
        JA      @@6
        JNE     @@7
        CMP     EDX, EBX
        JA      @@6
@@7:    MOV     EAX, EDI
        MOV     EBX, ESI
        MOV     ESI, # -1
        MOV     EDI, ESI
        JMP     @@8
@@6:    MOV     ECX, # 40
        CLC
@@1:    RCL     ESI
        RCL     EDI
        RCL     EBX
        RCL     EAX
        JAE     @@3
@@2:    SUB     EBX, EDX
        SBB     EAX, EBP
        STC
        loop    @@1
        JMP     @@5
@@3:    CMP     EAX, EBP
        JB      @@4
        JNE     @@2
        CMP     EBX, EDX
        JAE     @@2
@@4:    CLC
        loop    @@1
@@5:    RCL     ESI
        RCL     EDI
@@8:    MOV     ECX, ESI
        POP     EBP
        POP     ESI
        POP     EDX
        PUSH    EBX
        PUSH    EAX
        PUSH    ECX
        MOV     EBX, EDI
        MOV     EDX, [EBP]
        MOV     EDI, 4 [EBP]
        ADD     EBP, # 8
        NEXT    C;


CODE D+C ( d d - d carry )
        POP     EAX
        ADD     4 [ESP], EAX
        ADC     0 [ESP], EBX
        XOR     EBX, EBX
        ADC     EBX, # 0
        NEXT    C;

: UMD* ( ud1 ud2 - uq )
  2 PICK OVER M* 2>R
  3 PICK UM* 2>R TUCK UM* 2>R
  UM* 0 2R> D+ 2R> D+C
  2R> D+ ;

: D* ( d d - d )
  3 PICK * ROT 2 PICK * +
  -ROT UM* ROT + ;


: dxor       ( d1 d2 -- d )             \ double xor
      ROT XOR -ROT XOR SWAP
;

: dor       ( d1 d2 -- d )              \ double or
      ROT OR -ROT OR SWAP
;

: dand     ( d1 d2 -- d )               \ double and
     ROT AND -ROT AND SWAP
;

\ single * double = double
: sd*   ( multiplicand  multiplier_double  -- product_double  )
             2 PICK * >R   UM*   R> +
;

\ : D0<        NIP 0< ;

: T*         TUCK UM* 2SWAP UM* SWAP >R 0 D+ R> ROT ROT ;
: T/         DUP >R UM/MOD ROT ROT R> UM/MOD NIP SWAP ;

\ : m*/        >R T* R> T/ ;

\ function vector definition
synonym v: defer
synonym defines is

: use(  STATE @ IF [COMPILE] ['] ELSE ' THEN ;  IMMEDIATE

: &     Postpone use( ; IMMEDIATE


\ pushes following value to the float stack
synonym % f#


\ : S>F   ( n -- | f: -- x )    \ integer to float
\         S>D  D>F
\ ;

\ : F>S    ( -- n | f: x -- )   \ float to integer
\         F>D DROP
\ ;

\ Store float at (aligned) HERE
\ already defined in F-PC
\ : F,   ( -- | f: x -- )         FALIGN HERE  1 FLOATS ALLOT F!  ;

\ : F=    F- F0= ;
: -FROT    FROT FROT ;
\ : F2*   % 2.0e0 F*     ;
\ : F2/   % 2.0e0 F/     ;
\ : F2DUP     FOVER FOVER ;
\ : F2DROP    FDROP FDROP ;


\ : CELL-    [ 1 CELLS ] LITERAL - ;           \ backup one cell


0 VALUE TYPE-ID               \ for building structures
FALSE VALUE STRUCT-ARRAY?

\ size of a regular integer
1 cells CONSTANT INTEGER

\ size of a double integer
2 cells CONSTANT DOUBLE

\ size of a regular float
\ synonym fvalue float   \ float is not defined in STC Forth yet
\ 1 floats CONSTANT FLOAT
( Note: This conflicts with the previous definition of float
  which declares a floating-point to-word. )


\ 1-D array definition
\    -----------------------------
\    | cell_size | data area     |
\    -----------------------------

: MARRAY ( n cell_size -- | -- addr )             \ monotype array
     CREATE
       DUP , * ALLOT
     DOES> CELL+
;

\    -----------------------------
\    | id | cell_size | data area |
\    -----------------------------

: SARRAY ( n cell_size -- | -- id addr )          \ structure array
     CREATE
       TYPE-ID ,
       DUP , * ALLOT
     DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
;

: ARRAY
     STRUCT-ARRAY? IF   SARRAY FALSE TO STRUCT-ARRAY?
                   ELSE MARRAY
                   THEN
;


\ word for creation of a dynamic array (no memory allocated)

\ Monotype
\    ------------------------
\    | data_ptr | cell_size |
\    ------------------------

: DMARRAY   ( cell_size -- )   CREATE  0 , ,
                               DOES>
                                    @ CELL+
;

\ Structures
\    ----------------------------
\    | data_ptr | cell_size | id |
\    ----------------------------

: DSARRAY   ( cell_size -- )  CREATE  0 , , TYPE-ID ,
                              DOES>
                                    DUP 2 CELLS+ @ SWAP
                                    @ CELL+
;


: DARRAY   ( cell_size -- )
     STRUCT-ARRAY? IF   DSARRAY FALSE TO STRUCT-ARRAY?
                   ELSE DMARRAY
                   THEN
;

: }FREE ( &array{ )
( Usage: array{ }free )
  >BODY DUP @ FREE DROP OFF ;

: }MALLOC ( &array{ #elements )
( Usage: & array{ 5 }malloc allocates an array of 5 elements )
  [ DEBUG-ARRAYS? ] [IF]
  OVER >BODY @ IF ." Warning: array is already allocated" THEN [THEN]
  OVER }FREE ( deallocate the array to prevent memory leaks )
  OVER >BODY CELL+ @ ( get the element size )
  TUCK * CELL+ ( add room to store the element size )
  ALLOCATE IF ( there was an error)
    2DROP 0 SWAP >BODY ! ( store 0 in the array pointer )
  ELSE
    TUCK ! ( store the element size )
    SWAP >BODY ! ( store the array location )
  THEN ;

v: do-align
v: do-aligned

: default-alignments  & ALIGN defines do-align  & ALIGNED defines do-aligned ;
: float-alignments    & FALIGN defines do-align  & FALIGNED defines do-aligned ;

: XINTEGER  1 CELLS  default-alignments ;

: XDOUBLE   2 CELLS  default-alignments ;

: XFLOAT   1  FLOATS    float-alignments ;


: XARRAY ( n size -- | -- addr )       \ experimental array with alignment
     CREATE
       DUP , DO-ALIGN * ALLOT
     DOES> CELL+ DO-ALIGNED
;


\ word for aliasing arrays,
\  typical usage:  a{ & b{ &!  sets b{ to point to a{'s data

: &!    ( addr_a &b -- )
        SWAP CELL- SWAP >BODY  !
;

DEBUG-ARRAYS? [IF]
: unallocated? ( array-address - array-address )
( Use ABORT" or THROW as you like. )
  DUP 0=
\ IF -9 THROW THEN
  ABORT" Array or matrix is not allocated"
  ;
[THEN]

: }   ( addr n -- addr[n])       \ word that fetches 1-D array addresses
  OVER CELL-
  [ DEBUG-ARRAYS? ] [IF] unallocated? [THEN]
  @ * SWAP + ;


VARIABLE print-width     6 print-width !

: }fprint ( n 'addr -- )       \ print n elements of a float array
        SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                  DUP I } F@ F. LOOP
        DROP
;

: }iprint ( n 'addr -- )        \ print n elements of an integer array
       SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                 DUP I } @ . LOOP
       DROP
;

: }fcopy ( 'src 'dest n -- )    \ copy one array into another
         0 DO
                 OVER I } F@
                 DUP  I } F!
               LOOP
         2DROP
;



\ 2-D array definition,

\ Monotype
\    -----------------------------------
\    | m | cell_size |  data area |
\    -----------------------------------

: MMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
        CREATE
           OVER , DUP ,
           * * ALLOT
        DOES>  [ 2 CELLS ] LITERAL +
;

\ Structures
\    -----------------------------------
\    | id | m | cell_size |  data area |
\    -----------------------------------

: SMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
        CREATE TYPE-ID ,
           OVER , DUP ,
           * * ALLOT
        DOES>  DUP @ TO TYPE-ID
               [ 3 CELLS ] LITERAL +
;


: MATRIX  ( n m size -- )           \ defining word for a 2-d matrix
     STRUCT-ARRAY? IF   SMATRIX FALSE TO STRUCT-ARRAY?
                   ELSE MMATRIX
                   THEN

;

\  Old }}
: }}    ( addr i j -- addr[i][j] )    \ word to fetch 2-D array addresses
  >R >R                  \ indices to return stack temporarily
  DUP CELL- CELL-
  [ DEBUG-ARRAYS? ] [IF] unallocated? [THEN]
  2@     \ &a[0][0] size m
  R> * R> + * + ; 
((
code }}    ( addr i j -- addr[i][j] )    \ word to fetch 2-D array addresses
        >r >r            \ indices to return stack temporarily
        DUP 2CELLS-  
        2@   \ &a[0][0] size m
        r> * r> + * +
   next,
   end-code
))
\ ( addr i j -- addr[i][j] )    \ word to fetch 2-D array addresses \ indices to return stack temporarily
\ &a[0][0] size m
\ Dynamic 2-D array definition,
\    ------------------------------
\    | data_ptr | cell_size | (id) |
\    ------------------------------

\ word for creation of a dynamic array (no memory allocated)

\ Monotype
\    ------------------------
\    | data_ptr | cell_size |
\    ------------------------

\  Old  DMMATRIX
: DMMATRIX   ( cell_size -- )
  CREATE  0 , ,
  DOES>  @  2 CELLS+
;
((
code _DMMATRIX  ( adr -- addr+2cells)
     @ 2 ass-lit CELLS+
     next,
     end-code

: DMMATRIX   ( cell_size -- )
  qalign
  CREATE  0 , ,
  DOES> _DMMATRIX
 ;      
))

\ Structures
\    ----------------------------
\    | data_ptr | cell_size | id |
\    ----------------------------

: DSMATRIX   ( cell_size -- )
  CREATE  0 , , TYPE-ID ,
  DOES> DUP 2 CELLS+ @ SWAP @ 2 CELLS+
;


: DMATRIX   ( cell_size -- )
     STRUCT-ARRAY? IF   DSMATRIX FALSE TO STRUCT-ARRAY?
                   ELSE DMMATRIX
                   THEN
;

synonym }}FREE }FREE

: }}MALLOC ( &matrix{{ rows cols )
( Allocates a matrix. The element size is known at compile time
  and is stored at &matrix{{; the array dimensions are specified
  at runtime. )
  [ DEBUG-ARRAYS? ] [IF]
  2 PICK >BODY @ IF ." Warning: matrix is already allocated" THEN [THEN]
  2 PICK }}FREE ( deallocate the array to prevent memory leaks )
  2 PICK >BODY CELL+ @ ( get the element size )
  2DUP 2>R * * 2 CELLS+ ( add room to store the element size and row length )
  ALLOCATE IF ( there was an error)
    2R> 3DROP 0 SWAP >BODY ! ( store 0 in the array pointer )
  ELSE
    R> R> 2 PICK 2! ( store the element size and row length )
    SWAP >BODY ! ( store the array location )
  THEN ;






: }}fprint ( n m 'addr -- )       \ print n×m elements of a float 2-D array
        ROT ROT SWAP 0 DO
                         DUP 0 DO
                                  OVER J I  }} F@ F.
                         LOOP

                         CR
                  LOOP
        2DROP
;

: }}iprint ( n m 'addr -- )       \ print n×m elements of a float 2-D array
  ROT ROT SWAP 0 DO
    DUP 0 DO
      OVER J I  }} @ .
    LOOP
    CR
  LOOP
  2DROP
;

: }}fcopy ( 'src 'dest n m  -- )      \ copy n×m elements of 2-D array src to dest
        SWAP 0 DO
                 DUP 0 DO
                            2 PICK J I  }} F@
                            OVER J I }} F!
                        LOOP
                  LOOP
        DROP 2DROP
;


\ Code for hiding words that the user does not need to access
\ into a hidden wordlist.
\ Private:
\          will add HIDDEN to the search order and make HIDDEN
\          the compilation wordlist.  Words defined after this will
\          compile into the HIDDEN vocabulary.
\ Public:
\          will restore the compilation wordlist to what it was before
\          HIDDEN got added, it will leave HIDDEN in the search order
\          if it was already there.   Words defined after this will go
\          into whatever the original vocabulary was, but HIDDEN words
\          are accessable for compilation.
\ Reset_Search_Order
\          This will restore the compilation wordlist and search order
\          to what they were before HIDDEN got added.  HIDDEN words will
\          no longer be visible.

\ These three words can be invoked in any order, multiple times, in a
\ file, but Reset_Search_Order should finally be called last in order to
\ restore things back to the way they were before the file got loaded.

\ WARNING: you can probably break this code by setting vocabularies while
\          Public: or Private: are still active.

synonym Private: internal
synonym Public: external
synonym Reset_Search_Order module

\  Code for local fvariables, loosely based upon Wil Baden's idea presented
\  at FORML 1992.
\  The idea is to have a fixed number of variables with fixed names.
\  I believe the code shown here will work with any, case insensitive,
\  ANS Forth.

\  FRAME| always pushes 8 floats onto the flocal stack; if your
\  arguments are A and B you can use C through H for local storage.

\  Note: The variables are in the opposite order than used by { ... } .

\  example:  : test  2e 3e FRAME| a b |  a f. b f. |FRAME ;
\            test <cr> 3.0000 2.0000 ok

\  PS: Don't forget to use |FRAME before an EXIT .


8 CONSTANT /flocals

: (frame) ( n -- ) FLOATS ALLOT ;

: FRAME|
        0 >R
        BEGIN   BL WORD  COUNT  1 =
                SWAP C@  [CHAR] | =
                AND 0=
        WHILE   POSTPONE F,  R> 1+ >R
        REPEAT
        /FLOCALS R> - DUP 0< ABORT" too many flocals"
        POSTPONE LITERAL  POSTPONE (frame) ; IMMEDIATE

: |FRAME ( -- ) [ /FLOCALS NEGATE ] LITERAL (FRAME) ;

: &h            HERE [ 1 FLOATS ] LITERAL - ;
: &g            HERE [ 2 FLOATS ] LITERAL - ;
: &f            HERE [ 3 FLOATS ] LITERAL - ;
: &e            HERE [ 4 FLOATS ] LITERAL - ;
: &d            HERE [ 5 FLOATS ] LITERAL - ;
: &c            HERE [ 6 FLOATS ] LITERAL - ;
: &b            HERE [ 7 FLOATS ] LITERAL - ;
: &a            HERE [ 8 FLOATS ] LITERAL - ;

: a             &a F@ ;
: b             &b F@ ;
: c             &c F@ ;
: d             &d F@ ;
: e             &e F@ ;
: f             &f F@ ;
: g             &g F@ ;
: h             &h F@ ;

( Note: B and E were previously defined as words interfacing with the editor. )





--- NEW FILE: bench.f ---

\ IN-SYSTEM

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

create date$ 32 allot
create time$ 32 allot
                      
: get-local-time ( -- )                 \ get the local computer date and time
[...1054 lines suppressed...]

   cr cr
   .ann ." This system's application performance" .specifics CR
   .header
   [$  
     $SIEVE$  $FIB$  $SORT$  $RAND$  $CODE77$ $DHRY$
\   [ ANSSYSTEM ] [IF]  $DHRY$  [THEN]
   CR  ." Total:"  1 $]
;


decimal
cr cr .( Benchmark code size = ) code-here start-here - . .( bytes.) cr

BENCHMARK

CR CR .( To run the benchmark program again, type BENCHMARK )




--- NEW FILE: MM.F ---
\ MM.FTH - Forth Floating point matrix multiply benchmark



0 [IF] ======================================================
This file is maintained by:
  Stephen Pelc
  MicroProcessor Engineering
  133 Hill Lane
  Southampton SO15 5AF
  England
  tel:   +44 (0)23 8063 1441
  fax:   +44 (0)23 8033 9691
  email: st...@mp...

The Forth MM benchmark was contributed by Marcel Hendrix, derived
from a C benchmark by Mark Smotherman. The code may be freely
redistributed. If you modify this code, and want the changes to
be incorporated in future releases, please send the changes to
Stephen Pelc.

The code is used to test MPE's VFX code generator and optimiser.
Except for legacy reasons, no attempt is made to maintain this
code for non-optimising and non-ANS systems.

The code is maintained to test ANS Forth systems. It does not take
advantage of system specific extensions, except for one (see below).
However, it uses the utility file from the Forth Scientific Library,
which is intended to be hacked for specific systems as much as you
can. Consequently, when you contribute results, please also contribute
the FSL utility file as well.


*************************************
On 2.8GHz P4, 512Mb DDR266 RAM, XPpro
*************************************

SwiftForth 2.00.3 19may2000
standard FPMATH.F and FSL-UTIL.F
all-tests
500x500 mm - normal algorithm                       3.282 secs.
500x500 mm - temporary variable in loop             9.781 secs.
500x500 mm - unrolled inner loop, factor of 4       9.969 secs.
500x500 mm - unrolled inner loop, factor of 8       9.922 secs.
500x500 mm - unrolled inner loop, factor of 16      9.906 secs.
500x500 mm - pointers used to access matrices       4.047 secs.
500x500 mm - pointers used, unrolled by 4           4.141 secs.
500x500 mm - transposed B matrix                    8.891 secs.
500x500 mm - interchanged inner loops               8.797 secs.
500x500 mm - blocking, step size of 20              9.234 secs.
500x500 mm - Robert's algorithm                     2.812 secs.
500x500 mm - T. Maeno's algorithm, subarray 20x20   3.766 secs.
500x500 mm - Generic Maeno, subarray 20x20          3.125 secs.
500x500 mm - D. Warner's algorithm, subarray 20x20  9.344 secs.
=========================================================
Total                                              97.017 secs. ok

iForth version 1.12.8722, generated 23:39:13, June 8, 2002.
optimised FSL_UTIL.FRT
500x500 mm - normal algorithm                       1.735 secs.
500x500 mm - temporary variable in loop             3.296 secs.
500x500 mm - unrolled inner loop, factor of 4       3.172 secs.
500x500 mm - unrolled inner loop, factor of 8       3.125 secs.
500x500 mm - unrolled inner loop, factor of 16      3.094 secs.
500x500 mm - pointers used to access matrices       1.734 secs.
500x500 mm - pointers used, unrolled by 4           1.578 secs.
500x500 mm - transposed B matrix                    1.687 secs.
500x500 mm - interchanged inner loops               2.938 secs.
500x500 mm - blocking, step size of 20              3.125 secs.
500x500 mm - Robert's algorithm                     0.593 secs.
500x500 mm - T. Maeno's algorithm, subarray 20x20   0.875 secs.
500x500 mm - Generic Maeno, subarray 20x20          0.922 secs.
500x500 mm - D. Warner's algorithm, subarray 20x20  1.765 secs.
=========================================================
Total                                              29.639 secs. ok

VFX Forth Version: 3.70 [build 1659] Build date: 5 July 2004
with optimising NDP387 and VFUTILS.FTH
all-tests
500x500 mm - normal algorithm                       1.641 secs.
500x500 mm - temporary variable in loop             2.766 secs.
500x500 mm - unrolled inner loop, factor of 4       2.563 secs.
500x500 mm - unrolled inner loop, factor of 8       2.562 secs.
500x500 mm - unrolled inner loop, factor of 16      2.563 secs.
500x500 mm - pointers used to access matrices       2.984 secs.
500x500 mm - pointers used, unrolled by 4           1.578 secs.
500x500 mm - transposed B matrix                    1.187 secs.
500x500 mm - interchanged inner loops               2.172 secs.
500x500 mm - blocking, step size of 20              2.328 secs.
500x500 mm - Robert's algorithm                     0.578 secs.
500x500 mm - T. Maeno's algorithm, subarray 20x20   0.578 secs.
500x500 mm - Generic Maeno, subarray 20x20          0.656 secs.
500x500 mm - D. Warner's algorithm, subarray 20x20  1.282 secs.
=========================================================
Total                                              25.438 secs. ok


===============================================================
[THEN]


\ ************************************************
\ Select system to be tested, set FORTHSYSTEM
\ to value of selected target.
\ Set SPECIFICS false to avoid system dependencies.
\ Set SPECIFICS true to show off implementation tricks.
\ Set HACKING false to use the base source code.
\ Set HACKING true to optimise the source code.
\ ************************************************

1  constant VfxForth3           \ MPE VFX Forth v3.x
2  constant Pfw22               \ MPE ProForth 2.2
3  constant SwiftForth20        \ FI SwiftForth 2.0
4  constant SwiftForth15        \ FI SwiftForth 1.5
5  constant Win32Forth          \ Win32Forth 4.2
6  constant BigForth            \ BigForth 11 July 1999
7  constant BigForth-Linux      \ BigForth 11 July 1999
8  constant iForth              \ iForth 1.12 5 Aug 2001
9  constant iForth20            \ iForth 2.0 8 June 2002
10  constant SwiftForth22       \ FI SwiftForth 2.2.2.9

\ VfxForth3 constant ForthSystem \ select system to test
\ iForth20 constant ForthSystem
\ SwiftForth22 constant ForthSystem
 Win32Forth constant ForthSystem

 false constant specifics       \ true to use system dependent code
 false constant hacking         \ true to use "guru" level code that
                                \ makes assumptions of an optimising compiler.
 true constant ANSSystem        \ Some Forth 83 systems cannot compile
                                \ all the test examples without carnal
                                \ knowledge, especially if the compiler
                                \ checks control structures.

: .specifics    \ -- ; display trick state
  ."  using"  specifics 0=
  if  ."  no"  then
  ."  extensions"
;

: .hacking      \ -- ; display hack state
  ."  using"  hacking 0=
  if  ."  no"  then
  ."  hackery"
;

: .testcond     \ -- ; display test conditions
  .specifics ."  and" .hacking
;


\ *****************************
\ VFX Forth for Windows harness
\ *****************************

VfxForth3 ForthSystem = [IF]

[defined] +idata [if]
  +idata        \ enable P4 data options
  variable zzz  \ preallocate first IDATA buffer
[then]

true constant ndp?      \ -- flag ; true if NDP stack version

c" C:\Products\PfwVfx.dev\WindowsBox\Sources\Lib"
  setmacro LibDir
c" C:\Products\PfwVfx.dev\WindowsBox\Sources\Lib\FSL\library"
  setmacro FslDir
c" C:\Products\PfwVfx.dev\WindowsBox\Sources\Lib"
  setmacro NdpDir

ndp? [if]
  S" %NdpDir%\Ndp387" INCLUDED
[else]
  S" %NdpDir%\Hfp387" INCLUDED
[then]

  char . dp-char !                      \ select ANS number conversion
  char . fp-char !

-short-branches                         \ disable short forward branches
S" %FslDir%\VfxUtil" INCLUDED           \ FSL harness for VFX Forth 3.x

: HTAB  out @ - spaces ; \ n -- ; step to position n
: DEC.  ( n -- ) BASE @ >R DECIMAL . R> BASE ! ;

extern: DWORD PASCAL GetTickCount( void );

: COUNTER       \ -- ms
  GetTickCount ;

: DFVARIABLE    #16 buffer:  ;

[THEN]


\ ******************************
\ iForth 2.0 for Windows harness
\ ******************************

iForth20 ForthSystem = [IF]

NEEDS -miscutil
NEEDS -dynlink
  0 VALUE 'counter
  S" kernel32.dll" LIBRARY-OPEN THROW ( dll)
  S" GetTickCount" ROT LIBRARY-FIND THROW TO 'counter

: counter ( -- ms ) 0 'counter FOREIGN ;

: defined       \ caddr -- flag
  find nip
;

\ include c:\dfwforth\examples\fsl\fsl_util.frt
include c:\dfwforth\include\fsl_util.frt

: &  ; IMMEDIATE

[THEN]


\ **********************
\ SwiftForth 2.0 harness
\ **********************

SwiftForth20 ForthSystem = [IF]

include C:\MyApps\SwiftForth20\Lib\Options\fpmath.f
: f<>   F= 0=  ;

include C:\MyApps\SwiftForth20\Lib\FSLib\Library\fsl-util.f

: HTAB    get-xy drop - spaces  ; \ n -- ; step to position n
: DEC.  ( n -- ) BASE @ >R DECIMAL . R> BASE ! ;

[THEN]


\ **********************
\ SwiftForth 2.2 harness
\ **********************

SwiftForth22 ForthSystem = [IF]

\ FPCONFIG.F should be in the BENCHMRK folder
include C:\MyApps\SwiftForth2229\Lib\Options\fpmath.f
: f<>   F= 0=  ;

include C:\MyApps\SwiftForth2229\Unsupported\FSLib\Library\fsl-util.f

: HTAB    get-xy drop - spaces  ; \ n -- ; step to position n
: DEC.  ( n -- ) BASE @ >R DECIMAL . R> BASE ! ;

[THEN]


\ ******************
\ Win32Forth harness
\ ******************

Win32Forth ForthSystem = [IF]

fload fsl_util.f

: COUNTER       \ -- ms
  Call GetTickCount ;

: >pos          \ n -- ; step to position n
  getxy drop - spaces ;

: HTAB  #TAB ; \ n -- ; step to position n

: M/            \ d n1 -- quot
  fm/mod nip ;

: buffer:       \ n -- ; -- addr
  create
    here  over allot  swap erase ;

: [o/n]         \ -- ; stop optimiser treating * DROP etc as no code
; immediate

: SendMessage   \ h m w l -- res
  4reverse      \ was swap 2swap swap   \ Win32Forth uses reverse order
  Call SendMessage ;

: GetTickCount  \ -- ms
  Call GetTickCount ;

: DEC.  ( n -- ) BASE @ >R DECIMAL . R> BASE ! ;

: F<>   ( F: r -- ) ( -- bool ) F= 0= ;

: DFVARIABLE ( -- ) CREATE 8 ALLOT ;

: 2+ ( n1 -- n2 ) 2 + ;

[THEN]


\ ********************
\ Start of common code
\ ********************

500 CONSTANT N  \ -- n ; number of iterations to use


\ ******************
\ Timing and display
\ ******************

50 CONSTANT TCOL

0 VALUE _time_
VARIABLE TotalTime

: TIMER-RESET ( -- )
  COUNTER TO _time_  ;

: #? ( d -- d )
  2DUP OR 0=
  IF  BL HOLD  ELSE  #  THEN ;

: .secs         \ ms --
  0 <#  BL HOLD # # # [char] . HOLD # #? #?  #> TYPE
  ." secs."
;

: .ELAPSED ( -- )
  TCOL HTAB
  COUNTER _time_ -
  dup TotalTime +!
  .secs
;

: .algo         \ caddr u --
\ Display size and algorithm from string
  CR N 0 .R  ." x"  N 0 .R  SPACE TYPE
;


\ *****
\ TOOLS
\ *****

DEFINED DF@+  NIP 0= [IF] : DF@+  ( addr -- addr' ) ( F: -- r ) DUP DF@ DFLOAT+ ; [THEN]
DEFINED DF+!  NIP 0= [IF] : DF+!  ( addr -- )       ( F: r -- ) DUP DF@ F+ DF!  ; [THEN]
DEFINED DF!+  NIP 0= [IF] : DF!+  ( addr -- addr' ) ( F: r -- ) DUP DF! DFLOAT+ ; [THEN]
DEFINED DF+!+ NIP 0= [IF] : DF+!+ ( addr -- addr' ) ( F: r -- ) DUP DF@ F+ DF!+ ; [THEN]


: *DSUM  ( addr1 addr2 count -- addr1' addr2' ) ( F: -- n )
  0e 0 ?DO  SWAP DF@+ SWAP DF@+ F* F+  LOOP ;

: *DSUML ( addr1 addr2 count stride2 -- addr1' addr2' ) ( F: -- r )
  LOCALS| stride2 |
  0e 0 ?DO
    SWAP DF@+
    SWAP DUP DF@ stride2 +
    F* F+
  LOOP ;



CHAR x CONSTANT 'x'
CHAR n CONSTANT 'n'
CHAR v CONSTANT 'v'
CHAR u CONSTANT 'u'
CHAR p CONSTANT 'p'
CHAR t CONSTANT 't'
CHAR i CONSTANT 'i'
CHAR b CONSTANT 'b'
CHAR m CONSTANT 'm'
CHAR r CONSTANT 'r'
CHAR w CONSTANT 'w'
CHAR z CONSTANT 'z'


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


DOUBLE DMATRIX  a{{
DOUBLE DMATRIX  b{{
DOUBLE DMATRIX  c{{
DOUBLE DMATRIX  d{{
DOUBLE DMATRIX bt{{

0 [IF] ================================================
\ Useful test bits

: .a{{          \ -- ; display A{{ matrix
  cr ." A{{"
  N 0 ?DO
    cr  N 0 ?DO
      a{{ J I }} DF@ F.
    LOOP
  LOOP
;

: .b{{          \ -- ; display B{{ matrix
  cr ." B{{"
  N 0 ?DO
    cr  N 0 ?DO
      b{{ J I }} DF@ F.
    LOOP
  LOOP
;

: .c{{          \ -- ; display B{{ matrix
  cr ." C{{"
  N 0 ?DO
    cr  N 0 ?DO
      c{{ J I }} DF@ F.
    LOOP
  LOOP
;

: .bt{{         \ -- ; display B{{ matrix
  cr ." BT{{"
  N 0 ?DO
    cr  N 0 ?DO
      bt{{ J I }} DF@ F.
    LOOP
  LOOP
;

[THEN]

: SET-COEFFICIENTS ( -- )
\ Set coefficients so that result matrix should have row entries
\ equal to (1/2)*n*(n-1)*i in row i
  N 0 ?DO
    N 0 ?DO
      J S>F FDUP b{{ J I }} DF!  a{{ J I }} DF!
    LOOP
  LOOP ;

: FLUSH-CACHE ( -- )
  N 0 ?DO
    N 0 ?DO
      0e d{{ J I }} DF!
    LOOP
  LOOP ;

FVARIABLE row_sum
FVARIABLE sum

: CHECK-RESULT ( -- )
  0e row_sum F!
  N N 1- * 2/ S>F sum F!
  N 0 ?DO
    I S>F sum F@ F* row_sum F!
    N 0 ?DO
      a{{ J I }} DF@  J S>F  F<> IF
        CR ." error in result entry a{{ " J DEC. I DEC. ." }}: "
        a{{ J I }} DF@ F. ." <> "  J S>F F.
        UNLOOP UNLOOP EXIT
      THEN
      b{{ J I }} DF@ J S>F  F<> IF
        CR ." error in result entry b{{ " J DEC. I DEC. ." }}: "
        b{{ J I }} DF@ F. ." <> "  J S>F F.
        UNLOOP UNLOOP EXIT
      THEN
      c{{ J I }} DF@ row_sum F@ F<> IF
        CR ." error in result entry c{{ " J DEC. I DEC. ." }}: "
        c{{ J I }} DF@ F. ." <> " row_sum F@ F.
        UNLOOP UNLOOP EXIT
      THEN
    LOOP
  LOOP  ;

: NORMAL() ( -- )
  s" mm - normal algorithm" .algo
  TIMER-RESET
  N 0 ?DO
    N 0 ?DO
      a{{ J 0 }} b{{ 0 I }} N N DFLOATS *DSUML 2DROP  c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED  ;

: TNSQ() ( -- )
  0 LOCALS| K |
  s" mm - temporary variable in loop" .algo
  TIMER-RESET
  N 0 ?DO  I TO K
    N 0 ?DO
      a{{ J 0 }} DF@  b{{ 0 I }} DF@ F*
      N 1 ?DO
        a{{ K I }} DF@  b{{ I J }} DF@ F* F+
      LOOP
      c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED ;

: UNROLL4() ( -- )
  0 0 LOCALS| K S |
  s" mm - unrolled inner loop, factor of 4" .algo
  TIMER-RESET
  N 0 ?DO  I TO K
    N 0 ?DO  0e  0 TO S
      N 3 - 0 ?DO  I TO S
        a{{ K I     }} DF@  b{{ I     J }} DF@ F* F+
        a{{ K I 1+  }} DF@  b{{ I 1+  J }} DF@ F* F+
        a{{ K I 2+  }} DF@  b{{ I 2+  J }} DF@ F* F+
        a{{ K I 3 + }} DF@  b{{ I 3 + J }} DF@ F* F+
      4 +LOOP
      N  S 4 + ?DO
        a{{ K I     }} DF@  b{{ I     J }} DF@ F* F+
      LOOP
      c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED ;

: UNROLL8() ( -- )
  0 0 LOCALS| K S |
  s" mm - unrolled inner loop, factor of 8" .algo
  TIMER-RESET
  N 0 ?DO  I TO K
    N 0 ?DO  0e  0 TO S
      N 7 - 0 ?DO  I TO S
        a{{ K I     }} DF@  b{{ I     J }} DF@ F* F+
        a{{ K I 1+  }} DF@  b{{ I 1+  J }} DF@ F* F+
        a{{ K I 2+  }} DF@  b{{ I 2+  J }} DF@ F* F+
        a{{ K I 3 + }} DF@  b{{ I 3 + J }} DF@ F* F+
        a{{ K I 4 + }} DF@  b{{ I 4 + J }} DF@ F* F+
        a{{ K I 5 + }} DF@  b{{ I 5 + J }} DF@ F* F+
        a{{ K I 6 + }} DF@  b{{ I 6 + J }} DF@ F* F+
        a{{ K I 7 + }} DF@  b{{ I 7 + J }} DF@ F* F+
      8 +LOOP
      N  S 8 + ?DO
        a{{ K I     }} DF@  b{{ I     J }} DF@ F* F+
      LOOP
      c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED ;

: UNROLL16() ( -- )
  0 0 LOCALS| K S |
  s" mm - unrolled inner loop, factor of 16" .algo
  TIMER-RESET
  N 0 ?DO  I TO K
    N 0 ?DO  0e 0 TO S
      N 15 - 0 ?DO  I TO S
        a{{ K I      }} DF@  b{{ I      J }} DF@ F* F+
        a{{ K I  1+  }} DF@  b{{ I  1+  J }} DF@ F* F+
        a{{ K I  2+  }} DF@  b{{ I  2+  J }} DF@ F* F+
        a{{ K I  3 + }} DF@  b{{ I  3 + J }} DF@ F* F+
        a{{ K I  4 + }} DF@  b{{ I  4 + J }} DF@ F* F+
        a{{ K I  5 + }} DF@  b{{ I  5 + J }} DF@ F* F+
        a{{ K I  6 + }} DF@  b{{ I  6 + J }} DF@ F* F+
        a{{ K I  7 + }} DF@  b{{ I  7 + J }} DF@ F* F+
        a{{ K I  8 + }} DF@  b{{ I  8 + J }} DF@ F* F+
        a{{ K I  9 + }} DF@  b{{ I  9 + J }} DF@ F* F+
        a{{ K I 10 + }} DF@  b{{ I 10 + J }} DF@ F* F+
        a{{ K I 11 + }} DF@  b{{ I 11 + J }} DF@ F* F+
        a{{ K I 12 + }} DF@  b{{ I 12 + J }} DF@ F* F+
        a{{ K I 13 + }} DF@  b{{ I 13 + J }} DF@ F* F+
        a{{ K I 14 + }} DF@  b{{ I 14 + J }} DF@ F* F+
        a{{ K I 15 + }} DF@  b{{ I 15 + J }} DF@ F* F+
      16 +LOOP
      N S  16 + ?DO
        a{{ K I      }} DF@  b{{ I      J }} DF@ F* F+
      LOOP
      c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED ;

: UNROLL ( n -- )
  CASE
     4 OF UNROLL4()  ENDOF
     8 OF UNROLL8()  ENDOF
    16 OF UNROLL16() ENDOF
          CR ." mm - unrolled inner loop, factor of " DUP DEC. ." not implemented"
  ENDCASE ;

specifics [if]
  VfxForth3 ForthSystem = [if]  -fasti  [then]
[then]

: PNSQ4() ( -- )
  0 LOCALS| S |
  s" mm - pointers used, unrolled by 4" .algo
  TIMER-RESET
  N 0 ?DO
    N 0 ?DO
      0e  a{{ J 0 }}  b{{ 0 I }}  0 TO S
      N 3 -   0 ?DO  I TO S
        SWAP DF@+ SWAP DUP DF@ F* F+ N DFLOATS +
        SWAP DF@+ SWAP DUP DF@ F* F+ N DFLOATS +
        SWAP DF@+ SWAP DUP DF@ F* F+ N DFLOATS +
        SWAP DF@+ SWAP DUP DF@ F* F+ N DFLOATS +
      4 +LOOP
      N   S 4 + ?DO
        SWAP DF@+ SWAP DUP DF@ F* F+ N DFLOATS +
      LOOP
      c{{ J I }} DF!  2DROP
    LOOP
  LOOP
  .ELAPSED ;

: PNSQ() ( n -- )
  DUP 4 =
  IF  DROP PNSQ4() EXIT  THEN
  s" mm - pointers used to access matrices" .algo
  ?DUP IF
    ." , unroll factor of " DEC. ." not allowed" EXIT
  THEN
  TIMER-RESET
  N 0 ?DO
    N 0 ?DO
      0e  a{{ J 0 }}  b{{ 0 I }}
      N 0 ?DO
        SWAP DF@+ SWAP
        DUP DF@ N DFLOATS +
        F* F+
\        DUP DF@
\        F* F+
\        N DFLOATS +
      LOOP
      c{{ J I }} DF!  2DROP
    LOOP
  LOOP
  .ELAPSED ;

specifics [if]
  VfxForth3 ForthSystem = [if]  +fasti  [then]
[then]


: TRANSPOSE() ( -- )
  0 LOCALS| K |
  s" mm - transposed B matrix" .algo
  TIMER-RESET
  N 0 ?DO
    N 0 ?DO
      b{{ J I }} DF@  bt{{ I J }} DF!
    LOOP
  LOOP
  N 0 ?DO  I TO K
    N 0 ?DO
      a{{ J 0 }} DF@  bt{{ I 0 }} DF@ F*
      N 1 ?DO
        a{{ K I }} DF@  bt{{ J I }} DF@ F* F+
      LOOP
      c{{ J I }} DF!
    LOOP
  LOOP
  .ELAPSED ;

\ from Monica Lam ASPLOS-IV paper
: REG_LOOPS() ( -- )
  0 LOCALS| K |
  s" mm - interchanged inner loops" .algo
  TIMER-RESET
  N 0 ?DO
    N 0 ?DO
      0e c{{ J I }} DF!
    LOOP
  LOOP
  N 0 ?DO  I TO K
    N 0 ?DO
      a{{ J I }} DF@
      N 0 ?DO
        FDUP b{{ J I }} DF@ F* c{{ K I }} DF+!
      LOOP
      FDROP
    LOOP
  LOOP
  .ELAPSED ;

: TILING() ( step -- )
  s" mm - blocking, step size of " .algo  DUP DEC.
  DUP 4 N 1+ WITHIN 0= IF
    drop ." is unreasonable"  EXIT
  THEN
  TIMER-RESET
  0 0 0 LOCALS| K kk jj step |
  N 0 ?DO  N 0 ?DO  0e c{{ J I }} DF!  LOOP LOOP
  N 0 ?DO  I TO kk
    N 0 ?DO  I TO jj
      N 0 ?DO   I TO K
        kk step + N MIN  kk ?DO
          a{{ J I }} DF@
          jj step + N MIN  jj ?DO
            FDUP b{{ J I }} DF@ F*  c{{ K I }} DF+!
          LOOP
          FDROP
        LOOP
      LOOP
    step +LOOP
  step +LOOP
  .ELAPSED
;


\ ********************************************/
\ * Contributed by Robert Debath 26 Nov 1995 */
\ * rd...@ci...              */
\ ********************************************/

: ROBERT() ( -- )
  s" mm - Robert's algorithm" .algo
  TIMER-RESET
  N 0 ?DO  N 0 ?DO
    b{{ J I }} DF@  bt{{ I J }} DF!
  LOOP LOOP
  N 0 ?DO  N 0 ?DO
    a{{ J 0 }} bt{{ I 0 }} N *DSUM 2DROP c{{ J I }} DF!
  LOOP LOOP
  .ELAPSED
;


0 [IF] ===========================================================================
 * Matrix Multiply by Dan Warner, Dept. of Mathematics, Clemson University
 *
 *    mmbu2.f multiplies matrices a and b
 *    a and b are n by n matrices
 *    nb is the blocking parameter.
 *    the tuning guide indicates nb = 50 is reasonable for the
 *    ibm model 530 hence 25 should be reasonable for the 320
 *    since the 320 has 32k rather than 64k of cache.
 *    Inner loops unrolled to depth of 2
 *    The loop functions without clean up code at the end only
 *    if the unrolling occurs to a depth k which divides into n
 *    in this case n must be divisible by 2.
 *    The blocking parameter nb must divide into n if the
 *    multiply is to succeed without clean up code at the end.
 *
 * converted to c by Mark Smotherman
 * note that nb must also be divisible by 2 => cannot use 25, so use 20
=========================================================================== [THEN]

DFVARIABLE s10
DFVARIABLE s00
DFVARIABLE s01
DFVARIABLE s11

: WARNER() ( nb -- )
  0 0 0 0 LOCALS| K ii jj kk nb |
  s" mm - D. Warner's algorithm, subarray" .algo  nb 0 .R  'x' EMIT  nb 0 .R
  N nb MOD  N 2 MOD OR IF
    cr ."   the matrix size " N DEC.
    ." must be divisible both by the block size " nb DEC. ." and 2."
    EXIT
  THEN
  nb 2 MOD IF
    ."   block size must be evenly divisible by 2"
    EXIT
  THEN
  TIMER-RESET
  N 0 ?DO  I TO ii
    N 0 ?DO  I TO jj
      nb ii + ii ?DO
        nb jj + jj ?DO
          0e c{{ J I }} DF!
        LOOP
      LOOP
      N 0 ?DO  I TO kk
        nb ii + ii ?DO  I TO K
          nb jj + jj ?DO
            c{{ J     I    }} DF@ s00 DF!
            c{{ J     I 1+ }} DF@ s01 DF!
            c{{ J 1+  I    }} DF@ s10 DF!
            c{{ J 1+  I 1+ }} DF@ s11 DF!
            nb kk + kk ?DO
              a{{ K    I }} DF@  b{{ I J    }} DF@ F* s00 DF+!
              a{{ K    I }} DF@  b{{ I J 1+ }} DF@ F* s01 DF+!
              a{{ K 1+ I }} DF@  b{{ I J    }} DF@ F* s10 DF+!
              a{{ K 1+ I }} DF@  b{{ I J 1+ }} DF@ F* s11 DF+!
            LOOP
            s00 DF@ c{{ J     I    }} DF!
            s01 DF@ c{{ J     I 1+ }} DF!
            s10 DF@ c{{ J 1+  I    }} DF!
            s11 DF@ c{{ J 1+  I 1+ }} DF!
          2 +LOOP
        2 +LOOP
      nb +LOOP
    nb +LOOP
  nb +LOOP
  .ELAPSED ;


0 [IF] ===========================================================================
Matrix Multiply tuned for SS-10/30;
 *                      Maeno Toshinori
 *                      Tokyo Institute of Technology
 *
 * Using gcc-2.4.1 (-O2), this program ends in 12 seconds on SS-10/30.
 *
 * in original algorithm - sub-area for cache tiling
 * #define      L       20
 * #define      L2      20
 * three 20x20 matrices reside in cache; two may be enough
=========================================================================== [THEN]

DFVARIABLE t0
DFVARIABLE t1
DFVARIABLE t2
DFVARIABLE t3
DFVARIABLE t4
DFVARIABLE t5
DFVARIABLE t6
DFVARIABLE t7

: MAENO() ( nb -- )
  0 0 0 0 0 LOCALS| K it kt i2 kk lparm |
  s" mm - T. Maeno's algorithm, subarray" .algo  lparm 0 .R 'x' EMIT lparm 0 .R
  N lparm MOD  N 4 MOD OR IF
    cr ."   the matrix size " N DEC.
    ." must be divisible both by the block size " lparm DEC. ." and 4."
    EXIT
  THEN
  lparm 4 MOD IF
    cr ."   block size must be evenly divisible by 4"
    EXIT
  THEN
  TIMER-RESET
  N 0 ?DO N 0 ?DO  0e c{{ J I }} DF!  LOOP LOOP
  N 0 ?DO  I TO i2
    N 0 ?DO  I TO kk
      i2 lparm + TO it
      kk lparm + TO kt
      N 0 ?DO  I TO K
        it i2 ?DO
          0e t0 DF!  0e t1 DF!  0e t2 DF!  0e t3 DF!
          0e t4 DF!  0e t5 DF!  0e t6 DF!  0e t7 DF!
          kt  kk ?DO
            a{{ J I }} DF@
            FDUP b{{ I K }} DUP DF@+ F* t0 DF+!
            FDUP                DF@+ F* t1 DF+!
            FDUP                DF@+ F* t2 DF+!
                                DF@  F* t3 DF+!
            a{{ J 1+ I }}  DF@
            FDUP                DF@+ F* t4 DF+!
            FDUP                DF@+ F* t5 DF+!
            FDUP                DF@+ F* t6 DF+!
                                DF@  F* t7 DF+!
          LOOP
          t0 DF@ c{{ I    J }}  DF+!+
          t1 DF@                DF+!+
          t2 DF@                DF+!+
          t3 DF@                DF+!
          t4 DF@ c{{ I 1+ J }}  DF+!+
          t5 DF@                DF+!+
          t6 DF@                DF+!+
          t7 DF@                DF+!
        2 +LOOP
      4 +LOOP
    lparm +LOOP
  lparm +LOOP
  .ELAPSED ;

: MM_MAENO      \ pip1 pip2 pop3 nb --
\ Takes pointers to two FSL input arrays, an FSL output array and a
\ block size nb.
  0 0 0 0 0 LOCALS| K it kt i2 kk lparm pop3{{ pip2{{ pip1{{ |
  N 0 ?DO N 0 ?DO  0e pop3{{ J I }} DF!  LOOP LOOP
  N 0 ?DO  I TO i2
    N 0 ?DO  I TO kk
      i2 lparm + TO it
      kk lparm + TO kt
      N 0 ?DO  I TO K
        it i2 ?DO
          0e t0 DF!  0e t1 DF!  0e t2 DF!  0e t3 DF!
          0e t4 DF!  0e t5 DF!  0e t6 DF!  0e t7 DF!
          kt  kk ?DO
            pip1{{ J I }} DF@
            FDUP pip2{{ I K }}  DUP DF@+ F* t0 DF+!
            FDUP                DF@+ F* t1 DF+!
            FDUP                DF@+ F* t2 DF+!
                                DF@  F* t3 DF+!
            pip1{{ J 1+ I }}    DF@
            FDUP                DF@+ F* t4 DF+!
            FDUP                DF@+ F* t5 DF+!
            FDUP                DF@+ F* t6 DF+!
                                DF@  F* t7 DF+!
          LOOP
          t0 DF@ pop3{{ I    J }}  DF+!+
          t1 DF@                DF+!+
          t2 DF@                DF+!+
          t3 DF@                DF+!
          t4 DF@ pop3{{ I 1+ J }}  DF+!+
          t5 DF@                DF+!+
          t6 DF@                DF+!+
          t7 DF@                DF+!
        2 +LOOP
      4 +LOOP
    lparm +LOOP
  lparm +LOOP
;

: MAENO2()      \ nb --
  s" mm - Generic Maeno, subarray " .algo  dup 0 .R  'x' EMIT  dup 0 .R
  N over MOD  N 4 MOD OR IF
    cr ."   the matrix size " N DEC.
    ." must be divisible both by the block size " DEC. ." and 4."
    EXIT
  THEN
  dup 4 MOD IF
    drop
    cr ."   block size must be evenly divisible by 4"
    EXIT
  THEN
  TIMER-RESET
  >r a{{ b{{ c{{ r> MM_MAENO
  .ELAPSED ;

: MM ( char n -- )
  DEPTH 0= ABORT" no algorithm chosen"
  DEPTH 2 < IF 0 THEN
  LOCALS| ur |
  &  a{{ N N }}malloc \ malloc-fail?
  &  b{{ N N }}malloc \ malloc-fail? OR
  & bt{{ N N }}malloc \ malloc-fail? OR
  &  c{{ N N }}malloc \ malloc-fail? OR
  &  d{{ N N }}malloc \ malloc-fail? OR ABORT" MM :: out of core"
  SET-COEFFICIENTS
  FLUSH-CACHE
  CASE
    'n' OF NORMAL()    ENDOF
    'v' OF TNSQ()      ENDOF
    'u' OF ur UNROLL   ENDOF
    'p' OF ur PNSQ()   ENDOF
    't' OF TRANSPOSE() ENDOF
    'i' OF REG_LOOPS() ENDOF
    'b' OF ur TILING() ENDOF
    'm' OF ur MAENO()  ENDOF
    'z' OF ur MAENO2() ENDOF
    'r' OF ROBERT()    ENDOF
    'w' OF ur WARNER() ENDOF
           CR ." `" DUP EMIT ." ' is an invalid algorithm"
  ENDCASE
  CHECK-RESULT
  &  d{{ }}free
  &  c{{ }}free
  & bt{{ }}free
  &  b{{ }}free
  &  a{{ }}free
  key? drop                     \ Permits o/p update on some systems
;

: ALL-TESTS ( -- )
  page
  0 TotalTime !
  'n'    mm    'v'    mm    'u'  4 mm    'u'  8 mm
  'u' 16 mm    'p'    mm    'p'  4 mm    't'    mm
  'i'    mm    'b' 20 mm    'r'    mm
  'm' 20 mm    'z' 20 mm    'w' 20 mm
  cr  TCOL 7 + 0
  ?DO  ." ="  LOOP
  cr ." Total" .testcond TCOL HTAB  TotalTime @ .secs
;

: .ABOUT
  CR ." Try: 'n'    mm  -- normal"
  CR ."      'v'    mm  -- with a temporary variable in the inner loop"
  CR ."      'u'  n mm  -- with unrolled (by n) inner loop, n = {4,8,16}"
  CR ."      'p'    mm  -- using pointers instead of array notation"
  CR ."      'p'  4 mm  -- using pointers instead of array notation, unrolled by 4 [new]"
  CR ."      't'    mm  -- with transposed b matrix"
  CR ."      'i'    mm  -- with switched inner loops"
  CR ."      'b'  n mm  -- using blocking by n, 4 < n < " N DEC.
  CR ."      'r'    mm  -- using Robert's algorithm"
  CR ."      'r'  8 mm  -- using Robert's algorithm unrolled by 8"
  CR ."      'm'  n mm  -- using Maeno's algorithm with blocking factor n"
  CR ."      'z'  n mm  -- using Maeno's algorithm with blocking factor n - generic form"
  CR ."      'w'  n mm  -- using Warner's algorithm with blocking factor n"
  CR
  CR ." ALL-TESTS       -- test all algorithms" ;

.ABOUT

( * End of Source * )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

: mat. ( a -- | print out the mat...
 
[truncated message content]

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

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

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

Removed Files:
	Testpde.f bench.f matrix.f pde1.f 
Log Message:
- 3reverse and 4reverse added to the kernel
- MM benchmark added
- Moved the benchmarks into a seperate folder

--- pde1.f DELETED ---

--- bench.f DELETED ---

--- matrix.f DELETED ---

--- Testpde.f DELETED ---

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.6,1.7

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

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

Modified Files:
	gkernel.f 
Log Message:
- 3reverse and 4reverse added to the kernel
- MM benchmark added
- Moved the benchmarks into a seperate folder

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** gkernel.f	30 Sep 2006 23:30:52 -0000	1.6
--- gkernel.f	1 Oct 2006 07:38:44 -0000	1.7
***************
*** 789,793 ****
  code 3dup       ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
       3 6 in/out
!                 mov     edx, [ebp]      \ n2
                  mov     ecx, 4 [ebp]      \ n1
                  mov     -4 [ebp], eax     \ n3
--- 789,793 ----
  code 3dup       ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
       3 6 in/out
!                 mov     edx, [ebp]        \ n2
                  mov     ecx, 4 [ebp]      \ n1
                  mov     -4 [ebp], eax     \ n3
***************
*** 798,802 ****
  code 4dup       ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 )
       4 8 in/out
!                 mov     edx, [ebp]      \ n3
                  mov     ecx, 4 [ebp]      \ n2
                  mov     edi, 8 [ebp]      \ n1
--- 798,802 ----
  code 4dup       ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 )
       4 8 in/out
!                 mov     edx, [ebp]        \ n3
                  mov     ecx, 4 [ebp]      \ n2
                  mov     edi, 8 [ebp]      \ n1
***************
*** 807,810 ****
--- 807,830 ----
                  next;
  
+ code 3reverse   ( n1 n2 n3 -- n3 n2 n1 )
+ \ *G exchange first and third items on data stack
+      3 3 in/out
+                 mov ecx, 4 [ebp]
+                 mov 4 [ebp], eax
+                 mov eax, ecx
+                 next;
+ 
+ code 4reverse   ( n1 n2 n3 n4 -- n4 n3 n2 n1 )
+ \ *G exchange first and fourth plus second and third items on the data stack
+      4 4 in/out
+                 mov ecx, 8 [ebp]
+                 mov 8 [ebp], eax
+                 mov eax, ecx
+                 mov edx, 0 [ebp]
+                 mov ecx, 4 [ebp]
+                 mov 4 [ebp], edx
+                 mov 0 [ebp], ecx
+                 next;
+ 
  \ -------------------- Memory operators -------------------------------
  

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

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

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

Modified Files:
	readme.txt 
Log Message:
- 3reverse and 4reverse added to the kernel
- MM benchmark added
- Moved the benchmarks into a seperate folder

Index: readme.txt
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/doc/readme.txt,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** readme.txt	27 Sep 2006 16:21:23 -0000	1.5
--- readme.txt	1 Oct 2006 07:38:44 -0000	1.6
***************
*** 25,31 ****
  1. Run w32f.exe
  
! 2. Type 
  
!     fload demos\bench
  
  To see generated code; after loading the benchmark try
--- 25,31 ----
  1. Run w32f.exe
  
! 2. Type
  
!     fload demos\benchmark\bench
  
  To see generated code; after loading the benchmark try
***************
*** 40,47 ****
  2. Type
  
!    fload demos\TestPde
  
  ( NB for comparison with the ITC version (or rival STC versions) just fload Pde1 in them; the test harness isn't needed)
  
  To run the task demos
  -------------------------
--- 40,62 ----
  2. Type
  
!    fload demos\benchmark\TestPde
!    elapse solve
  
  ( NB for comparison with the ITC version (or rival STC versions) just fload Pde1 in them; the test harness isn't needed)
  
+ To test the Forth Floating point matrix multiply benchmark
+ -------------------------
+ 
+ 1. Run w32f.exe
+ 
+ 2. Type
+ 
+    fload demos\benchmark\mm
+ 
+    and follow the instructions showen.
+ 
+    Be warned running ALL-TESTS can take a lot of time...
+ 
+ 
  To run the task demos
  -------------------------

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

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

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

Modified Files:
	gkernel.exe 
Log Message:
- 3reverse and 4reverse added to the kernel
- MM benchmark added
- Moved the benchmarks into a seperate folder

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
Binary files /tmp/cvsAd7JIh and /tmp/cvs1EQhzj differ

[Win32forth-cvs] win32forth-stc/demos/benchmarks - New directory

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

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

Log Message:
Directory /cvsroot/win32forth/win32forth-stc/demos/benchmarks added to the repository

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f, 1.5, 1.6 gmeta-compiler.f, 1.1, 1.2

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

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

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

Index: gmeta-compiler.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** gmeta-compiler.f	21 Sep 2006 16:26:33 -0000	1.1
--- gmeta-compiler.f	30 Sep 2006 23:30:52 -0000	1.2
***************
*** 832,836 ****
  t: [']       ( -- )     't-ptr [transition] literal   t;
  t: [compile]   't execute    t;
! t: postpone    't-ptr [transition] literal [target] xt>ct-exec t;
  
  : t-count dup 1+ swap t-c@ ;
--- 832,836 ----
  t: [']       ( -- )     't-ptr [transition] literal   t;
  t: [compile]   't execute    t;
! t: postpone    't-ptr [transition] literal [target] >ct-exec t;
  
  : t-count dup 1+ swap t-c@ ;

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** gkernel.f	30 Sep 2006 15:17:32 -0000	1.5
--- gkernel.f	30 Sep 2006 23:30:52 -0000	1.6
***************
*** 2295,2301 ****
              code-here swap dup code-allot move ;
  
! : move-code ( addr -- )                       \ routine to move the code
!             count (move-code) ;
! 
  \ -------------------- Vocabulary/header support -----------------------
  
--- 2295,2300 ----
              code-here swap dup code-allot move ;
  
! : move-code ( addr -- ) count (move-code) ;     \ routine to move the code
!             
  \ -------------------- Vocabulary/header support -----------------------
  
***************
*** 2339,2343 ****
  \     4     xt for DUP
  \
! \ When we do an XT>CT 2@ EXECUTE of the token, this gives
  \     ' DUP ' COMPILE,
  \ which compiles DUP. COMPILE, invokes the comp field for this purpose.
--- 2338,2342 ----
  \     4     xt for DUP
  \
! \ When we do an >ct 2@ EXECUTE of the token, this gives
  \     ' DUP ' COMPILE,
  \ which compiles DUP. COMPILE, invokes the comp field for this purpose.
***************
*** 2348,2352 ****
  \     4     xt for CHARS
  \
! \ When we do an XT>CT 2@ EXECUTE of the token, this gives
  \     ' CHARS ' EXECUTE
  \ which executes CHARS.
--- 2347,2351 ----
  \     4     xt for CHARS
  \
! \ When we do an >ct 2@ EXECUTE of the token, this gives
  \     ' CHARS ' EXECUTE
  \ which executes CHARS.
***************
*** 2375,2400 ****
  \   : x swap ; inline
  
! : xt>ct     ( xt -- ct )                      \ given an xt, get the ct
!             dup cell- @ + ;                   \ relative to abs address
! 
! : xt>ct-exec ( xt -- )                        \ execute the ct
!             xt>ct 2@ execute ;
! 
! : name>ct-exec ( nfa -- )                     \ execute the ct
!             name>ct 2@ execute ;
! 
! : xt>name   ( xt -- nfa ) xt>ct ct>name ;   \ get the name
! 
! : >comp     ( xt -- comp )                    \ point to the comp field
!             xt>ct cell- ;
! 
! : compile,  ( xt -- )                         \ compile xt on the stack
!             dup >comp @ execute ;             \ execute comp token
! 
! : (compiles) ( xt2 xt1 -- )                   \ set the compile word
!             >comp ! ;
! 
! : (comp-only)   ( -- )                        \ compile only message
!             throw_componly throw  ;
  
  \ ------------------------- Address support words ---------------------------
--- 2374,2384 ----
  \   : x swap ; inline
  
! : >ct       ( xt -- ct )   dup cell- @ + ;    \ given an xt, get the ct
! : >comp     ( xt -- comp ) >ct cell- ;        \ point to the comp field
! : (compiles) ( xt2 xt1 -- ) >comp ! ;         \ set the compile word
! : >ct-exec  ( xt -- )      >ct 2@ execute ;   \ execute the ct
! : >name     ( xt -- nfa )  >ct ct>name ;      \ get the name
! : compile,  ( xt -- ) dup >comp @ execute ;   \ compile xt on the stack
! : (comp-only) ( -- ) throw_componly throw ;   \ compile only message
  
  \ ------------------------- Address support words ---------------------------
***************
*** 2403,2420 ****
              code-here - cell- code-, ;        \ the xt relative adjusted
  
! : xt-rel,   ( xt op -- )                      \ generate opcode and rel adjusted xt
!             code-c, xt-reladdr, ;             \ opcode and the xt relative adjusted
! 
! : xt-jmp,   ( xt -- )                         \ generate jump to xt on the stack
!             $e9 xt-rel, ;
  
  0 | value tail-call                           \ see exit for use
  
! : xt-call,  ( xt -- )                         \ compile call to xt on the stack
!             $e8 xt-rel,                       \ call address
              code-here to tail-call ;          \ possible tail call
  
  : xt-inline, ( xt -- )                        \ inline the xt
!             dup xt>name n>ofa w@ (move-code) ; \ get the length and move the code
  
  \ ---------------------------- Defining Words --------------------------------
--- 2387,2401 ----
              code-here - cell- code-, ;        \ the xt relative adjusted
  
! : xt-rel,   ( xt op -- ) code-c, xt-reladdr, ; \ generate opcode and rel adjusted xt
  
+ : xt-jmp,   ( xt -- ) $e9 xt-rel, ;           \ generate jump to xt on the stack
+             
  0 | value tail-call                           \ see exit for use
  
! : xt-call,  ( xt -- ) $e8 xt-rel,             \ compile call to xt on the stack
              code-here to tail-call ;          \ possible tail call
  
  : xt-inline, ( xt -- )                        \ inline the xt
!             dup >name n>ofa w@ (move-code) ;  \ get the length and move the code
  
  \ ---------------------------- Defining Words --------------------------------
***************
*** 2428,2434 ****
  7 equ addr-off                                \ the offset of the address part
  
! : >body     ( xt -- body )                    \ get body of created word
!             body-off + @ ;
! 
  gcode _lit
                  mov     -4 [ebp], eax
--- 2409,2414 ----
  7 equ addr-off                                \ the offset of the address part
  
! : >body     ( xt -- body ) body-off + @ ;     \ get body of created word
!             
  gcode _lit
                  mov     -4 [ebp], eax
***************
*** 2455,2461 ****
              ;
  
! : (x-cons)  ( xt -- )                         \ execute & compile a literal
!             execute postpone literal ;
! 
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
--- 2435,2440 ----
              ;
  
! : (x-cons)  ( xt -- ) execute postpone literal ; \ execute & compile a literal
!             
  0 1 in/out : constant  ( n "name" )           \ compile time
              ( -- n )                          \ run time
***************
*** 2493,2500 ****
      (comp-only)                               \ compile only
      compilation> ( -- xt ) drop
!             swap                              \ n on first
!             postpone literal                  \ generate literal
!             postpone literal                  \ and another
!             ;                                 \ compile only
  
  \ -------------------- Link Operations (Single Linked)  --------------------
--- 2472,2477 ----
      (comp-only)                               \ compile only
      compilation> ( -- xt ) drop
!             swap postpone literal postpone literal
!             ;
  
  \ -------------------- Link Operations (Single Linked)  --------------------
***************
*** 2696,2705 ****
                  next;
  
! : char      ( -- char )
!             parse-word drop c@ ;
! 
! : [char]    ( -- char )
!             char postpone literal ; immediate
! 
  : /parse    ( -- addr u )
              >in @ char swap >in ! dup '"' = over ''' =
--- 2673,2680 ----
                  next;
  
! : char      ( -- char ) parse-word drop c@ ;
!             
! : [char]    ( -- char ) char postpone literal ; immediate
!             
  : /parse    ( -- addr u )
              >in @ char swap >in ! dup '"' = over ''' =
***************
*** 2738,2742 ****
      compilation> ( -- xt ) drop
              postpone [']                      \ generate xt
!             postpone xt>ct-exec
              ;
  
--- 2713,2717 ----
      compilation> ( -- xt ) drop
              postpone [']                      \ generate xt
!             postpone >ct-exec
              ;
  
***************
*** 2744,2749 ****
      (comp-only)                               \ compile only
      compilation> ( -- xt ) drop
!             ' dup xt>ct @ ['] compile, <> if
!               postpone literal postpone xt>ct-exec
              else
                compile,
--- 2719,2724 ----
      (comp-only)                               \ compile only
      compilation> ( -- xt ) drop
!             ' dup >ct @ ['] compile, <> if
!               postpone literal postpone >ct-exec
              else
                compile,
***************
*** 2753,2759 ****
  \ -------------------- String Literals --------------------------------------
  
! : "parse    ( -- addr len )
!             [char] " parse ;
! 
  : ",        ( a1 n1 -- )               \ compile a1,n1 at here (counted)
              here over c, over allot 1+ swap cmove ;
--- 2728,2733 ----
  \ -------------------- String Literals --------------------------------------
  
! : "parse    ( -- addr len ) [char] " parse ;
!             
  : ",        ( a1 n1 -- )               \ compile a1,n1 at here (counted)
              here over c, over allot 1+ swap cmove ;
***************
*** 3405,3409 ****
                    s" :noname-" type $.          \ print the hex address
                  else
!                   xt>name .id
                  then ;
  
--- 3379,3383 ----
                    s" :noname-" type $.          \ print the hex address
                  else
!                   >name .id
                  then ;
  
***************
*** 4467,4471 ****
  : (interpret-c) ( str -- ??? )
                  find if
!                   xt>ct-exec      \ smart compile time
                  else
                    count number
--- 4441,4445 ----
  : (interpret-c) ( str -- ??? )
                  find if
!                   >ct-exec            \ smart compile time
                  else
                    count number
***************
*** 4475,4479 ****
  : (interpret-i) ( str -- ??? )
                  find if
!                   execute ?stack  \ interpret
                  else
                    count number
--- 4449,4453 ----
  : (interpret-i) ( str -- ??? )
                  find if
!                   execute ?stack       \ interpret
                  else
                    count number
***************
*** 5895,5899 ****
          begin   @ dup
          while
!           dup vlink>voc voc>vxt@ xt>name dup to .olly-vocname count
            s" locals" str= not if
              dup .olly-voc
--- 5869,5873 ----
          begin   @ dup
          while
!           dup vlink>voc voc>vxt@ >name dup to .olly-vocname count
            s" locals" str= not if
              dup .olly-voc