Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30537
Modified Files: cells.lisp cells.lpr constructors.lisp defpackage.lisp family.lisp fm-utilities.lisp initialize.lisp integrity.lisp md-slot-value.lisp Log Message: Mainly remove WITH-INTEGRITY wrapper from (setf md-slot-value). Big change, that.
--- /project/cells/cvsroot/cells/cells.lisp 2006/03/16 05:28:28 1.7 +++ /project/cells/cvsroot/cells/cells.lisp 2006/05/01 20:23:14 1.8 @@ -141,7 +141,7 @@ (unless *stop* (c-stop args) (format t "c-break > stopping > ~a" args) - (apply #'error args))) + (apply 'break args)))
--- /project/cells/cvsroot/cells/cells.lpr 2006/03/22 04:08:34 1.9 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/01 20:23:14 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -49,7 +49,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::go-deep + :on-initialization 'cells::test :on-restart 'do-default-restart)
;; End of Project Definition --- /project/cells/cvsroot/cells/constructors.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/05/01 20:23:14 1.5 @@ -57,9 +57,6 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body))))
- - - (defmacro c?dbg (&body body) `(make-c-dependent :code ',body @@ -74,6 +71,14 @@ :lazy t :rule (c-lambda ,@body)))
+(defmacro c_? (&body body) + "Lazy until asked, then eagerly propagating" + `(make-c-dependent + :code ',body + :value-state :unevaluated + :lazy :until-asked + :rule (c-lambda ,@body))) + (defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) (let ((result (copy-symbol 'result)) (thetag (gensym))) --- /project/cells/cvsroot/cells/defpackage.lisp 2006/03/22 04:08:34 1.5 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/05/01 20:23:14 1.6 @@ -41,11 +41,11 @@
#:class-precedence-list #-(and mcl (not openmcl-partial-mop)) #:class-slots - #-clisp #:slot-definition-name + #:slot-definition-name ) (:export #:cell #:.md-name #:c-input #:c-in #:c-in8 - #:c-formula #:c? #:c?8 #:c?_ #:c?? + #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c?? #:with-integrity #:without-c-dependency #:self #:*parent* #:.cache #:.with-c-cache #:c-lambda #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test --- /project/cells/cvsroot/cells/family.lisp 2006/04/01 21:47:00 1.5 +++ /project/cells/cvsroot/cells/family.lisp 2006/05/01 20:23:14 1.6 @@ -36,7 +36,8 @@ nil)
(defmethod print-object ((self model) s) - (format s "~a" (or (md-name self) (type-of self)))) + (format s "~a" (type-of self)) + #+shhh (format s "~a" (or (md-name self) (type-of self))))
(define-symbol-macro .parent (fm-parent self))
@@ -143,7 +144,7 @@
(defobserver .kids ((self family) new-kids old-kids) (declare (ignorable usage)) - (c-assert (listp new-kids)) + (c-assert (listp new-kids) () "New kids value for ~a not listp: ~a ~a" self (type-of new-kids) new-kids) (c-assert (listp old-kids)) (c-assert (not (member nil old-kids))) (c-assert (not (member nil new-kids))) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/26 14:05:49 1.5 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/01 20:23:14 1.6 @@ -525,7 +525,7 @@ (count-it :fm-find-one) (flet ((matcher (fm) (when diag - (trc "fm-find-one matcher sees" md-name fm (md-name fm))) + (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name)) (when (and (eql (name-root md-name)(md-name fm)) (or (null (name-subscript md-name)) (eql (name-subscript md-name) (fm-pos fm))) @@ -541,7 +541,7 @@ :skip-tree skip-tree :global-search global-search)))) (when (and must-find (null match)) - (trc "fm-find-one > erroring fm-not-found" family md-name must-find global-search) + (trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search) ;;(inspect family) (setq diag t must-find nil) (fm-traverse family #'matcher --- /project/cells/cvsroot/cells/initialize.lisp 2006/03/18 00:15:40 1.3 +++ /project/cells/cvsroot/cells/initialize.lisp 2006/05/01 20:23:14 1.4 @@ -34,10 +34,6 @@
(defmethod c-awaken-cell ((c cell)) (assert (c-inputp c)) - #+goforit(when (and (c-ephemeral-p c) - (c-value c)) - (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]" - (c-value c))) ; ; nothing to calculate, but every cellular slot should be output ; --- /project/cells/cvsroot/cells/integrity.lisp 2006/03/18 00:15:40 1.6 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/05/01 20:23:14 1.7 @@ -41,19 +41,36 @@ (when *stop* (return-from call-with-integrity)) (if *within-integrity* - (if opcode - (ufb-add opcode (cons defer-info action)) - (funcall action)) + (if opcode + (ufb-add opcode (cons defer-info action)) + (funcall action)) (let ((*within-integrity* t) - *unfinished-business*) + *unfinished-business* + *defer-changes*) (when (or (zerop *data-pulse-id*) - (eq opcode :change)) + (eq opcode :change) + ) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 (funcall action) (finish-business)))))
+(defmacro without-integrity ((&optional dbg-info) &rest body) + "Whimsical name for launching a self-contained, dynamic integrity chunk, as with +string-to-mx in the math-paper project, where everything is fully isolated from the +outside computation." + `(call-without-integrity ,dbg-info (lambda () ,@body))) + +(defun call-without-integrity (dbg-info action) + (declare (ignorable dbg-info)) + (let ((*within-integrity* nil) + *unfinished-business* + *defer-changes* + *c-calculators* + (*data-pulse-id* 0)) + (funcall action))) + (defun ufb-queue (opcode) (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) @@ -131,7 +148,7 @@ ;--- do deferred state changes ----------------------- ; (bwhen (task-info (fifo-pop (ufb-queue :change))) - (trc nil "!!!!!!!!!!!!!!!!!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) + (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/03/16 05:28:28 1.11 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/01 20:23:14 1.12 @@ -162,10 +162,25 @@ (when *defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
- (with-integrity (:change) + (progn ;; with-integrity (:change) + ;; + ;; ok, we had a weird bug to find caused by a SETF being deferred unexpectedly. + ;; This was the gears Togl demo, setf-ing a display-list in the create callback. It got + ;; called within the dynamic scope of the ufb queue handler doing the :make-tk items. + ;; When contemplating a fix, it occurred to me that I had no idea what to return from + ;; (setf md-slot-value) if the core setf behavior got deferred. I concluded one could not + ;; sensibly impose integrity automatically here, as slick as that might seem. So callers + ;; will have to provide the with-integrity (:change... wrapper. Since SETF happens mostly + ;; in event handling callbacks, hopefully this will not be necesssary at all. A quck check + ;; of Celtk confirms this pattern. + ;; (md-slot-value-assume c new-value nil))
- new-value) + ;; new-value + ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot + ;; not the value setf'ed (on rare occasions they diverge, or at least used to for delta slots) + ;; anyway, if they no longer diverge the question of which to return is moot + )
(defmethod md-slot-value-assume (c raw-value propagation-code) (assert c)