csys, shape/space: use new space package for location-based indexing, making util/index obsolete
This commit is contained in:
parent
e6bccc140a
commit
ca678e5bdc
4 changed files with 23 additions and 30 deletions
|
|
@ -4,9 +4,9 @@
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:local-nicknames (:actor :scopes/core/actor)
|
(:local-nicknames (:actor :scopes/core/actor)
|
||||||
(:csys :scopes/csys)
|
(:csys :scopes/csys)
|
||||||
(:index :scopes/util/index)
|
|
||||||
(:message :scopes/core/message)
|
(:message :scopes/core/message)
|
||||||
(:shape :scopes/shape)
|
(:shape :scopes/shape)
|
||||||
|
(:space :scopes/shape/space)
|
||||||
(:util :scopes/util))
|
(:util :scopes/util))
|
||||||
(:export #:*env*
|
(:export #:*env*
|
||||||
#:create #:simple-setup #:simple-proc
|
#:create #:simple-setup #:simple-proc
|
||||||
|
|
@ -22,7 +22,7 @@
|
||||||
|
|
||||||
(defun create (proc meta-env &key eff-contacts (spaces '(:env :csys)))
|
(defun create (proc meta-env &key eff-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 (index: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 eff-contacts env (spaces scope))
|
(create-contact-cells eff-contacts env (spaces scope))
|
||||||
|
|
@ -125,19 +125,13 @@
|
||||||
(defun register-cell (reg addr cell)
|
(defun register-cell (reg addr cell)
|
||||||
(destructuring-bind (dom cat &optional (loc "")) addr
|
(destructuring-bind (dom cat &optional (loc "")) addr
|
||||||
(let ((idx (getf reg dom)))
|
(let ((idx (getf reg dom)))
|
||||||
(index:put idx loc cell))))
|
(space:put idx loc cell))))
|
||||||
|
|
||||||
(defun find-cells (reg addr &key no-warn)
|
|
||||||
(destructuring-bind (dom cat &optional (loc "")) addr
|
|
||||||
(let* ((idx (getf reg dom))
|
|
||||||
(cells (when idx (index:query idx loc))))
|
|
||||||
(unless (or no-warn cells)
|
|
||||||
(util:lgw "not found" addr reg idx))
|
|
||||||
cells)))
|
|
||||||
|
|
||||||
(defun find-cell (reg addr &key no-warn)
|
(defun find-cell (reg addr &key no-warn)
|
||||||
(let ((cells (find-cells reg addr :no-warn no-warn)))
|
(destructuring-bind (dom cat loc) addr
|
||||||
(when (> (length cells) 1)
|
(let* ((idx (getf reg dom))
|
||||||
(util:lgw "more than one cell found" addr reg cells))
|
(cell (space:fetch idx loc)))
|
||||||
(car cells)))
|
(unless (or no-warn cell)
|
||||||
|
(util:lgw "not found" addr reg idx))
|
||||||
|
cell)))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -21,10 +21,10 @@
|
||||||
(:file "forge/forge" :depends-on ("util/iter" "util/util"))
|
(:file "forge/forge" :depends-on ("util/iter" "util/util"))
|
||||||
(:file "logging" :depends-on ("config" "util/util"))
|
(:file "logging" :depends-on ("config" "util/util"))
|
||||||
(:file "shape/shape")
|
(:file "shape/shape")
|
||||||
|
(:file "shape/space")
|
||||||
(:file "util/util")
|
(:file "util/util")
|
||||||
(:file "util/async" :depends-on ("util/util"))
|
(:file "util/async" :depends-on ("util/util"))
|
||||||
(:file "util/crypt" :depends-on ("util/util"))
|
(:file "util/crypt" :depends-on ("util/util"))
|
||||||
(:file "util/index")
|
|
||||||
(:file "util/iter")
|
(:file "util/iter")
|
||||||
(:file "testing" :depends-on ("util/util")))
|
(:file "testing" :depends-on ("util/util")))
|
||||||
:long-description "scopes/core: The core packages of the scopes project."
|
:long-description "scopes/core: The core packages of the scopes project."
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
(defpackage :scopes/shape/space
|
(defpackage :scopes/shape/space
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:local-nicknames (:alx :alexandria))
|
(:local-nicknames (:alx :alexandria))
|
||||||
(:export #:create #:put #:get #:query))
|
(:export #:create #:put #:fetch #:query))
|
||||||
|
|
||||||
(in-package :scopes/shape/space)
|
(in-package :scopes/shape/space)
|
||||||
|
|
||||||
|
|
@ -14,7 +14,7 @@
|
||||||
(defun put (space key value)
|
(defun put (space key value)
|
||||||
(setf (gethash key space) value))
|
(setf (gethash key space) value))
|
||||||
|
|
||||||
(defun get (space key)
|
(defun fetch (space key)
|
||||||
(gethash key space))
|
(gethash key space))
|
||||||
|
|
||||||
(defun query (space pattern)
|
(defun query (space pattern)
|
||||||
|
|
|
||||||
|
|
@ -9,11 +9,11 @@
|
||||||
(:config :scopes/config)
|
(:config :scopes/config)
|
||||||
(:core :scopes/core)
|
(:core :scopes/core)
|
||||||
(:crypt :scopes/util/crypt)
|
(:crypt :scopes/util/crypt)
|
||||||
(:index :scopes/util/index)
|
|
||||||
(:iter :scopes/util/iter)
|
(:iter :scopes/util/iter)
|
||||||
(:logging :scopes/logging)
|
(:logging :scopes/logging)
|
||||||
(:message :scopes/core/message)
|
(:message :scopes/core/message)
|
||||||
(:shape :scopes/shape)
|
(:shape :scopes/shape)
|
||||||
|
(:space :scopes/shape/space)
|
||||||
(:util :scopes/util)
|
(:util :scopes/util)
|
||||||
(:t :scopes/testing))
|
(:t :scopes/testing))
|
||||||
(:export #:run #:user #:password
|
(:export #:run #:user #:password
|
||||||
|
|
@ -68,9 +68,9 @@
|
||||||
(progn
|
(progn
|
||||||
(test-util)
|
(test-util)
|
||||||
(test-util-crypt)
|
(test-util-crypt)
|
||||||
(test-util-index)
|
|
||||||
(test-util-iter)
|
(test-util-iter)
|
||||||
(test-shape)
|
(test-shape)
|
||||||
|
(test-space)
|
||||||
(core:setup-services)
|
(core:setup-services)
|
||||||
(test-util-async)
|
(test-util-async)
|
||||||
(test-actor)
|
(test-actor)
|
||||||
|
|
@ -123,16 +123,6 @@
|
||||||
(== (iter:next it) nil)
|
(== (iter:next it) nil)
|
||||||
(== (string (iter:value it)) "A")))
|
(== (string (iter:value it)) "A")))
|
||||||
|
|
||||||
(deftest test-util-index ()
|
|
||||||
(let ((idx (index:create)))
|
|
||||||
(index:put idx "1-1" 42)
|
|
||||||
(index:put idx "1-2" 46)
|
|
||||||
(index:put idx "1-1" 43)
|
|
||||||
(== (index:query idx "1-1") '(43 42))
|
|
||||||
(== (index:query idx "1-2") '(46))
|
|
||||||
(== (index:query idx "*") '(46 43 42))
|
|
||||||
))
|
|
||||||
|
|
||||||
(deftest test-shape ()
|
(deftest test-shape ()
|
||||||
(let ((rec (make-instance 'shape:record :head '(:t1))))
|
(let ((rec (make-instance 'shape:record :head '(:t1))))
|
||||||
(== (shape:head rec) '(:t1 nil))
|
(== (shape:head rec) '(:t1 nil))
|
||||||
|
|
@ -142,6 +132,15 @@
|
||||||
(== (shape:head-plist-str rec) '(:taskid "t1" :username "u1"))
|
(== (shape:head-plist-str rec) '(:taskid "t1" :username "u1"))
|
||||||
))
|
))
|
||||||
|
|
||||||
|
(deftest test-space ()
|
||||||
|
(let ((idx (space:create)))
|
||||||
|
(space:put idx "1-1" 42)
|
||||||
|
(space:put idx "1-2" 46)
|
||||||
|
(space:put idx "1-1" 43)
|
||||||
|
(== (space:fetch idx "1-1") 43)
|
||||||
|
(== (space:fetch idx "1-2") 46)
|
||||||
|
))
|
||||||
|
|
||||||
(deftest test-util-async ()
|
(deftest test-util-async ()
|
||||||
(let ((mb (async:make-task nil)))
|
(let ((mb (async:make-task nil)))
|
||||||
(async:submit-task mb (lambda () (sleep 0.1) :done))
|
(async:submit-task mb (lambda () (sleep 0.1) :done))
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue