diff --git a/csys/csys.lisp b/csys/csys.lisp index 02f235c..5a466a7 100644 --- a/csys/csys.lisp +++ b/csys/csys.lisp @@ -11,7 +11,7 @@ (:export #:*domain* #:scope #:environ #:make-program #:create-zero - #:neuron #:std-proc #:eff-proc + #:neuron #:gen-proc #:std-proc #:eff-proc #:handle-action #:basic-actions #:forward #:notify #:no-op #:printer #:value-add #:create #:connect #:modify-value #:add #:multiply @@ -104,34 +104,41 @@ (defun merge-actions (&optional act+ (base (basic-actions))) (util:plist-merge base act+)) + +(defun gen-proc (actions &key default before after) + (lambda (msg scope) + (let* ((key (message:action msg)) + (acts (getf actions key (getf actions :default default)))) + (dolist (act (alx:flatten (cons before (cons acts (list after))))) + (when act + (util:mv-bind (nmsg (nscope scope)) (funcall act msg scope) + (setf msg nmsg scope nscope))))) + (update scope))) (defun std-proc (&rest args &key actions &allow-other-keys) (let ((actions (or actions (merge-actions args)))) - (lambda (msg scope) - (util:mv-bind (nmsg (nscope scope)) - (handle-action msg scope :actions actions) - (when nmsg (forward nmsg (syns nscope))) - (update nscope))))) + (gen-proc actions + :after (lambda (msg scope) (forward msg scope) msg)))) (defun eff-proc (&rest args &key actions &allow-other-keys) (let ((actions (or actions (merge-actions args)))) - (lambda (msg scope) - (util:mv-bind (nmsg (nscope scope)) - (handle-action msg scope :default (no-op) :actions actions) - (when nmsg - (setf (nth 1 (shape:head nmsg)) :effect) - (forward nmsg (syns nscope)) - (unless (syns nscope) (notify nmsg nscope))) - (update nscope))))) + (flet ((forward-eff (msg scope) + (when msg + (setf (nth 1 (shape:head msg)) :effect) + (forward msg scope) + (unless (syns scope) (notify msg scope))) + msg)) + (gen-proc actions :after #'forward-eff)))) (defun handle-action (msg scope &key (default (no-op)) actions) (let* ((key (message:action msg)) (act (getf actions key (getf actions :default default)))) (funcall act msg scope))) -(defun forward (msg syns) - (dolist (s syns) - (funcall s msg))) +(defun forward (msg scope) + (when msg + (dolist (s (syns scope)) + (funcall s msg)))) (defun notify (msg scope) (setf (actor:customer msg) actor:*self*) diff --git a/csys/environ.lisp b/csys/environ.lisp index e72d50e..0e3d014 100644 --- a/csys/environ.lisp +++ b/csys/environ.lisp @@ -138,7 +138,7 @@ (env *env*) &allow-other-keys) (let ((head (list domain :create))) (when (listp rcvr) - (setf head (append head (cdr rcvr))) + (setf head (append head rcvr)) (setf rcvr nil)) (setf args (alx:remove-from-plist args :domain :env)) (send-message head args :customer rcvr :env env))) diff --git a/test/test-core.lisp b/test/test-core.lisp index 3de8995..04c8318 100644 --- a/test/test-core.lisp +++ b/test/test-core.lisp @@ -102,10 +102,14 @@ (let ((pl '(:a 0))) (== (util:plist-add pl :b 1) '(:b 1 :a 0)) (== pl '(:b 1 :a 0))) - (util:mv-bind (a (b :not-set) c) (values 42 2) - (== a 42) - (== b 2) - (== c nil)) + (let ((x 1) (b 99)) + (util:mv-bind (a (b :not-set) c) (values 42 2) + (== a 42) + (== b 2) + (== c nil) + (setf x a)) + (== b 99) + (== x 42)) (util:load-dotenv (t:test-path ".test.env")) (== (util:getenv "SCOPES_USER") "user-from-env-file") (== (util:getenv "SCOPES_PASSWORD") "very_secret")) diff --git a/test/test-csys.lisp b/test/test-csys.lisp index 08c9ead..6ce2b48 100644 --- a/test/test-csys.lisp +++ b/test/test-csys.lisp @@ -130,7 +130,7 @@ (deftest test-gene-0 () (let ((environ:*env* (setup (gene:config-g0))) (rcvr (tc:receiver t:*test-suite*))) - (environ:send-create '(:csys :c00 #(0 0)) :cat :e10 :connect :succ :value 2) + (environ:send-create '(:c00 #(0 0)) :cat :e10 :connect :succ :value 2) (sleep 0.01) (environ:send-value '(:c00 #(0 0)) 2) ;(environ:send-value '(:c00 #(0 0)) 2)