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

more on actor-ng - now working with core

Browse source
This commit is contained in:
Helmut Merz 2025-06-02 15:25:13 +02:00
parent 50dc19c974
commit 2e07786286
5 changed files with 18 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
core/actor-ng.lisp
View file

@ -5,6 +5,7 @@
(:local-nicknames (:async :scopes/util/async)
(:lp :lparallel)
(:lpq :lparallel.queue)
(:shape :scopes/shape)
(:util :scopes/util))
(:export #:start #:stop #:become #:create #:send
#:message #:content #:customer
@ -23,6 +24,9 @@
((content :reader content :initarg :content :initform nil)
(customer :reader customer :initarg :customer :initform nil)))
(defmethod x-print-object ((msg message) stream)
(shape:print-slots msg stream 'content 'customer))
(defun message (content &optional customer)
(make-instance 'message :content content :customer customer))
@ -55,6 +59,7 @@
(values mb (start mb bhv))))
(defun send (mb msg)
;(util:lgi msg)
(lpq:push-queue msg mb))
;;;; predefined behaviors
@ -80,7 +85,7 @@
(defun calculator (&optional (val 0))
(lambda (msg)
(format t "calc ~a ~a~%" val (content msg))
;(format t "calc ~a ~a~%" val (content msg))
(destructuring-bind (fn &optional param) (content msg)
(funcall fn msg val param))))

11
core/core.lisp
View file

@ -69,12 +69,7 @@
(name :reader name :initarg :name)
(services :reader services :initform (make-hash-table))))
(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 (&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))))
@ -88,7 +83,6 @@
(defun setup-services (&optional (cfg config:*root*))
(async:init)
;(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))
@ -126,9 +120,8 @@
(add-action child (car a) (cadr a)))
(setf (gethash (config:name cfg) services) child)))))
(defgeneric handle-message (ctx msg)
(:method ((ctx base-context) msg)
(do-actions ctx (actor:content msg))))
(defun handle-message (ctx msg)
(do-actions ctx msg))
(defun do-actions (ctx msg &optional (acts #'actions))
(let ((hdlrs (select msg (funcall acts ctx))))

4
core/message.lisp
View file

@ -2,7 +2,7 @@
(defpackage :scopes/core/message
(:use :common-lisp)
(:local-nicknames (:actor :scopes/core/actor)
(:local-nicknames (:actor :scopes/core/actor-ng)
(:shape :scopes/shape))
(:export #:message-meta #:message #:create
#:head #:data))
@ -24,4 +24,4 @@
(shape:print-slots msg stream 'shape:head 'actor:customer 'shape:data))
(defmethod actor:content ((msg message))
(list (shape:head-plist) (shape:data)))
(list (shape:head-plist msg) (shape:data msg)))

6
scopes-core.asd
View file

@ -10,16 +10,14 @@
:flexi-streams :ironclad :local-time :log4cl
:lparallel :qbase64 :serapeum :str)
:components ((:file "config" :depends-on ("util/util"))
(:file "core/actor"
:depends-on ("shape/shape" "util/async" "util/util"))
(:file "core/actor-ng"
:depends-on ("shape/shape" "util/async" "util/util"))
(:file "core/core"
:depends-on ("config"
"core/actor" "core/message"
"core/actor-ng" "core/message"
"forge/forge" "logging"
"util/async" "util/util"))
(:file "core/message" :depends-on ("core/actor" "shape/shape"))
(:file "core/message" :depends-on ("core/actor-ng" "shape/shape"))
(:file "forge/forge" :depends-on ("util/iter" "util/util"))
(:file "logging" :depends-on ("config" "util/util"))
(:file "shape/shape")

26
test/test-core.lisp
View file

@ -4,7 +4,6 @@
(:use :common-lisp)
(:local-nicknames (:alx :alexandria)
(:actor :scopes/core/actor-ng)
(:actorx :scopes/core/actor)
(:async :scopes/util/async)
(:config :scopes/config)
(:core :scopes/core)
@ -51,7 +50,7 @@
;;;; test runner
(defclass test-suite (t:test-suite)
((receiver :accessor receiver :initarg :receiver)))
((receiver :accessor receiver :initarg :receiver :initform nil)))
(defun run ()
(async:init)
@ -65,10 +64,10 @@
(test-util-iter)
(test-shape)
(core:setup-services)
(test-actor-x)
(test-actor)
(setf (receiver t:*test-suite*) (core:find-service :test-receiver))
(test-send))
(test-send)
)
(core:shutdown)
(check-expected)
(t:show-result))))
@ -130,20 +129,6 @@
(setf (shape:head-value rec :username) :u1)
(== (shape:head-value rec :username) :u1)))
(deftest test-actor-x ()
(let* ((calc (actorx:create (actorx:calculator) 'actorx:bg-actor))
val
(collector
(actorx:create
#'(lambda (ac msg) (setf val (actorx:content msg))))))
(actorx:send calc '(actorx:plus 2))
(actorx:send calc '(actorx:minus 3))
(actorx:send calc '(actorx:show))
(actorx:send calc '(actorx:send-value) :customer collector)
(sleep 0.1)
(== val -1)
))
(deftest test-actor ()
;(async:init)
(let* ((calc (actor:create (actor:calculator)))
@ -153,7 +138,7 @@
(actor:send calc (actor:message '(actor:plus 2)))
(actor:send calc (actor:message '(actor:minus 3)))
(actor:send calc (actor:message '(actor:show)))
(actor:send calc (actor:message '(actor:send-value) collector))
(actor:send calc (actor:message '(actor:show) collector))
(actor:stop calc)
(sleep 0.1)
(== val -1)
@ -165,4 +150,5 @@
(msg-exp (message:create '(:test :dummy) :data "dummy payload")))
(expect rcvr msg-exp)
(== (core:name rcvr) :test-receiver)
(actor:send (core:mailbox rcvr) (actor:message msg))))
(actor:send (core:mailbox rcvr) msg)
))