From 0d73c7d39e3f3ba3bf4bb3f07c4b5552c7eea562 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Thu, 12 Jun 2025 15:42:51 +0200
Subject: [PATCH] first try with virtual (restartable) actor loop

---
 core/actor.lisp     | 19 ++++++++++++++++---
 test/test-core.lisp | 15 +++++++++------
 util/async.lisp     |  6 +++---
 3 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/core/actor.lisp b/core/actor.lisp
index babcc20..ab100b5 100644
--- a/core/actor.lisp
+++ b/core/actor.lisp
@@ -39,10 +39,10 @@
   (when (not (boundp '+quit-message+)) 
     (defconstant +quit-message+ (gensym "QUIT"))))
 
-(defun start (mb bhv &key foreground)
+(defun start (mb bhv &key foreground (listener #'ac-loop))
   (if foreground
     (ac-loop mb bhv)
-    (async:submit-task mb (lambda () (ac-loop mb bhv)))))
+    (async:submit-task mb listener mb bhv)))
 
 (defun stop (mb)
   (send mb +quit-message+))
@@ -52,17 +52,30 @@
     (unless (eq (content msg) +quit-message+)
       (ac-loop mb (or (funcall bhv msg) bhv)))))
 
+(defun ac-vloop (mb bhv)
+  (multiple-value-bind (msg ok) (async:try-rcv mb)
+    (if ok
+      (if (eq (content msg) +quit-message+)
+        nil
+        (ac-vloop mb (or (funcall bhv msg) bhv)))
+      bhv)))
+
 ;;;; the core (classical, i.e. Hewitt) actor API
 ;;;  there is no `become` operation: the behavior just returns the new behavior
 
 (defun create (bhv)
   (let ((mb (async:make-mb))) 
     (start mb bhv)
+    (start mb bhv :listener #'ac-vloop)
     mb))
 
 (defun send (mb msg)
   ;(util:lgi msg)
-  (async:snd mb msg))
+  (async:snd mb msg)
+  (multiple-value-bind (bhv done) (async:try-receive-result mb)
+    (util:lgi done)
+    (if (and done bhv)
+      (async:submit-task mb (lambda () (ac-vloop mb bhv))))))
 
 ;;;; predefined behaviors
 
diff --git a/test/test-core.lisp b/test/test-core.lisp
index 49b7cd0..0079b86 100644
--- a/test/test-core.lisp
+++ b/test/test-core.lisp
@@ -59,11 +59,11 @@
     (unwind-protect
       (progn
         (test-util)
-        (test-util-async)
         (test-util-crypt)
         (test-util-iter)
         (test-shape)
         (core:setup-services)
+        (test-util-async)
         (test-actor)
         (setf (receiver t:*test-suite*) (core:find-service :test-receiver))
         (test-send))
@@ -87,11 +87,6 @@
     (== (util:plist-add pl :b 1) '(:b 1 :a 0))
     (== pl '(:b 1 :a 0))))
 
-(deftest test-util-async ()
-  (let ((mb (async:make-mb)))
-    (async:submit-task mb (lambda () (sleep 0.1) :done))
-))
-
 (deftest test-util-crypt ()
   (let ((s1 (crypt:create-secret))
         (s2 (crypt:create-secret)))
@@ -114,6 +109,14 @@
     (setf (shape:head-value rec :username) :u1)
     (== (shape:head-value rec :username) :u1)))
 
+(deftest test-util-async ()
+  (let ((mb (async:make-mb)))
+    (async:submit-task mb (lambda () (sleep 0.1) :done))
+    (== (async:try-receive-result mb) nil)
+    (== (async:receive-result mb) :done)
+    (== (async:try-receive-result mb) nil)
+))
+ 
 (deftest test-actor ()
   (let* ((calc (actor:create (actor:calculator)))
          val
diff --git a/util/async.lisp b/util/async.lisp
index 5994153..c9e295c 100644
--- a/util/async.lisp
+++ b/util/async.lisp
@@ -33,13 +33,13 @@
   (lpq:pop-queue (queue mb)))
 
 (defun try-rcv (mb)
-  (lpq:peek-queue (queue mb)))
+  (lpq:try-pop-queue (queue mb)))
 
 (defun snd (mb msg)
   (lpq:push-queue msg (queue mb)))
 
-(defun submit-task (mb job)
-  (lp:submit-task (channel mb) job))
+(defun submit-task (mb job &rest args)
+  (apply #'lp:submit-task (channel mb) job args))
 
 (defun receive-result (mb)
   (lp:receive-result (channel mb)))