Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv10869
Modified Files: cell-types.lisp cells.lpr constructors.lisp defmodel.lisp family.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp slot-utilities.lisp Log Message:
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/11/03 13:37:10 1.22 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/11/13 05:28:08 1.23 @@ -44,8 +44,10 @@
;_____________________ print __________________________________
+#+sigh (defmethod print-object :before ((c cell) stream) - (unless (or *stop* *print-readably*) + (declare (ignorable stream)) + #+shhh (unless (or *stop* *print-readably*) (format stream "[~a~a:" (if (c-inputp c) "i" "?") (cond ((null (c-model c)) #\0) @@ -53,16 +55,19 @@ ((not (c-currentp c)) ##) (t #\space)))))
- (defmethod print-object ((c cell) stream) - (if (or *stop* *print-readably*) - (call-next-method) - (progn - (c-print-value c stream) - (format stream "=~d/~a/~a]" - (c-pulse c) - (symbol-name (or (c-slot-name c) :anoncell)) - (or (and (c-model c)(md-name (c-model c))) :anonmd))))) + (declare (ignorable stream)) + (unless *stop* + (let ((*print-circle* t)) + #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) + (if *print-readably* + (call-next-method) + (progn + (c-print-value c stream) + (format stream "=~d/~a/~a]" + (c-pulse c) + (symbol-name (or (c-slot-name c) :anoncell)) + (bwhen (md (c-model c)) (md-name md) :anonmd)))))))
(defmethod trcp :around ((c cell)) (or (c-debug c) @@ -100,13 +105,11 @@ ; ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? ; + ;;(trcx bingo-ephem c) (with-integrity (:ephemeral-reset c) (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) (md-slot-value-store (c-model c) (c-slot-name c) nil) - (setf (c-value c) nil) - #+notsureaboutthis - (loop for caller in (c-callers c) - do (calculate-and-link caller))))) + (setf (c-value c) nil))))
; -----------------------------------------------------
@@ -170,5 +173,3 @@ (defmethod c-print-value (c stream) (declare (ignore c stream)))
- - --- /project/cells/cvsroot/cells/cells.lpr 2006/11/04 20:52:01 1.23 +++ /project/cells/cvsroot/cells/cells.lpr 2006/11/13 05:28:08 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "variables.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/11/03 13:37:10 1.12 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/11/13 05:28:08 1.13 @@ -92,7 +92,7 @@ :lazy :until-asked :rule (c-lambda ,@body)))
-(export! c?dbg c_?dbg) +(export! c?dbg c_?dbg c-input-dbg)
(defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" --- /project/cells/cvsroot/cells/defmodel.lisp 2006/10/02 02:38:31 1.10 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/11/13 05:28:08 1.11 @@ -118,18 +118,18 @@ (find-class ',class))))
(defun defmd-canonicalize-slot (slotname - &key - (cell nil cell-p) + &key + (cell nil cell-p) (owning nil owning-p) (type nil type-p) - (initform nil initform-p) - (initarg (intern (symbol-name slotname) :keyword)) - (documentation nil documentation-p) - (unchanged-if nil unchanged-if-p) - (reader slotname reader-p) - (writer `(setf ,slotname) writer-p) - (accessor slotname accessor-p) - (allocation nil allocation-p)) + (initform nil initform-p) + (initarg (intern (symbol-name slotname) :keyword)) + (documentation nil documentation-p) + (unchanged-if nil unchanged-if-p) + (reader slotname reader-p) + (writer `(setf ,slotname) writer-p) + (accessor slotname accessor-p) + (allocation nil allocation-p)) (list* slotname :initarg initarg (append (when cell-p (list :cell cell)) --- /project/cells/cvsroot/cells/family.lisp 2006/11/04 20:52:01 1.16 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/13 05:28:08 1.17 @@ -41,6 +41,17 @@
(define-symbol-macro .parent (fm-parent self))
+(defmethod md-name (other) + (trc "yep other md-name" other (type-of other)) + other) + +(defmethod md-name ((nada null)) + (unless (c-stopped) + (c-stop :md-name-on-null) + (break "md-name called on nil"))) + +(defmethod md-name ((sym symbol)) sym) + (defmethod shared-initialize :around ((self model) slotnames &rest initargs &key fm-parent) (declare (ignorable initargs slotnames fm-parent))
@@ -189,12 +200,5 @@ (declare (ignorable self)) (list ,@slot-defs)))
-(defmethod md-name (other) - (trc "yep other md-name" other (type-of other)) - other)
-(defmethod md-name ((nada null)) - (unless (c-stopped) - (c-stop :md-name-on-null) - (break "md-name called on nil")))
--- /project/cells/cvsroot/cells/integrity.lisp 2006/11/04 20:52:01 1.15 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/11/13 05:28:08 1.16 @@ -24,24 +24,22 @@ :ephemeral-reset :change))
-(defmacro with-integrity ((&optional opcode defer-info) &rest body) +(defmacro with-integrity ((&optional opcode defer-info debug) &rest body) (when opcode (assert (find opcode *ufb-opcodes*) () "Invalid second value to with-integrity: ~a" opcode)) - `(call-with-integrity ,opcode ,defer-info (lambda () ,@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)))
-(export! with-c-change with-c-changes) +(export! with-cc)
-(defmacro with-c-change (id &body body) +(defmacro with-cc (id &body body) `(with-integrity (:change ,id) ,@body))
-(defmacro with-c-changes (id &rest change-forms) - `(with-c-change ,id - ,(car change-forms) - ,(when (cdr change-forms) - `(with-c-changes ,id ,@(cdr change-forms))))) - (defun integrity-managed-p () *within-integrity*)
@@ -51,7 +49,7 @@ (if *within-integrity* (if opcode (ufb-add opcode (cons defer-info action)) - (funcall action)) + (funcall action opcode defer-info)) (let ((*within-integrity* t) *unfinished-business* *defer-changes*) @@ -62,7 +60,7 @@ (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 - (funcall action) + (funcall action opcode defer-info) (finish-business)))))
(defun ufb-queue (opcode) @@ -87,10 +85,10 @@ (ufb-queue op-or-q) op-or-q))) (trc nil "just do it doing" op-or-q) - (loop for (nil . task) = (fifo-pop q) + (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) - (funcall task))) + (funcall task op-or-q defer-info)))
(defun finish-business () (when *stop* (return-from finish-business)) @@ -169,7 +167,7 @@ (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) - (funcall task-fn) + (funcall task-fn :change defer-info) ; ; to finish this state change we could recursively call (finish-business), but ; a goto let's us not use the stack. Someday I envision code that keeps on --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/03 13:37:10 1.31 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/13 05:28:08 1.32 @@ -40,12 +40,16 @@
;; (count-it :md-slot-value slot-name) (if c - (prog1 - (with-integrity () - (ensure-value-is-current c :mdsv nil)) - (when (car *call-stack*) - (record-caller c))) + (cell-read c) (values (bd-slot-value self slot-name) nil))) + +(defun cell-read (c) + (assert (typep c 'cell)) + (prog1 + (with-integrity () + (ensure-value-is-current c :c-read nil)) + (when (car *call-stack*) + (record-caller c))))
(defun chk (s &optional (key 'anon)) (when (eq :eternal-rest (md-state s)) @@ -56,12 +60,12 @@ (count-it :ensure-value-is-current) (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller)
- (when (eq :eternal-rest (md-state (c-model c))) + (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c))
(cond ((c-currentp c) - (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete + (trc c "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete ;; ((and (c-inputp c) @@ -112,11 +116,11 @@ (trc "calculating cell ~a appears in call stack: ~a" c x stack ))) (setf *stop* t) (c-break "yep" c) - #+not (loop with caller-reiterated - for caller in *call-stack* - until caller-reiterated - do (trc "caller:" caller) - (pprint (cr-code c)) + (loop with caller-reiterated + for caller in *call-stack* + until caller-reiterated + do (trc "caller:" caller) + ;; not necessary (pprint (cr-code c)) (setf caller-reiterated (eq caller c))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) @@ -138,6 +142,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) + (trc nil "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) --- /project/cells/cvsroot/cells/model-object.lisp 2006/10/17 21:28:39 1.13 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/11/13 05:28:08 1.14 @@ -31,6 +31,8 @@ :documentation "cells supplied but un-whenned or optimized-away") (adopt-ct :initform 0 :accessor adopt-ct)))
+(defmethod md-state ((self symbol)) + :alive) ;;; --- md obj initialization ------------------
(defmethod shared-initialize :after ((self model-object) slotnames @@ -67,31 +69,34 @@ (md-awaken self))) ))
- - -(defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell))) +(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell))) ; ; iff cell, init and move into dictionary ; (when c-isa-cell (count-it :md-install-cell) - (setf (c-model c) self - (c-slot-name c) sn - (md-slot-cell self sn) c)) + (c-slot-name c) slot-name + (md-slot-cell self slot-name) c)) ; ; now have the slot really be the slot ; (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))) - (setf (slot-value self sn) c))) ;; (in which case "c" is not actually a cell) - + (bd-slot-makunbound self slot-name) + (if self + (setf (slot-value self slot-name) + (when (c-inputp c) (c-value c))) + (setf (symbol-value slot-name) + (when (c-inputp c) (c-value c))))) + ;; note that in this else branch "c" is a misnomer since + ;; the value is not actually a cell + (if self + (setf (slot-value self slot-name) c) + (setf (symbol-value slot-name) c)))) + + ;;; --- awaken -------- ; ; -- do initial evaluation of all ruled slots @@ -163,44 +168,61 @@ (slot-value self slot))
(defmethod md-slot-cell (self slot-name) - (cdr (assoc slot-name (cells self)))) + (if self + (cdr (assoc slot-name (cells self))) + (get slot-name 'cell)))
(defun md-slot-cell-type (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :cell-types))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name)) - (setf (md-slot-cell-type class-name slot-name) nil)) - (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) - (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :cell-type) + (bif (entry (assoc slot-name (get class-name :cell-types))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name)) + (setf (md-slot-cell-type class-name slot-name) nil)) + (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) + (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
(defun (setf md-slot-cell-type) (new-type class-name slot-name) - (let ((entry (assoc slot-name (get class-name :cell-types)))) - (if entry - (progn - (setf (cdr entry) new-type) - (loop for c in (class-direct-subclasses (find-class class-name)) + (assert class-name) + (if (eq class-name 'null) ;; not def-c-variable + (setf (get slot-name :cell-type) new-type) + (let ((entry (assoc slot-name (get class-name :cell-types)))) + (if entry + (progn + (setf (cdr entry) new-type) + (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) - (push (cons slot-name new-type) (get class-name :cell-types))))) + (push (cons slot-name new-type) (get class-name :cell-types))))))
(defun md-slot-owning (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :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))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :owning) + (bif (entry (assoc slot-name (get class-name :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))))))))
(defun (setf md-slot-owning) (value class-name slot-name) - (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)) + (assert class-name) + (if (eq class-name 'null) + (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))))) + (push (cons slot-name value) (get class-name :ownings))))))
-(defmethod md-slot-value-store ((self model-object) slot-name new-value) - (trc nil "md-slot-value-store" slot-name new-value) - (setf (slot-value self slot-name) new-value)) +(defun md-slot-value-store (self slot-name new-value) + (trc nil "md-slot-value-store" self slot-name new-value) + (if self + (setf (slot-value self slot-name) new-value) + (setf (symbol-value slot-name) new-value)))
(defun md-slot-cell-flushed (self slot-name) (cdr (assoc slot-name (cells-flushed self)))) @@ -220,17 +242,19 @@ (defmethod cell-when (other) (declare (ignorable other)) nil)
(defun (setf md-slot-cell) (new-cell self slot-name) - (bif (entry (assoc slot-name (cells self))) - (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter - (declare (ignorable old)) - (c-assert (null (c-callers old))) - (c-assert (null (cd-useds old))) - (trc nil "replacing in model .cells" old new-cell self) - (rplacd entry new-cell)) - (progn - (trc nil "adding to model .cells" new-cell self) - (push (cons slot-name new-cell) - (cells self))))) + (if self ;; not on def-c-variables + (bif (entry (assoc slot-name (cells self))) + (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (declare (ignorable old)) + (c-assert (null (c-callers old))) + (c-assert (null (cd-useds old))) + (trc nil "replacing in model .cells" old new-cell self) + (rplacd entry new-cell)) + (progn + (trc nil "adding to model .cells" new-cell self) + (push (cons slot-name new-cell) + (cells self)))) + (setf (get slot-name 'cell) new-cell)))
(defun md-map-cells (self type celldo) (map type (lambda (cell-entry) --- /project/cells/cvsroot/cells/propagate.lisp 2006/11/03 13:37:10 1.25 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/11/13 05:28:08 1.26 @@ -73,7 +73,7 @@ (when *stop* (princ #.)(princ #!) (return-from c-propagate)) - (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) --- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/05/20 06:32:19 1.3 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2006/11/13 05:28:08 1.4 @@ -84,7 +84,9 @@ (slot-boundp self slot-name))
(defun bd-slot-makunbound (self slot-name) - (slot-makunbound self slot-name)) + (if slot-name ;; not in def-c-variable + (slot-makunbound self slot-name) + (makunbound self)))
#| sample incf (defmethod c-value-incf ((base fpoint) delta)