Return to tasker.fs CVS log

Up to [gforth] / gforth

eliminated state-smartness in ;code and sfnumber
immediate-flag is now $40 and restrict-flag $20
HEADER now stores the compilation wordlist in the header and
	REVEAL reveals into that wordlist
assorted cleanups

    1: \ Multitasker                                          19aug94py
    2: 
    3: Create sleepers  sleepers A, sleepers A, 0 ,
    4: 
    5: \ LINK-TASK links task1 into the task chain of task2
    6: : link-task ( task1 task2 -- )
    7:   over 2@  2dup cell+ ! swap !  \ unlink task1
    8:   2dup @ cell+ !  2dup dup @ rot 2!  ! ;
    9: 
   10: : sleep ( task -- )  sleepers  link-task ;
   11: : wake  ( task -- )  next-task link-task ;
   12: 
   13: \ PAUSE is the task-switcher
   14: : pause ( -- )
   15:   rp@ fp@ lp@ sp@ save-task !
   16:   next-task @ up! save-task @ sp!
   17:   lp! fp! rp! ;
   18: 
   19: \ STOP sleeps a task and switches to the next
   20: : stop ( -- )
   21:   rp@ fp@ lp@ sp@ save-task !
   22:   next-task @ up! save-task @ sp!
   23:   lp! fp! rp! prev-task @ sleep ;
   24: 
   25: \ USER' computes the task offset
   26: : user' ( 'user' -- n )
   27:     ' >body @ postpone literal ; immediate
   28: interpretation:
   29:     ' >body @ ;
   30: 
   31: \ NEWTASK creates a new, sleeping task
   32: : NewTask ( n -- Task )  dup 2* 2* udp @ + dup
   33:   allocate throw  + >r
   34:   r@ over - udp @ - next-task over udp @ move
   35:   r> over user' r0 + ! dup >r
   36:   dup r@ user' l0   + ! over -
   37:   dup r@ user' f0   + ! over -
   38:   dup r@ user' s0   + ! over -
   39:   dup r@ user' normal-dp + dup >r !
   40:    r> r@ user' dpp  + ! + $10 +
   41:       r@ user' >tib + !
   42:   r> dup 2dup 2! dup sleep ;
   43: 
   44: : kill-task
   45:   next-task @ up! save-task @ sp!
   46:   lp! fp! rp! prev-task @ dup dup link-task user' normal-dp + @ free throw ;
   47: 
   48: : (pass) ( x1 .. xn n task -- )  rdrop
   49:   [ ' kill-task >body ] ALiteral r>
   50:   rot >r r@ user' r0 + @ 2 cells - dup >r 2!
   51:   r>              swap 1+
   52:   r@ user' f0 + @ swap 1+
   53:   r@ user' l0 + @ swap 1+
   54:   cells r@ user' s0 + @ tuck swap - dup r@ user' save-task + !
   55:   ?DO  I !  cell  +LOOP  r> wake ;
   56: 
   57: : activate ( task -- )  0 swap (pass) ;
   58: : pass ( x1 .. xn n task -- )  (pass) ;
   59: 
   60: : single-tasking? ( -- flag )
   61:     next-task dup @ = ;
   62: 
   63: : task-key   BEGIN  pause key? single-tasking? or  UNTIL  (key) ;
   64: : task-emit  (emit) pause ;
   65: : task-type  (type) pause ;
   66: 
   67: ' task-key  IS key
   68: ' task-emit IS emit
   69: ' task-type IS type