diff --git a/core/actor-ng.lisp b/core/actor-ng.lisp index bb93fa8..fde376e 100644 --- a/core/actor-ng.lisp +++ b/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) - (if fore-ground +(defun start (mb bhv &key foreground) + (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+) - +quit-message+ - (funcall bhv msg)))) + (unless (eq (content msg) +quit-message+) + (ac-loop mb (or (funcall bhv msg) bhv))))) ;;;; the core (classical, i.e. Hewitt) actor API ;;; there is no `become` operation: the behavior just returns the new behavior diff --git a/core/core.lisp b/core/core.lisp index c09ac8e..586619b 100644 --- a/core/core.lisp +++ b/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) - ((actions :accessor actions :initform nil))) +(defclass base-context () + ((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) - ((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) +(defun x-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) - &allow-other-keys) - #'(lambda (cfg) - (apply #'actor:create behavior class :config cfg :name (config:name cfg) args))) +(defun make-setup (&key (class 'context) (behavior #'handle-message) args) + ;(lambda (cfg) + ; (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)))) diff --git a/test/test-core.lisp b/test/test-core.lisp index 082242a..8f0bb92 100644 --- a/test/test-core.lisp +++ b/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))))