scopes/core, work in progress: use new actor-g implementation

core/actor-ng.lisp

@@ -32,8 +32,8 @@
   (when (not (boundp '+quit-message+)) 
     (defconstant +quit-message+ (gensym "QUIT"))))
 
-(defun start (mb bhv &key fore-ground)
+(defun start (mb bhv &key foreground)
-  (if fore-ground
+  (if foreground
     (ac-loop mb bhv)
     (let ((ch (lp:make-channel)))
       (lp:submit-task ch (lambda () (ac-loop mb bhv)))
@@ -43,15 +43,9 @@
   (send mb (message +quit-message+)))
 
 (defun ac-loop (mb bhv)
-  (let ((next (ac-step mb bhv)))
-    (unless (eq next +quit-message+)
-      (ac-loop mb (or next bhv)))))
-
-(defun ac-step (mb bhv)
   (let ((msg (lpq:pop-queue mb)))
-    (if (eq (content msg) +quit-message+)
+    (unless (eq (content msg) +quit-message+)
-      +quit-message+
+      (ac-loop mb (or (funcall bhv msg) bhv)))))
-      (funcall bhv msg))))
 
 ;;;; the core (classical, i.e. Hewitt) actor API
 ;;;  there is no `become` operation: the behavior just returns the new behavior

core/core.lisp

@@ -2,7 +2,7 @@
 
 (defpackage :scopes/core
   (:use :common-lisp)
-  (:local-nicknames (:actor :scopes/core/actor)
+  (:local-nicknames (:actor :scopes/core/actor-ng)
                     (:async :scopes/util/async)
                     (:config :scopes/config)
                     (:message :scopes/core/message)
@@ -12,9 +12,9 @@
                     (:lp :lparallel) 
                     (:lpq :lparallel.queue))
   (:export #:action-spec #:define-actions
-           #:*root* #:default-setup #:make-setup #:actions 
+           #:*root* #:make-setup #:actions 
            #:find-service #:run-services #:setup-services #:shutdown
-           #:base-context #:context #:service #:add-action #:config #:name
+           #:base-context #:context #:add-action #:config #:mailbox #:name
            #:handle-message
            #:do-print #:echo))
 
@@ -60,26 +60,26 @@
 
 (defvar *root* nil)
 
-(defclass base-context (actor:bg-actor)
+(defclass base-context ()
-  ((actions :accessor actions :initform nil)))
+  ((actions :accessor actions :initform nil)
+   (mailbox :accessor mailbox :initform nil)))
 
 (defclass context (base-context) 
   ((config :reader config :initarg :config)
    (name :reader name :initarg :name)
    (services :reader services :initform (make-hash-table))))
 
-(defclass service (context actor:bg-actor)
+(defun x-default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
-  ((task :accessor task :initform nil)))
-
-(defclass root-service (service actor:fg-actor) ())
-
-(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
   (apply #'actor:create #'handle-message cls :config cfg :name (config:name cfg) args))
 
-(defun make-setup (&rest args &key (class 'context) (behavior #'handle-message)
+(defun make-setup (&key (class 'context) (behavior #'handle-message) args)
-                   &allow-other-keys)
+  ;(lambda (cfg)
-  #'(lambda (cfg)
+  ;  (apply #'actor:create behavior class :config cfg :name (config:name cfg) args))
-      (apply #'actor:create behavior class :config cfg :name (config:name cfg) args)))
+  (lambda (cfg) 
+    (let* ((ctx (apply #'make-instance class :config cfg :name (config:name cfg) args))
+           (bhv (lambda (msg) (funcall behavior ctx msg))))
+      (setf (mailbox ctx) (actor:create bhv))
+      ctx)))
 
 (defun find-service (name &optional (parent *root*))
   (with-slots (services) parent
@@ -88,7 +88,11 @@
 
 (defun setup-services (&optional (cfg config:*root*))
   (async:init)
-  (setf *root* (actor:make-actor #'handle-message 'root-service :config cfg))
+  ;(setf *root* (actor:make-actor #'handle-message 'root-service :config cfg))
+  (let* ((ctx (make-instance 'context :config cfg))
+         (bhv (lambda (msg) (funcall #'handle-message ctx msg)))) 
+    (setf (mailbox ctx) (lpq:make-queue))
+    (setf *root* ctx))
   (dolist (c (reverse (config:children cfg)))
     (add-service *root* c)))
 
@@ -96,14 +100,13 @@
   (unwind-protect
     (progn
       (setup-services cfg)
-      (actor:start *root*))
+      (actor:start (mailbox *root*)))
     (shutdown)))
  
 (defun shutdown ()
   (dolist (ctx (alx:hash-table-values (services *root*)))
     (funcall (config:shutdown (config ctx)) ctx))
-  (if (task *root*) 
+  ;(actor:stop *root*)
-    (actor:stop *root*))
   (async:finish)
 )
 
@@ -125,7 +128,7 @@
 
 (defgeneric handle-message (ctx msg)
   (:method ((ctx base-context) msg)
-    (do-actions ctx msg)))
+    (do-actions ctx (actor:content msg))))
 
 (defun do-actions (ctx msg &optional (acts #'actions))
   (let ((hdlrs (select msg (funcall acts ctx))))

test/test-core.lisp

@@ -27,7 +27,7 @@
              :initform (make-hash-table :test #'equalp))))
 
 (defun setup (cfg)
-  (core:default-setup cfg 'test-receiver))
+  (funcall (core:make-setup :class 'test-receiver) cfg))
 
 (defun check-message (ctx msg)
   (let ((key (shape:head msg)))
@@ -165,4 +165,4 @@
         (msg-exp (message:create '(:test :dummy) :data "dummy payload")))
     (expect rcvr msg-exp)
     (== (core:name rcvr) :test-receiver)
-    (actorx:send rcvr msg)))
+    (actor:send (core:mailbox rcvr) (actor:message msg))))