[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Wed Apr 23 03:20:10 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv1212
Modified Files:
cell-types.lisp cells.lisp defmodel.lisp family.lisp
integrity.lisp md-utilities.lisp model-object.lisp
propagate.lisp
Log Message:
Oops. Major repairs to handling of the owning property of cell slots.
--- /project/cells/cvsroot/cells/cell-types.lisp 2008/01/31 03:30:17 1.29
+++ /project/cells/cvsroot/cells/cell-types.lisp 2008/04/23 03:20:09 1.30
@@ -67,11 +67,12 @@
(call-next-method)
(progn
(c-print-value c stream)
- (format stream "=~d/~a/~a/~a]"
+ (format stream "<~d:~a ~a/~a = ~a>"
(c-pulse c)
- (c-state c)
+ (subseq (string (c-state c)) 0 1)
(symbol-name (or (c-slot-name c) :anoncell))
- (print-cell-model (c-model c))))))))
+ (print-cell-model (c-model c))
+ (c-value c)))))))
(export! print-cell-model)
--- /project/cells/cvsroot/cells/cells.lisp 2008/04/12 22:53:26 1.27
+++ /project/cells/cvsroot/cells/cells.lisp 2008/04/23 03:20:09 1.28
@@ -45,6 +45,7 @@
(defparameter *c-debug* nil)
(defparameter *defer-changes* nil)
(defparameter *within-integrity* nil)
+(defvar *istack*)
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
(defparameter *not-to-be* nil)
--- /project/cells/cvsroot/cells/defmodel.lisp 2008/04/22 10:11:50 1.19
+++ /project/cells/cvsroot/cells/defmodel.lisp 2008/04/23 03:20:09 1.20
@@ -103,7 +103,7 @@
`(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning
(setf (md-slot-cell-type ',class ',slotname) ,cell)
,(when owning
- `(setf (md-slot-owning? ',class ',slotname) ,owning))
+ `(setf (md-slot-owning-direct? ',class ',slotname) ,owning))
,(when reader-fn
`(defmethod ,reader-fn ((self ,class))
(md-slot-value self ',slotname)))
--- /project/cells/cvsroot/cells/family.lisp 2008/04/22 10:11:50 1.27
+++ /project/cells/cvsroot/cells/family.lisp 2008/04/23 03:20:09 1.28
@@ -94,6 +94,11 @@
:accessor kids
:initarg :kids)))
+#+test
+(let ((c (find-class 'family)))
+ (mop::finalize-inheritance c)
+ (class-precedence-list c))
+
(defmacro the-kids (&rest kids)
`(let ((*parent* self))
(packed-flat! , at kids)))
--- /project/cells/cvsroot/cells/integrity.lisp 2008/04/11 09:19:32 1.21
+++ /project/cells/cvsroot/cells/integrity.lisp 2008/04/23 03:20:09 1.22
@@ -28,11 +28,14 @@
(when opcode
(assert (find opcode *ufb-opcodes*) ()
"Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*))
- `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info)
- (declare (ignorable opcode defer-info))
- ,(when debug
- `(trc "integrity action entry" opcode defer-info ',body))
- , at body)))
+ `(call-with-integrity ,opcode ,defer-info
+ (lambda (opcode defer-info)
+ (declare (ignorable opcode defer-info))
+ ,(when debug
+ `(trc "integrity action entry" opcode defer-info ',body))
+ , at body)
+ (when *c-debug*
+ ',body)))
(export! with-cc)
@@ -43,7 +46,7 @@
(defun integrity-managed-p ()
*within-integrity*)
-(defun call-with-integrity (opcode defer-info action)
+(defun call-with-integrity (opcode defer-info action code)
(when *stop*
(return-from call-with-integrity))
(if *within-integrity*
@@ -58,17 +61,32 @@
;
:deferred-to-ufb-1)
(funcall action opcode defer-info))
- (let ((*within-integrity* t)
- *unfinished-business*
- *defer-changes*)
- (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
- (when (or (zerop *data-pulse-id*)
- (eq opcode :change))
- (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
- (data-pulse-next (cons opcode defer-info))))
- (prog1
- (funcall action opcode defer-info)
- (finish-business)))))
+ (flet ((go-go ()
+ (let ((*within-integrity* t)
+ *unfinished-business*
+ *defer-changes*)
+ (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
+ (when (or (zerop *data-pulse-id*)
+ (eq opcode :change))
+ (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
+ (data-pulse-next (cons opcode defer-info))))
+ (prog1
+ (funcall action opcode defer-info)
+ (finish-business)))))
+ (if *c-debug*
+ (let ((*istack* (list (list opcode defer-info)
+ (list :trigger code)
+ (list :start-dp *data-pulse-id*))))
+ (handler-case
+ (go-go)
+ (t (c)
+ (if (functionp *c-debug*)
+ (funcall *c-debug* c (nreverse *istack*))
+ (loop for f in (nreverse *istack*)
+ do (format t "~&istk> ~(~a~) " f)
+ finally (describe c)
+ (break "integ backtrace: see listener for deets"))))))
+ (go-go)))))
(defun ufb-queue (opcode)
(cdr (assoc opcode *unfinished-business*)))
@@ -85,14 +103,17 @@
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
(fifo-add (ufb-queue-ensure opcode) continuation))
-(defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q)
- (ufb-queue op-or-q)
- op-or-q)))
+(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; make-better
+ &aux (q (if (keywordp op-or-q)
+ (ufb-queue op-or-q)
+ op-or-q)))
(trc nil "----------------------------just do it doing---------------------" op-or-q)
(loop for (defer-info . task) = (fifo-pop q)
while task
do (trc nil "unfin task is" opcode task)
- (funcall task op-or-q defer-info)))
+ (when *c-debug*
+ (push (list op-code defer-info) *istack*))
+ (funcall task op-or-q defer-info)))
(defun finish-business ()
(when *stop* (return-from finish-business))
@@ -153,7 +174,7 @@
(bwhen (clientq (ufb-queue :client))
(if *client-queue-handler*
(funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check
- (just-do-it clientq))
+ (just-do-it clientq :client))
(when (fifo-peek (ufb-queue :client))
#+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry)
(trc "surprise client" entry)))
--- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 11:03:44 1.21
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/23 03:20:09 1.22
@@ -39,6 +39,7 @@
(declare (ignore self))
nil))
+
(defgeneric not-to-be (self)
(:method ((self list))
(dolist (s self)
@@ -55,8 +56,7 @@
(md-quiesce self))
(:method :before ((self model-object))
- (loop for (slot-name . owning?) in (get (type-of self) :ownings)
- when owning?
+ (loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
(:method :around ((self model-object))
--- /project/cells/cvsroot/cells/model-object.lisp 2008/04/22 10:11:50 1.20
+++ /project/cells/cvsroot/cells/model-object.lisp 2008/04/23 03:20:09 1.21
@@ -216,28 +216,55 @@
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
+#+hunh
+(md-slot-owning? 'mathx::prb-solver '.kids)
+
+#+hunh
+(cdr (assoc '.value (get 'm-index :indirect-ownings)))
+
+#+test
+(md-slot-owning? 'm-index '.value)
+
(defun md-slot-owning? (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
- (get slot-name :owning)
- (bif (entry (assoc slot-name (get class-name :ownings)))
+ (get slot-name :owning) ;; might be wrong -- support for specials is unfinished w.i.p.
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
(cdr entry)
- (dolist (super (class-precedence-list (find-class class-name)))
- (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings)))
- (return (setf (md-slot-owning? class-name slot-name) (cdr entry))))))))
+ (bif (entry (assoc slot-name (get class-name :indirect-ownings)))
+ (cdr entry)
+ (cdar
+ (push (cons slot-name
+ (cdr (loop for super in (cdr (class-precedence-list (find-class class-name)))
+ thereis (assoc slot-name (get (c-class-name super) :direct-ownings)))))
+ (get class-name :indirect-ownings)))))))
-(defun (setf md-slot-owning?) (value class-name slot-name)
+(defun (setf md-slot-owning-direct?) (value class-name slot-name)
(assert class-name)
- (if (eq class-name 'null)
+ (if (eq class-name 'null) ;; global variables
(setf (get slot-name :owning) value)
-
- (let ((entry (assoc slot-name (get class-name :ownings))))
- (if entry
- (progn
- (setf (cdr entry) value)
- (loop for c in (class-direct-subclasses (find-class class-name))
- do (setf (md-slot-owning? (class-name c) slot-name) value)))
- (push (cons slot-name value) (get class-name :ownings))))))
+ (progn
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
+ (setf (cdr entry) value)
+ (push (cons slot-name value) (get class-name :direct-ownings)))
+ ; -- propagate to derivatives ...
+ (labels ((clear-subclass-ownings (c)
+ (loop for sub-c in (class-direct-subclasses c)
+ for sub-c-name = (c-class-name sub-c)
+ do (setf (get sub-c-name :indirect-ownings)
+ (delete slot-name (get sub-c-name :indirect-ownings) :key 'car)) ;; forces redecide
+ (setf (get sub-c-name :model-ownings) nil) ;; too much forcing full recalc like this?
+ (clear-subclass-ownings sub-c))))
+ (clear-subclass-ownings (find-class class-name))))))
+
+(defun md-owning-slots (self &aux (st (type-of self)))
+ (or (get st :model-ownings)
+ (setf (get st :model-ownings)
+ (loop for s in (class-slots (class-of self))
+ for sn = (slot-definition-name s)
+ when (and (md-slot-cell-type st sn)
+ (md-slot-owning? st sn))
+ collect sn))))
(defun md-slot-value-store (self slot-name new-value)
(trc nil "md-slot-value-store" self slot-name new-value)
--- /project/cells/cvsroot/cells/propagate.lisp 2008/04/22 10:11:50 1.35
+++ /project/cells/cvsroot/cells/propagate.lisp 2008/04/23 03:20:09 1.36
@@ -42,6 +42,8 @@
(declare (ignorable pulse-info))
(unless *one-pulse?*
(trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info)
+ (when *c-debug*
+ (push (list :data-pulse-next pulse-info) *istack*))
(incf *data-pulse-id*)))
(defun c-currentp (c)
@@ -106,11 +108,15 @@
(when (and prior-value-supplied
prior-value
(md-slot-owning? (type-of (c-model c)) (c-slot-name c)))
- (trc nil "c.propagate> contemplating lost")
+ (trc nil "c.propagate> contemplating lost" c)
(flet ((listify (x) (if (listp x) x (list x))))
(bif (lost (set-difference (listify prior-value) (listify (c-value c))))
(progn
(trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c))
+ (loop for l in lost
+ when (numberp l)
+ do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c)
+ (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))))
(mapcar 'not-to-be lost))
(trc nil "no owned lost!!!!!"))))
More information about the Cells-cvs
mailing list