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

csys: use new gen-proc also in test and environ code

Browse source
This commit is contained in:
Helmut Merz 2026-10-12 16:45:54 +02:00
parent 38c7912bb8
commit 05e31c1d68
4 changed files with 19 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
csys/csys.lisp
View file

@ -12,7 +12,7 @@
#:scope #:environ #:scope #:environ
#:make-program #:create-zero #:make-program #:create-zero
#:neuron #:gen-proc #:std-proc #:eff-proc #:neuron #:gen-proc #:std-proc #:eff-proc
#:handle-action #:basic-actions #:forward #:notify #:basic-actions #:forward #:notify
#:no-op #:printer #:value-add #:create #:connect #:no-op #:printer #:value-add #:create #:connect
#:modify-value #:add #:multiply #:modify-value #:add #:multiply
#:send-message #:send-create #:send-connect #:send-switch)) #:send-message #:send-create #:send-connect #:send-switch))
@ -118,7 +118,7 @@
(defun std-proc (&rest args &key actions &allow-other-keys) (defun std-proc (&rest args &key actions &allow-other-keys)
(let ((actions (or actions (merge-actions args)))) (let ((actions (or actions (merge-actions args))))
(gen-proc actions (gen-proc actions
:after (lambda (msg scope) (forward msg scope) msg)))) :after (lambda (msg scope) (forward msg scope)))))
(defun eff-proc (&rest args &key actions &allow-other-keys) (defun eff-proc (&rest args &key actions &allow-other-keys)
(let ((actions (or actions (merge-actions args)))) (let ((actions (or actions (merge-actions args))))
@ -126,19 +126,14 @@
(when msg (when msg
(setf (nth 1 (shape:head msg)) :effect) (setf (nth 1 (shape:head msg)) :effect)
(forward msg scope) (forward msg scope)
(unless (syns scope) (notify msg scope))) (unless (syns scope) (notify msg scope)))))
msg))
(gen-proc actions :after #'forward-eff)))) (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 scope) (defun forward (msg scope)
(when msg (when msg
(dolist (s (syns scope)) (dolist (s (syns scope))
(funcall s msg)))) (funcall s msg)))
msg)
(defun notify (msg scope) (defun notify (msg scope)
(setf (actor:customer msg) actor:*self*) (setf (actor:customer msg) actor:*self*)

9
csys/environ.lisp
View file

@ -32,18 +32,15 @@
(defun simple-setup (cfg) (defun simple-setup (cfg)
(destructuring-bind (prg &key std contacts) cfg (destructuring-bind (prg &key std contacts) cfg
(let* ((env (create #'simple-proc (csys:printer) :contacts contacts)) (let* ((env (create (simple-proc) (csys:printer) :contacts contacts))
(zero-val (getf std :bias 0)) (zero-val (getf std :bias 0))
(zero-cat (getf std :cat :c00))) (zero-cat (getf std :cat :c00)))
(csys:create-zero prg env :categ (list csys:*domain* zero-cat) :value zero-val) (csys:create-zero prg env :categ (list csys:*domain* zero-cat) :value zero-val)
env))) env)))
(defun simple-proc (msg scope) (defun simple-proc (msg scope)
(util:mv-bind (nmsg (scope scope)) (csys:gen-proc (actions)
(csys:handle-action msg scope :actions (actions)) :after (lambda (msg scope) (actor:send (csys:environ scope) msg))))
(util:lgi msg nmsg)
(when nmsg
(actor:send (csys:environ scope) nmsg))))
;;;; eff contact cells ;;;; eff contact cells

13
test/test-csys.lisp
View file

@ -41,12 +41,13 @@
(config:add-action '(:csys) #'tc:collect)) (config:add-action '(:csys) #'tc:collect))
(defun proc-env (msg scope) (defun proc-env (msg scope)
(let ((t:*test-suite* (csys:environ scope))) (let* ((t:*test-suite* (csys:environ scope))
(util:mv-bind (nmsg (scope scope)) (proc
(csys:handle-action msg scope :actions (environ:actions)) (csys:gen-proc (environ:actions)
(util:lgi msg nmsg) :after (lambda (msg scope)
(when nmsg (when msg
(actor:send (core:mailbox (tc:receiver t:*test-suite*)) nmsg))))) (actor:send (core:mailbox (tc:receiver t:*test-suite*)) msg))))))
(funcall proc msg scope)))
(defun run () (defun run ()
(let ((t:*test-suite* (make-instance 'tc:test-suite :name "csys"))) (let ((t:*test-suite* (make-instance 'tc:test-suite :name "csys")))

2
util/util.lisp
View file

@ -99,7 +99,7 @@
`(setf ,pl (cons ,k (cons ,v ,pl)))) `(setf ,pl (cons ,k (cons ,v ,pl))))
(defmacro mv-bind (vars vform &body body) (defmacro mv-bind (vars vform &body body)
`(destructuring-bind ,(cons (car vars) (cons '&optional (cdr vars))) `(destructuring-bind ,(cons '&optional (cons (car vars) (cdr vars)))
(multiple-value-list ,vform) ,@body)) (multiple-value-list ,vform) ,@body))
(defun with-iterator (it fn) (defun with-iterator (it fn)