Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv5472/cells
Modified Files: cell-types.lisp cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse.lisp Removed Files: cells-test.asd cells-test.lpr rif.lisp Log Message:
Date: Sun Jul 4 11:59:41 2004 Author: ktilton
Index: cell-cultures/cells/cell-types.lisp diff -u cell-cultures/cells/cell-types.lisp:1.1 cell-cultures/cells/cell-types.lisp:1.2 --- cell-cultures/cells/cell-types.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/cell-types.lisp Sun Jul 4 11:59:41 2004 @@ -53,8 +53,8 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - (synapses nil :type list) lazy + (code nil :type list) ;; /// feature this out on production build rule)
(defun c-optimized-away-p (c) @@ -73,8 +73,8 @@ (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) + (synapses nil :type list) (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build (usage (make-array *cd-usagect* :element-type 'bit :initial-element 0) :type vector))
Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.2 cell-cultures/cells/cells.lisp:1.3 --- cell-cultures/cells/cells.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/cells/cells.lisp Sun Jul 4 11:59:41 2004 @@ -112,6 +112,7 @@ (declare (ignorable slot-name self new old old-boundp)))
+ ; -------- cell conditions (not much used) ---------------------------------------------
(define-condition xcell () ;; new 2k0227
Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.1 cell-cultures/cells/constructors.lisp:1.2 --- cell-cultures/cells/constructors.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/constructors.lisp Sun Jul 4 11:59:41 2004 @@ -87,7 +87,7 @@ :code ',forms :value-state :unevaluated :rule (c-lambda ,@forms) - ,@keys)) + ,@keys))
(defmacro c-input ((&rest keys) &optional (value nil valued-p)) `(make-cell
Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.3 cell-cultures/cells/defpackage.lisp:1.4 --- cell-cultures/cells/defpackage.lisp:1.3 Wed Jun 30 14:02:47 2004 +++ cell-cultures/cells/defpackage.lisp Sun Jul 4 11:59:41 2004 @@ -38,15 +38,19 @@
#:class-precedence-list #:class-slots #:slot-definition-name ) - - (:export #:cell #:c-input #:c-in #:c-in8 #:c? #:c?8 #:c?_ #:c?? + #+clisp (:import-from #:clos #:class-slots #:class-precedence-list) + #+cmu (:import-from #:pcl #:class-precedence-list #:class-slots + #:slot-definition-name #:true) + #+lispworks (:import-from #:lw #:true) + (:export #:cell #:c-input #:c-in #:c-in8 + #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:c... #:make-be #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids - #:cell-reset #:upper #:fm-max #:nearest #:^fm-min-kid #:^fm-max-kid #:mk-kid-slot + #:cell-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib #:to-be #:not-to-be #:ssibno #:md-awaken
Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.1 cell-cultures/cells/integrity.lisp:1.2 --- cell-cultures/cells/integrity.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/integrity.lisp Sun Jul 4 11:59:41 2004 @@ -24,6 +24,7 @@
(defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (if (< *data-pulse-id* most-positive-fixnum) (incf *data-pulse-id*) (progn @@ -93,7 +94,7 @@ (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) - (data-pulse-next defer-info) + (data-pulse-next (cons opcode defer-info)) (trc nil "!!! New pulse, event" *data-pulse-id* defer-info)) (prog1 (funcall action)
Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.1 cell-cultures/cells/md-slot-value.lisp:1.2 --- cell-cultures/cells/md-slot-value.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/md-slot-value.lisp Sun Jul 4 11:59:41 2004 @@ -54,6 +54,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) + (trc c "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.1 cell-cultures/cells/model-object.lisp:1.2 --- cell-cultures/cells/model-object.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/model-object.lisp Sun Jul 4 11:59:41 2004 @@ -96,15 +96,15 @@ (c-model c) self (c-slot-name c) sn (md-slot-cell self sn) c)) - (if (c-unboundp c) - (progn (trc "unbound cell" (type-of c) c) - (bd-slot-makunbound self sn)) - (setf (slot-value self sn) - (if c-isa-cell + + (if c-isa-cell + (if (c-unboundp c) + (bd-slot-makunbound self sn) + (setf (slot-value self sn) (if (c-inputp c) - (c-value c) - nil) - c)))) + (c-value c) + nil))) + (setf (slot-value self sn) c)))
;------------------ md obj initialization ------------------
Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.1 cell-cultures/cells/propagate.lisp:1.2 --- cell-cultures/cells/propagate.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/propagate.lisp Sun Jul 4 11:59:41 2004 @@ -56,15 +56,14 @@ (c-output-slot c (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied)))
- (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c :cause *causation*) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) - (trc nil "c-propagate-to-users> cause, user, c:" *causation* user c) + (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) (c-value-ensure-current user)))))))
@@ -89,7 +88,7 @@ (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil)))
(defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation *causation*)) ;; in case deferred (with-integrity (:c-output-slot :output c) (let ((*causation* causation)) (trc nil "c-output-slot > causation" c *causation* causation)
Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.1 cell-cultures/cells/synapse.lisp:1.2 --- cell-cultures/cells/synapse.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/synapse.lisp Sun Jul 4 11:59:41 2004 @@ -28,13 +28,13 @@ (defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) (declare (ignorable trcp)) (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key (cr-synapses + `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses (car *c-calculators*)))) (cdar (push (cons ',lex-loc-key (let (,@closure-vars) (make-synaptic-ruled slot-c (,fire-p ,fire-value) ,@body))) - (cr-synapses + (cd-synapses (car *c-calculators*))))))) (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) (c-value-ensure-current synapse)))))