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

csys: creation of two additional cells (with addr / categ) OK

Browse source
This commit is contained in:
Helmut Merz 2026-07-27 19:12:04 +02:00
parent f2d4b32fdc
commit d27049230d
3 changed files with 27 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
csys/csys.lisp
View file

@ -36,11 +36,16 @@
(set-proc sc)) (set-proc sc))
(defun reset-scope (scp &rest args) (defun reset-scope (scp &rest args)
(let* ((addr (getf args :addr))
(categ (if addr
(list (car addr) (cadr addr))
(getf args :categ (categ scp)))))
(setf args (alx:remove-from-plist args :categ :addr))
(apply #'scope (apply #'scope
(getf args :program (program scp)) (getf args :program (program scp))
(getf args :environ (environ scp)) (getf args :environ (environ scp))
:categ (getf args :categ (categ scp)) :categ categ
args)) args)))
(defun set-proc (scope) (defun set-proc (scope)
(setf (proc scope) (funcall (program scope) scope)) (setf (proc scope) (funcall (program scope) scope))
@ -49,7 +54,7 @@
(defgeneric make-program (spec) (defgeneric make-program (spec)
(:method ((proc function)) (lambda (scope) proc)) (:method ((proc function)) (lambda (scope) proc))
(:method ((spec list)) (:method ((spec list))
(make-program (alx:plist-hash-table spec :test :equal))) (make-program (alx:plist-hash-table spec :test #'equal)))
(:method ((spec hash-table)) (:method ((spec hash-table))
(lambda (scope) (lambda (scope)
(let* ((cat (cadr (categ scope))) (let* ((cat (cadr (categ scope)))

4
csys/environ.lisp
View file

@ -32,7 +32,7 @@
(defun cell-created (msg scope) (defun cell-created (msg scope)
(let* ((data (shape:data msg)) (let* ((data (shape:data msg))
(addr (getf data :addr)) (addr (getf data :addr (getf data :categ)))
(new (getf data :new))) (new (getf data :new)))
(when addr (when addr
(register-cell (cells scope) addr new)) (register-cell (cells scope) addr new))
@ -49,7 +49,7 @@
;;;; helpers ;;;; helpers
(defun register-cell (reg addr cell) (defun register-cell (reg addr cell)
(destructuring-bind (dom cat key) addr (destructuring-bind (dom cat &optional (key "")) addr
(let* ((dcat (list dom cat)) (let* ((dcat (list dom cat))
(idx (gethash dcat reg))) (idx (gethash dcat reg)))
(unless idx (unless idx

16
test/test-csys.lisp
View file

@ -64,9 +64,13 @@
;;;; (move to scopes/csys/programs) ;;;; (move to scopes/csys/programs)
(defun test-program () (defun test-program ()
;; set up plist for (:default :initial), :default
(csys:make-program (csys:eff-proc :actions (actions-zero-initial)))) (csys:make-program (csys:eff-proc :actions (actions-zero-initial))))
(defun prog-b0 ()
(csys:make-program
(list '(:c00 :initial) (csys:eff-proc :actions (actions-zero-initial))
':default (csys:std-proc))))
(defun actions-zero-initial () (defun actions-zero-initial ()
(let ((acts (csys:basic-actions))) (let ((acts (csys:basic-actions)))
(setf (getf acts :next) (next-zero-initial)) (setf (getf acts :next) (next-zero-initial))
@ -74,15 +78,19 @@
(defun next-zero-initial () (defun next-zero-initial ()
(lambda (msg scope) (lambda (msg scope)
(util:lgi msg) (let ((head '(:csys :create :c00 "0-0")))
(actor:send actor:*self*
(message:create head :data '(:categ (:csys :e01))))
(actor:send actor:*self*
(message:create head :data '(:addr (:csys :s01 "0-1"))))
;; create :succ :e01; create :pred :s01; connect *self* :op (multiply -1) ;; create :succ :e01; create :pred :s01; connect *self* :op (multiply -1)
;; switch :active ;; switch :active
nil)) nil)))
;;;; test definitions ;;;; test definitions
(deftest test-basic-0 () (deftest test-basic-0 ()
(let ((env (setup-test (test-program))) (let ((env (setup-test (prog-b0)))
(rcvr (tc:receiver t:*test-suite*))) (rcvr (tc:receiver t:*test-suite*)))
(sleep 0.1) (sleep 0.1)
(tc:expect rcvr (message:create '(:csys :effect :c00) :data '(:value 1))) (tc:expect rcvr (message:create '(:csys :effect :c00) :data '(:value 1)))