Return to tasker.fs CVS log

Up to [gforth] / gforth

updated copyright year after changing license notice

    1: \ Multitasker                                          19aug94py
    2: 
    3: \ Copyright (C) 1995,1996,1997,2001,2003,2007 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: Create sleepers  sleepers A, sleepers A, 0 ,
   21: 
   22: : link-task ( task1 task2 -- )
   23:     \G LINK-TASK links task1 into the task chain of task2
   24:     over 2@  2dup cell+ ! swap !  \ unlink task1
   25:     2dup @ cell+ !  2dup dup @ rot 2!  ! ;
   26: 
   27: : sleep ( task -- )
   28:     \G deactivates task
   29:     sleepers  link-task ;
   30: : wake  ( task -- )
   31:     \G activates task
   32:     next-task link-task ;
   33: 
   34: : pause ( -- )
   35:     \G PAUSE is the task-switcher
   36:     rp@ fp@ lp@ sp@ save-task !
   37:     next-task @ up! save-task @ sp!
   38:     lp! fp! rp! ;
   39: 
   40: : stop ( -- )
   41:     \G STOP sleeps a task and switches to the next
   42:     rp@ fp@ lp@ sp@ save-task !
   43:     next-task @ up! save-task @ sp!
   44:     lp! fp! rp! prev-task @ sleep ;
   45: 
   46: :noname    ' >body @ ;
   47: :noname    ' >body @ postpone literal ; 
   48: interpret/compile: user' ( 'user' -- n )
   49: \G USER' computes the task offset of a user variable
   50: 
   51: : NewTask ( stacksize -- Task )  dup 2* 2* udp @ + dup
   52:     \G NEWTASK creates a new, sleeping task
   53:     allocate throw  + >r
   54:     r@ over - udp @ - next-task over udp @ move
   55:     r> over user' rp0 + ! dup >r
   56:     dup r@ user' lp0   + ! over -
   57:     dup r@ user' fp0   + ! over -
   58:     dup r@ user' sp0   + ! over -
   59:     dup r@ user' normal-dp + dup >r !
   60:     r> r@ user' dpp  + ! 2drop
   61:     0 r@ user' current-input + !
   62:     r> dup 2dup 2! dup sleep ;
   63: 
   64: Create killer killer A, killer A,
   65: : kill ( task -- )
   66:     \G kills a task - deactivate and free task area
   67:     dup killer link-task  killer dup dup 2!
   68:     user' normal-dp + @ free throw ;
   69: 
   70: : kill-task ( -- )
   71:     \G kills the current task, also on bottom of return stack of a new task
   72:     next-task @ up! save-task @ sp!
   73:     lp! fp! rp! prev-task @ kill ;
   74: 
   75: : (pass) ( x1 .. xn n task -- )  rdrop
   76:   [ ' kill-task >body ] ALiteral r>
   77:   rot >r r@ user' rp0 + @ 2 cells - dup >r 2!
   78:   r>              swap 1+
   79:   r@ user' fp0 + @ swap 1+
   80:   r@ user' lp0 + @ swap 1+
   81:   cells r@ user' sp0 + @ tuck swap - dup r@ user' save-task + !
   82:   ?DO  I !  cell  +LOOP  r> wake ;
   83: 
   84: : activate ( task -- )
   85:     \G activates the task.
   86:     \G Continues execution with the caller of ACTIVATE.
   87:     0 swap (pass) ;
   88: : pass ( x1 .. xn n task -- )
   89:     \G passes n parameters to the task and activates that task.
   90:     \G Continues execution with the caller of PASS.
   91:     (pass) ;
   92: 
   93: : single-tasking? ( -- flag )
   94:     \G checks if only one task is running
   95:     next-task dup @ = ;
   96: 
   97: : task-key   BEGIN  pause key? single-tasking? or  UNTIL  (key) ;
   98: : task-emit  (emit) pause ;
   99: : task-type  (type) pause ;
  100: 
  101: ' task-key  IS key
  102: ' task-emit IS emit
  103: ' task-type IS type