Annotation of gforth/tasker.fs, revision 1.1
1.1 ! pazsan 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 @ state @ IF postpone Literal THEN ; immediate
! 28:
! 29: \ NEWTASK creates a new, sleeping task
! 30: : NewTask ( n -- Task ) dup 2* 2* udp @ + dup
! 31: allocate throw + >r
! 32: r@ over - udp @ - next-task over udp @ move
! 33: r> over user' r0 + ! dup >r
! 34: dup r@ user' l0 + ! over -
! 35: dup r@ user' f0 + ! over -
! 36: dup r@ user' s0 + ! over -
! 37: dup r@ user' normal-dp + dup >r !
! 38: r> r@ user' dpp + ! + $10 +
! 39: r@ user' >tib + !
! 40: r> dup 2dup 2! dup sleep ;
! 41:
! 42: : kill-task
! 43: next-task @ up! save-task @ sp!
! 44: lp! fp! rp! prev-task @ dup dup link-task user' normal-dp + @ free throw ;
! 45:
! 46: : (pass) ( x1 .. xn n task -- ) rdrop
! 47: [ ' kill-task >body ] ALiteral r>
! 48: rot >r r@ user' r0 + @ 2 cells - dup >r 2!
! 49: r> swap 1+
! 50: r@ user' f0 + @ swap 1+
! 51: r@ user' l0 + @ swap 1+
! 52: cells r@ user' s0 + @ tuck swap - dup r@ user' save-task + !
! 53: ?DO I ! cell +LOOP r> wake ;
! 54:
! 55: : activate ( task -- ) 0 swap (pass) ;
! 56: : pass ( x1 .. xn n task -- ) (pass) ;
! 57:
! 58: : task-key BEGIN pause key? UNTIL (key) ;
! 59: : task-emit (emit) pause ;
! 60: : task-type (type) pause ;
! 61:
! 62: ' task-key IS key
! 63: ' task-emit IS emit
! 64: ' task-type IS type
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>