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! ,@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)) - ,@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)) + ,@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!!!!!"))))