[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Mon May 1 20:23:14 UTC 2006
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 , at body))))
-
-
-
(defmacro c?dbg (&body body)
`(make-c-dependent
:code ',body
@@ -74,6 +71,14 @@
:lazy t
:rule (c-lambda , at 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 , at 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 () , at 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)
More information about the Cells-cvs
mailing list