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

csys/environ: add cells index, always use scope for storing or retrieving cells

Browse source
This commit is contained in:
Helmut Merz 2026-09-25 09:23:59 +02:00
parent d910366dac
commit 2fe73c3632
1 changed files with 23 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
csys/environ.lisp
View file

@ -18,14 +18,15 @@
(defvar *env* nil) (defvar *env* nil)
(defclass scope (csys:scope) (defclass scope (csys:scope)
((spaces :reader spaces :initarg :spaces))) ((spaces :reader spaces :initarg :spaces)
(cells :reader cells :initform (make-hash-table))))
(defun create (proc meta-env &key contacts (spaces '(:env :csys))) (defun create (proc meta-env &key contacts (spaces '(:env :csys)))
(let* ((prg (csys:make-program proc)) (let* ((prg (csys:make-program proc))
(spcs (loop for d in spaces append (list d (space:create)))) (spcs (loop for d in spaces append (list d (space:create))))
(scope (csys:scope prg meta-env :cls 'scope :categ '(:env :c00) :spaces spcs)) (scope (csys:scope prg meta-env :cls 'scope :categ '(:env :c00) :spaces spcs))
(env (csys:neuron scope))) (env (csys:neuron scope)))
(create-contact-cells contacts env (spaces scope)) (create-contact-cells contacts env scope)
env)) env))
(defun simple-setup (cfg) (defun simple-setup (cfg)
@ -48,7 +49,7 @@
(defclass contact-scope (csys:scope) (defclass contact-scope (csys:scope)
((loc :reader loc :initarg :loc))) ((loc :reader loc :initarg :loc)))
(defun create-contact-cells (contacts env cells) (defun create-contact-cells (contacts env scope)
(util:loop-plist contacts cat locs do (util:loop-plist contacts cat locs do
(dolist (loc locs) (dolist (loc locs)
(let ((ct (csys:neuron (let ((ct (csys:neuron
@ -56,7 +57,7 @@
:cls 'contact-scope :cls 'contact-scope
:categ (list :env cat) :loc loc)))) :categ (list :env cat) :loc loc))))
;(util:lgi cells cat loc) ;(util:lgi cells cat loc)
(register-cell cells (list :env cat loc) ct))))) (register-cell scope (list :env cat loc) ct)))))
(defun proc-contact (msg scope) (defun proc-contact (msg scope)
(let ((head (copy-list (shape:head msg)))) (let ((head (copy-list (shape:head msg))))
@ -78,9 +79,9 @@
(addr (getf data :addr (getf data :categ))) (addr (getf data :addr (getf data :categ)))
(new (getf data :new))) (new (getf data :new)))
(when addr (when addr
(register-cell (spaces scope) addr new)) (register-cell scope addr new))
(let* ((ct-addr (cons :env (cdr addr))) (let* ((ct-addr (cons :env (cdr addr)))
(ct (find-cell (spaces scope) ct-addr :no-warn t))) (ct (find-cell scope ct-addr :no-warn t)))
(when ct (csys:send-connect new ct))) (when ct (csys:send-connect new ct)))
(csys:send-message new (list (message:domain msg) :next) data) (csys:send-message new (list (message:domain msg) :next) data)
nil)) nil))
@ -88,7 +89,7 @@
(defun forward (msg scope) (defun forward (msg scope)
(let ((addr (message:addr msg))) (let ((addr (message:addr msg)))
(if addr (if addr
(let ((cell (find-cell (spaces scope) (message:addr msg)))) (let ((cell (find-cell scope (message:addr msg))))
(actor:send cell msg)) (actor:send cell msg))
(let ((rcvr (actor:customer msg))) (let ((rcvr (actor:customer msg)))
(if rcvr (if rcvr
@ -101,8 +102,9 @@
(let* ((data (shape:data msg)) (let* ((data (shape:data msg))
(tgt (getf data :target)) (tgt (getf data :target))
(cust (actor:customer msg))) (cust (actor:customer msg)))
(when (listp tgt) (cond
(setf (getf data :target) (find-cell (spaces scope) tgt))) ((null tgt) (setf (getf data :target) (find-cell-near scope cust)))
((listp tgt) (setf (getf data :target) (find-cell scope tgt))))
(forward (message:create (shape:head msg) :data data :customer cust) scope))) (forward (message:create (shape:head msg) :data data :customer cust) scope)))
;;;; public shortcuts ;;;; public shortcuts
@ -115,7 +117,6 @@
(send-message head `(:value ,val) :env env))) (send-message head `(:value ,val) :env env)))
(defun send-connect (rcvr target &key (domain csys:*domain*) (env *env*) op) (defun send-connect (rcvr target &key (domain csys:*domain*) (env *env*) op)
;; TODO: use msg.customer instead of :to in data
(let* ((cat-loc (when (listp rcvr) rcvr)) (let* ((cat-loc (when (listp rcvr) rcvr))
(head (cons domain (cons :connect cat-loc))) (head (cons domain (cons :connect cat-loc)))
(cust (unless cat-loc rcvr)) (cust (unless cat-loc rcvr))
@ -128,16 +129,21 @@
;;;; internal helpers ;;;; internal helpers
(defun register-cell (reg addr cell) (defun register-cell (scope addr cell)
(destructuring-bind (dom cat &optional (loc "")) addr (destructuring-bind (dom cat &optional (loc "")) addr
(let ((idx (getf reg dom))) (let* ((reg (spaces scope))
(space:put idx loc cell)))) (spc (getf reg dom)))
(space:put spc loc cell)
(setf (gethash cell (cells scope)) addr))))
(defun find-cell (reg addr &key no-warn) (defun find-cell (scope addr &key no-warn)
(destructuring-bind (dom cat &optional loc) addr (destructuring-bind (dom cat &optional loc) addr
(let* ((idx (getf reg dom)) (let* ((reg (spaces scope))
(cell (space:fetch idx loc))) (spc (getf reg dom))
(cell (space:fetch spc loc)))
(unless (or no-warn cell) (unless (or no-warn cell)
(util:lgw "not found" addr reg idx)) (util:lgw "not found" addr reg spc))
cell))) cell)))
(defun find-cell-near (scope cell))