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 (,@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 ,@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)