cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells
by ktilton 21 Aug '06

21 Aug '06

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)

1 0

[cells-cvs] CVS Celtk
by ktilton 25 Jul '06

25 Jul '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6393 Modified Files: togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/togl.lisp 2006/07/24 05:04:01 1.15 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/07/25 10:53:41 1.16 @@ -183,8 +183,8 @@ (def-togl-callback create () (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) -;;; (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready -;;; togl-ptr)) + (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + togl-ptr)) (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 25 Jul '06

25 Jul '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv6247/utils-kt Modified Files: debug.lisp utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/05/20 06:32:20 1.8 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/07/25 10:51:48 1.9 @@ -96,6 +96,8 @@ (format t "decrementing trc depth ~d" *trcdepth*) (decf *trcdepth*)) +(export! wtrc) + (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) `(let ((*trcdepth* (if *trcdepth* (1+ *trcdepth*) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/07/24 05:03:08 1.14 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/07/25 10:51:48 1.15 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 12, 2006 12:22)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells
by ktilton 25 Jul '06

25 Jul '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv6247 Modified Files: cell-types.lisp cells.lisp cells.lpr md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2006/07/24 05:03:07 1.16 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/07/25 10:51:48 1.17 @@ -45,9 +45,10 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) -;;;(defmethod trcp ((c cell)) -;;; (and ;; (typep (c-model c) 'index) -;;; (find (c-slot-name c) '(celtk::state mathx::problem)))) +(defmethod trcp ((c cell)) + #+not (and ;; (typep (c-model c) 'index) + (find (c-slot-name c) '(celtk::state mathx::problem)))) + ; --- ephemerality -------------------------------------------------- ; @@ -131,7 +132,7 @@ ;_____________________ print __________________________________ (defmethod print-object :before ((c cell) stream) - (unless *print-readably* + (unless (or *stop* *print-readably*) (format stream "[~a~a:" (if (c-inputp c) "i" "?") (cond ((null (c-model c)) #\0) @@ -139,8 +140,9 @@ ((not (c-currentp c)) #\#) (t #\space))))) + (defmethod print-object ((c cell) stream) - (if *print-readably* + (if (or *stop* *print-readably*) (call-next-method) (progn (c-print-value c stream) @@ -149,6 +151,7 @@ (symbol-name (or (c-slot-name c) :anoncell)) (or (c-model c) :anonmd))))) + ;__________________ (defmethod c-print-value ((c c-ruled) stream) --- /project/cells/cvsroot/cells/cells.lisp 2006/06/25 21:30:34 1.14 +++ /project/cells/cvsroot/cells/cells.lisp 2006/07/25 10:51:48 1.15 @@ -45,8 +45,8 @@ (trc nil "------ cell reset ----------------------------")) (defun c-stop (&optional why) - (format t "~&C-STOP> stopping because ~a" why) - (setf *stop* t)) + (setf *stop* t) + (format t "~&C-STOP> stopping because ~a" why) ) (define-symbol-macro .stop (c-stop :user)) @@ -132,9 +132,12 @@ (defun c-break (&rest args) (unless *stop* - (c-stop args) - (format t "c-break > stopping > ~a" args) - (apply 'break args))) + (LET ((*print-level* 3) + (*print-circle* t) + ) + (c-stop args) + (format t "c-break > stopping > ~a" args) + (apply 'break args)))) --- /project/cells/cvsroot/cells/cells.lpr 2006/07/24 05:03:08 1.18 +++ /project/cells/cvsroot/cells/cells.lpr 2006/07/25 10:51:48 1.19 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/07/24 05:03:08 1.25 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/07/25 10:51:48 1.26 @@ -18,7 +18,7 @@ (in-package :cells) -(defparameter *ide-app-hard-to-kill* nil) +(defparameter *ide-app-hard-to-kill* t) (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) (tagbody @@ -83,15 +83,18 @@ (return-from calculate-and-set)) (when (find c *call-stack*) ;; circularity - (trc "cell appears in call stack:" c) - (loop with caller-reiterated + (trc "cell appears in call stack:" *stop*) + (setf *stop* t) + (break) + #+not (loop with caller-reiterated for caller in *call-stack* until caller-reiterated do (trc "caller:" caller) (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)) + "cell ~a midst askers (see above)" c) + (break)) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c)

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 25 Jul '06

25 Jul '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv6247/gui-geometry Modified Files: geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/07/06 22:10:02 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/07/25 10:51:48 1.7 @@ -44,7 +44,7 @@ (mk-kid-slot (px :if-missing t) (c? (px-maintain-pl 0))) (mk-kid-slot (py :if-missing t) - (c? (break)(py-maintain-pt 0)))))) + (c? (py-maintain-pt 0)))))) (defmodel geo-kid-sized (family) ()

1 0

[cells-cvs] CVS Celtk
by ktilton 24 Jul '06

24 Jul '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv25756 Modified Files: CELTK.lpr timer.lisp togl.lisp Log Message: Not really changed for the most part. --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/29 09:54:52 1.17 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/07/24 05:04:01 1.18 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/07/06 22:10:40 1.9 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/07/24 05:04:01 1.10 @@ -79,8 +79,8 @@ (funcall (^action) self) (setf (^executed) t)))) (after-factory :reader after-factory - :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on) - (^repeat)))) + :initform (c? (bwhen (rpt (when (eq (^state) :on) + (^repeat))) (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution (when (zerop (^executions)) (setf (elapsed self) (now))) @@ -90,19 +90,23 @@ (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters (set-timer self (^delay)))))))))) +(defobserver state ((self timer)) + (unless (eq new-value :on) + (trc "bingo!!!!!!!!!!!!!!!!!!!!! state takes out timer" self) + (cancel-timer self))) + (defun set-timer (self time) (let ((callback-id (symbol-name (gentemp "AFTER")))) (setf (gethash callback-id (dictionary *tkw*)) self) (setf (cancel-id self) (tk-eval "after ~a {do-on-command ~a}" time callback-id)))) (defun cancel-timer (timer) - (setf (state timer) :off) (when (cancel-id timer) - (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed + (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed (defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) - (cancel-timer k))) + (setf (state k) :off))) ;; actually could be anything but :on \ No newline at end of file --- /project/cells/cvsroot/Celtk/togl.lisp 2006/07/06 22:10:40 1.14 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/07/24 05:04:01 1.15 @@ -167,11 +167,14 @@ (callback :pointer)) (defcallback ,(intern cb$) :void ((,ptr-var :pointer)) (unless (c-stopped) - (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*)) - (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))) - ,@preamble - (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*))) - (,(intern uc$) ,self-var)))) + (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*)) + (gethash (togl-ident ,ptr-var)(dictionary *tkw*)))) + (progn + ,@preamble + (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*))) + (,(intern uc$) ,self-var)) + (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a" + ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var))))) (defmethod ,(intern uc$) :around ((self togl)) (if (,(intern cb-slot$) self) (funcall (,(intern cb-slot$) self) self)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 24 Jul '06

24 Jul '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv25652/utils-kt Modified Files: utils-kt.lpr Log Message: Looks like copying files back and forth has fooled CVS into thinking everything changed. <sigh> --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/06/29 09:54:06 1.13 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/07/24 05:03:08 1.14 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jul 12, 2006 12:22)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells
by ktilton 24 Jul '06

24 Jul '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv25652 Modified Files: cell-types.lisp cells.lpr integrity.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp Log Message: Looks like copying files back and forth has fooled CVS into thinking everything changed. <sigh> --- /project/cells/cvsroot/cells/cell-types.lisp 2006/06/29 09:54:06 1.15 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/07/24 05:03:07 1.16 @@ -45,9 +45,9 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) -(defmethod trcp ((c cell)) - nil #+(or) (and (typep (c-model c) 'index) - (eql 'state (c-slot-name c)))) +;;;(defmethod trcp ((c cell)) +;;; (and ;; (typep (c-model c) 'index) +;;; (find (c-slot-name c) '(celtk::state mathx::problem)))) ; --- ephemerality -------------------------------------------------- ; @@ -131,20 +131,23 @@ ;_____________________ print __________________________________ (defmethod print-object :before ((c cell) stream) - (declare (ignorable c)) - (format stream "[~a~a:" (if (c-inputp c) "i" "?") - (cond - ((null (c-model c)) #\0) - ((eq :eternal-rest (md-state (c-model c))) #\_) - ((not (c-currentp c)) #\#) - (t #\space)))) + (unless *print-readably* + (format stream "[~a~a:" (if (c-inputp c) "i" "?") + (cond + ((null (c-model c)) #\0) + ((eq :eternal-rest (md-state (c-model c))) #\_) + ((not (c-currentp c)) #\#) + (t #\space))))) (defmethod print-object ((c cell) stream) - (c-print-value c stream) - (format stream "=~d/~a/~a]" - (c-pulse c) - (symbol-name (or (c-slot-name c) :anoncell)) - (or (c-model c) :anonmd))) + (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)) + (or (c-model c) :anonmd))))) ;__________________ --- /project/cells/cvsroot/cells/cells.lpr 2006/06/29 09:54:06 1.17 +++ /project/cells/cvsroot/cells/cells.lpr 2006/07/24 05:03:08 1.18 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/integrity.lisp 2006/07/06 22:10:01 1.11 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/07/24 05:03:08 1.12 @@ -53,18 +53,21 @@ (funcall action) (finish-business))))) -(defmacro without-integrity ((&optional dbg-info) &rest body) +(export! with-integrity-bubble) + +(defmacro with-integrity-bubble ((&optional dbg-info) &rest body) "Whimsical name for launching a self-contained, dynamic integrity chunk, as with string-to-mx in the math-paper project, where everything is fully isolated from the outside computation." - `(call-without-integrity ,dbg-info (lambda () ,@body))) + `(call-with-integrity-bubble ,dbg-info (lambda () ,@body))) -(defun call-without-integrity (dbg-info action) +(defun call-with-integrity-bubble (dbg-info action) (declare (ignorable dbg-info)) (let ((*within-integrity* nil) *unfinished-business* *defer-changes* - *call-stack*) + *call-stack* + (*data-pulse-id* 0)) (funcall action))) (defun ufb-queue (opcode) --- /project/cells/cvsroot/cells/link.lisp 2006/07/06 22:10:01 1.15 +++ /project/cells/cvsroot/cells/link.lisp 2006/07/24 05:03:08 1.16 @@ -95,7 +95,7 @@ (defmethod c-unlink-from-used ((caller c-dependent)) (dolist (used (cd-useds caller)) - #+dfdbg (trc caller "unlinking from used" caller used) + #+dfdbg (trc nil "unlinking from used" caller used) (c-unlink-caller used caller)) ;; shouldn't be necessary (setf (cd-useds caller) nil) ) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/29 09:54:06 1.24 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/07/24 05:03:08 1.25 @@ -42,14 +42,15 @@ (if c (prog1 (with-integrity () - (ensure-value-is-current c)) + (ensure-value-is-current c :mdsv nil)) (when (car *call-stack*) (record-caller c))) (values (bd-slot-value self slot-name) nil))) -(defun ensure-value-is-current (c) +(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 >" c) + (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller) (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 @@ -58,16 +59,17 @@ ((or (not (c-validp c)) (some (lambda (used) - (ensure-value-is-current used) - (trc nil "comparing pulses (caller, used): " (c-pulse c)(c-pulse used)) + (ensure-value-is-current used :nested c) + (trc nil "comparing pulses (caller, used, used-changed): " c used (c-changed used)) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) - (trc nil "used changed" c used) + (trc nil "used changed and newer !!!!!!" c used) t)) (cd-useds c))) - (trc nil "ensuring current calc-set of" (c-slot-name c) debug-id) + (trc nil "ensuring current calc-set of" (c-slot-name c)) (calculate-and-set c)) - (t (c-pulse-update c :valid-uninfluenced))) + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) ) + (c-pulse-update c :valid-uninfluenced))) (when (c-unboundp c) (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) @@ -143,6 +145,7 @@ ; ; --- data flow propagation ----------- ; + (setf (c-changed c) t) (without-c-dependency (c-propagate c prior-value t))))))) @@ -207,6 +210,7 @@ ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) + (trc nil "md-slot-value-assume flagging as changed" c) (setf (c-changed c) t) (c-propagate c prior-value (eq prior-state :valid))) ;; until 06-02-13 was (not (eq prior-state :unbound)) --- /project/cells/cvsroot/cells/propagate.lisp 2006/06/23 01:04:56 1.18 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/07/24 05:03:08 1.19 @@ -46,7 +46,7 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating" *data-pulse-id* c key) + (trc nil "c-pulse-update updating as unchanged!!!" *data-pulse-id* c key) (setf (c-changed c) nil (c-pulse c) *data-pulse-id*)) @@ -165,11 +165,11 @@ (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc nil "c-propagate-to-callers > notifying callers of" c (mapcar 'c-slot-name (c-callers c))) + (trc nil "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) (dolist (caller (c-callers c)) (unless (member (cr-lazy caller) '(t :always :once-asked)) - (trc nil "propagating to caller is (used,caller):" c caller) - (ensure-value-is-current caller)))))))) + (trc nil "propagating to caller is caller:" caller) + (ensure-value-is-current caller :prop-from c)))))))) --- /project/cells/cvsroot/cells/synapse.lisp 2006/07/06 22:10:01 1.13 +++ /project/cells/cvsroot/cells/synapse.lisp 2006/07/24 05:03:08 1.14 @@ -39,7 +39,7 @@ (prog1 (multiple-value-bind (v p) (with-integrity () - (ensure-value-is-current synapse)) + (ensure-value-is-current synapse :synapse (car *call-stack*))) (trc nil "with-synapse: synapse, v, prop" synapse v p) (values v p)) (record-caller synapse)))))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 08 Jul '06

08 Jul '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv5356/utils-kt Modified Files: detritus.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/07/06 22:10:03 1.7 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/07/08 03:28:07 1.8 @@ -20,7 +20,7 @@ (in-package :utils-kt) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(eval-now!))) + (export '(eval-now! export!))) (defmacro wdbg (&body body) `(let ((*dbg* t))

1 0

[cells-cvs] CVS Celtk
by ktilton 06 Jul '06

06 Jul '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv10563 Modified Files: Celtk.asd Celtk.lisp composites.lisp font.lisp run.lisp timer.lisp tk-object.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/06/07 22:13:41 1.10 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/07/06 22:10:39 1.11 @@ -12,7 +12,7 @@ :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" - :depends-on (:cells :cffi :gui-geometry) + :depends-on (:cells :cffi :gui-geometry :cl-ftgl) :serial t :components ((:file "Celtk") (:file "tk-structs") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/07/03 00:32:52 1.33 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/07/06 22:10:39 1.34 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.33 2006/07/03 00:32:52 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.34 2006/07/06 22:10:39 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -68,7 +68,7 @@ ; --- tk-format --- talking to wish/Tk ----------------------------------------------------- -(defconstant +tk-client-task-priority+ +(defparameter +tk-client-task-priority+ '(:delete :forget :destroy :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk :variable :bind :selection :trace :configure :grid :pack :fini)) @@ -249,4 +249,4 @@ else do (push ch item) finally (gather-item) (return (nreverse items)))))) - \ No newline at end of file + --- /project/cells/cvsroot/Celtk/composites.lisp 2006/07/03 00:32:52 1.12 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/07/06 22:10:40 1.13 @@ -69,7 +69,7 @@ (defmodel composite-widget (widget) ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil))) -(eval-when (compile load eval) +(eval-now! (export '(title$ active .time))) (defvar *app*) --- /project/cells/cvsroot/Celtk/font.lisp 2006/06/07 22:13:41 1.5 +++ /project/cells/cvsroot/Celtk/font.lisp 2006/07/06 22:10:40 1.6 @@ -20,7 +20,7 @@ ;;; --- fonts obtained from Tk-land --------------- -(eval-when (compile load eval) +(eval-now! (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent tkfinfo-linespace tkfinfo-fixed tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent tkfinfo-descent ^tkfont-descent ^tkfont-find @@ -31,7 +31,7 @@ `(progn ,@(loop for fn-name in fn-names collecting (let ((^name (format nil "^~:@(~a~)" fn-name))) `(progn - (eval-when (compile load eval) + (eval-now! (export '(,(intern ^name)))) (defmacro ,(intern ^name) () `(,',fn-name self))))))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/07/03 00:32:52 1.18 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/07/06 22:10:40 1.19 @@ -20,7 +20,7 @@ ;;; --- running a Celtk (window class, actually) -------------------------------------- -(eval-when (compile load eval) +(eval-now! (export '(tk-scaling run-window test-window))) (defun run-window (root-class &optional (resetp t) &rest window-initargs) @@ -149,12 +149,9 @@ "nails existing window as a convenience in iterative development" (declare (ignorable root-class)) - #+tki (when (and *tkw* (open-stream-p *tkw*)) - (format *tkw* "wm withdraw .~%") - (force-output *tkw*) - (format *tkw* "destroy .%") - (force-output *tkw*) - (setf *tkw* nil)) + #+notquite (when (and *tkw* (fm-parent *tkw*)) ;; probably a better way to test if the window is still alive + (not-to-be (fm-parent *tkw*)) + (setf *tkw* nil ctk::*app* nil)) (apply 'run-window root-class resetp window-initargs)) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/25 07:12:59 1.8 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/07/06 22:10:40 1.9 @@ -44,7 +44,7 @@ ;;; Timer is totally a work-in-progress with much development ahead. ;;; -(eval-when (compile load eval) +(eval-now! (export '(repeat ^repeat))) (defmodel timer () --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/29 09:54:52 1.7 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/07/06 22:10:40 1.8 @@ -59,7 +59,7 @@ collecting `(setf (get ',slot-name 'tk-config-option) ',tk-option) into outputs finally (return (values slot-defs outputs))) - `(eval-when (compile load eval) + `(eval-now! (defmodel ,class ,(or superclasses '(tk-object)) (,@(append std-slots slots)) ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) @@ -84,7 +84,7 @@ collecting (list slot-name (if (atom tk-option-def) tk-option-def (cadr tk-option-def))))) -(eval-when (compile load eval) +(eval-now! (defun de- (sym) (remove #\- (symbol-name sym) :end 1))) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/07/03 01:31:38 1.13 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/07/06 22:10:40 1.14 @@ -71,7 +71,7 @@ ;; Togl_FreeColorOverlay ;; Togl_DumpToEpsFile -(eval-when (compile load eval) +(eval-now! (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class togl-display-using-class togl-width togl-height togl-create-using-class))) @@ -179,9 +179,11 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) - (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - togl-ptr)) + (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) +;;; (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready +;;; togl-ptr)) + + (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) (def-togl-callback display ()) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/06/29 09:54:52 1.15 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/07/06 22:10:40 1.16 @@ -71,7 +71,7 @@ :event-handler nil #+debug (lambda (self xe) (TRC "debug event handler" self (tk-event-type (xsv type xe)))))) -(eval-when (compile load eval) +(eval-now! (export '())) (defun tk-create-event-handler-ex (widget callback-name &rest masks) @@ -153,7 +153,7 @@ ;;; --- items ----------------------------------------------------------------------- -(eval-when (compile load eval) +(eval-now! (export '(canvas-offset ^canvas-offset coords-tweak ^coords-tweak caret-tweak ^caret-tweak decorations ^decorations)))

1 0

← Newer
1
...
27
28
29
30
31
32
33
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs