cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

util/async basically working

Browse source
This commit is contained in:
Helmut Merz 2025-02-19 10:45:50 +01:00
parent fcdacb677f
commit a3efdcc63b
2 changed files with 28 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
test/test-core.lisp
View file

@ -89,7 +89,8 @@
(== (async:status tsk) :new) (== (async:status tsk) :new)
(async:start tsk) (async:start tsk)
(== (async:status tsk) :running) (== (async:status tsk) :running)
(sleep 0.1) (async:stop tsk)
;(sleep 0.1)
(== (async:status tsk) :finished) (== (async:status tsk) :finished)
)) ))

35
util/async.lisp
View file

@ -23,13 +23,16 @@
(defun standard-job (tsk &key (startup #'noop) (teardown #'noop) handle-message) (defun standard-job (tsk &key (startup #'noop) (teardown #'noop) handle-message)
(let ((mb (mailbox tsk))) (let ((mb (mailbox tsk)))
(funcall startup tsk) (unwind-protect
(if mb (progn
(loop for msg = (lpq:pop-queue mb) (funcall startup tsk)
until (eq msg +quit-message+) (when mb
do (funcall handle-message tsk msg))) (loop for msg = (lpq:pop-queue mb)
(funcall teardown tsk) until (eq msg +quit-message+)
(setf (status tsk) :finished))) do (funcall handle-message tsk msg)))
(funcall teardown tsk))
(setf (status tsk) :finished)
"done")))
;;;; task class and related functions / methods ;;;; task class and related functions / methods
@ -51,5 +54,19 @@
tsk)) tsk))
(defun start (tsk) (defun start (tsk)
(lp:submit-task (channel tsk) (job tsk)) (when (eq (status tsk) :running)
(setf (status tsk) :running)) (util:lgw "task already running" (taskid tsk))
(return-from start))
(setf (status tsk) :running)
(lp:submit-task (channel tsk) (job tsk)))
(defun stop (tsk &key (wait t))
(when (mailbox tsk)
(send tsk +quit-message+))
(when wait
(lp:receive-result (channel tsk))))
(defun send (tsk msg)
(if (mailbox tsk)
(lpq:push-queue msg (mailbox tsk))
(util:lgw "task has no mailbox" (taskid tsk))))