[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Mon Nov 13 05:28:08 UTC 2006
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 , at 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 , at 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 () , 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)))
-(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)
, at 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)
More information about the Cells-cvs
mailing list