[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Mon Aug 21 04:29:30 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv8238
Modified Files:
cells.lisp cells.lpr defmodel.lisp family.lisp
fm-utilities.lisp link.lisp md-slot-value.lisp
md-utilities.lisp
Log Message:
CVS sucks
--- /project/cells/cvsroot/cells/cells.lisp 2006/07/25 10:51:48 1.15
+++ /project/cells/cvsroot/cells/cells.lisp 2006/08/21 04:29:30 1.16
@@ -32,6 +32,7 @@
(defparameter *within-integrity* nil)
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
+
(defun cells-reset (&optional client-queue-handler)
(utils-kt-reset)
(setf
@@ -41,7 +42,8 @@
*defer-changes* nil ;; should not be necessary, but cannot be wrong
*client-queue-handler* client-queue-handler
*within-integrity* nil
- *unfinished-business* nil)
+ *unfinished-business* nil
+ *trcdepth* 0)
(trc nil "------ cell reset ----------------------------"))
(defun c-stop (&optional why)
@@ -132,7 +134,7 @@
(defun c-break (&rest args)
(unless *stop*
- (LET ((*print-level* 3)
+ (let ((*print-level* 3)
(*print-circle* t)
)
(c-stop args)
--- /project/cells/cvsroot/cells/cells.lpr 2006/07/25 10:51:48 1.19
+++ /project/cells/cvsroot/cells/cells.lpr 2006/08/21 04:29:30 1.20
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -6,6 +6,7 @@
(define-project :name :cells
:modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "trc-eko.lisp")
(make-instance 'module :name "cells.lisp")
(make-instance 'module :name "integrity.lisp")
(make-instance 'module :name "cell-types.lisp")
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/07/03 00:08:29 1.7
+++ /project/cells/cvsroot/cells/defmodel.lisp 2006/08/21 04:29:30 1.8
@@ -147,7 +147,7 @@
(when documentation-p (list :documentation documentation)))))
(defmacro defmd (class superclasses &rest mdspec)
- `(defmodel ,class ,superclasses
+ `(defmodel ,class (, at superclasses model)
,@(let (definitargs class-options slots)
(loop with skip
for (spec next) on mdspec
--- /project/cells/cvsroot/cells/family.lisp 2006/07/06 22:10:01 1.10
+++ /project/cells/cvsroot/cells/family.lisp 2006/08/21 04:29:30 1.11
@@ -183,8 +183,9 @@
(declare (ignorable self))
(list , at slot-defs)))
-(defmethod md-name (symbol)
- symbol)
+(defmethod md-name (other)
+ (trc "yep other md-name" other (type-of other))
+ other)
(defmethod md-name ((nada null))
(unless (c-stopped)
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/20 06:32:19 1.7
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/21 04:29:30 1.8
@@ -195,6 +195,15 @@
;; eventually fm-find-all needs a better name (as does fm-collect) and they
;; should be modified to go through 'gather', which should be the real fm-find-all
;;
+
+(export! fm-do-up)
+
+(defun fm-do-up (self &optional (fn 'identity))
+ (when self
+ (funcall fn self)
+ (if .parent (fm-do-up .parent fn) self))
+ (values))
+
(defun fm-gather (family &key (test #'true-that))
(packed-flat!
(cons (when (funcall test family) family)
@@ -256,10 +265,11 @@
(when (funcall test-fn family)
family))))
-(defun fm-prior-sib (self &optional (test-fn #'true-that)
- &aux (kids (kids (fm-parent self))))
+(defun fm-prior-sib (self &optional (test-fn #'true-that))
"Find nearest preceding sibling passing TEST-FN"
- (find-if test-fn kids :end (position self kids) :from-end t))
+ (chk self 'psib)
+ (let ((kids (kids (fm-parent self))))
+ (find-if test-fn kids :end (position self kids) :from-end t)))
(defun fm-next-sib-if (self test-fn)
(some test-fn (cdr (member self (kids (fm-parent self))))))
--- /project/cells/cvsroot/cells/link.lisp 2006/07/24 05:03:08 1.16
+++ /project/cells/cvsroot/cells/link.lisp 2006/08/21 04:29:30 1.17
@@ -56,12 +56,17 @@
;--- unlink unused --------------------------------
-(defun c-unlink-unused (c &aux (usage (cd-usage c)))
+(defun c-unlink-unused (c &aux (usage (cd-usage c))
+ (usage-size (array-dimension (cd-usage c) 0))
+ (dbg nil #+not (and (typep (c-model c) 'mathx::mx-solver-stack)
+ (eq (c-slot-name c) '.kids))))
+ (declare (ignorable usage-size))
(when (cd-useds c)
(let (rev-pos)
(labels ((nail-unused (useds)
(flet ((handle-used (rpos)
- (if (zerop (sbit usage rpos))
+ (if (or (>= rpos usage-size)
+ (zerop (sbit usage rpos)))
(progn
(count-it :unlink-unused)
(c-unlink-caller (car useds) c)
@@ -75,6 +80,7 @@
(nail-unused (cdr useds))
(handle-used (incf rev-pos)))
(handle-used (setf rev-pos 0))))))
+ (trc dbg "cd-useds length" (length (cd-useds c)) c)
(nail-unused (cd-useds c))
(setf (cd-useds c) (delete nil (cd-useds c)))))))
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/07/25 10:51:48 1.26
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/08/21 04:29:30 1.27
@@ -47,10 +47,16 @@
(record-caller c)))
(values (bd-slot-value self slot-name) nil)))
+(defun chk (s &optional (key 'anon))
+ (when (eq :eternal-rest (md-state s))
+ (break "model ~a is dead at ~a" s key)))
+
(defun ensure-value-is-current (c debug-id caller)
(declare (ignorable debug-id caller))
(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)))
+ (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
;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
@@ -82,10 +88,12 @@
(princ #\.)
(return-from calculate-and-set))
- (when (find c *call-stack*) ;; circularity
- (trc "cell appears in call stack:" *stop*)
+ (bwhen (x (find c *call-stack*)) ;; circularity
+ (unless nil ;; *stop*
+ (let ((stack (copy-list *call-stack*)))
+ (trc "calculating cell ~a appears in call stack: ~a" c x stack )))
(setf *stop* t)
- (break)
+ (c-break "yep" c)
#+not (loop with caller-reiterated
for caller in *call-stack*
until caller-reiterated
@@ -105,7 +113,7 @@
(md-slot-value-assume c raw-value propagation-code))))
(if nil ;; *dbg*
- (ukt::wtrc (0 100 "calcnset" c) (body))
+ (wtrc (0 100 "calcnset" c) (body))
(body))))
(defun calculate-and-link (c)
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/06/23 01:04:56 1.6
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/08/21 04:29:30 1.7
@@ -30,7 +30,7 @@
;___________________ birth / death__________________________________
(defmethod not-to-be :around (self)
- (trc nil "not-to-be clearing 1 fm-parent, eternal-rest" self)
+ (trc nil "not-to-be nailing" self)
(c-assert (not (eq (md-state self) :eternal-rest)))
(call-next-method)
More information about the Cells-cvs
mailing list