@@ -60,7 +60,13 @@ See the Lisp Lesser GNU Public License for more details. (defmethod print-object ((c cell) stream) (declare (ignorable stream)) - (unless *stop* + (if *stop* + (format stream "<~d:~a ~a/~a = ~a>" + (c-pulse c) + (subseq (string (c-state c)) 0 1) + (symbol-name (or (c-slot-name c) :anoncell)) + (md-name (c-model c)) + (type-of (c-value c))) (let ((*print-circle* t)) #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) (if *print-readably* @@ -72,7 +78,8 @@ See the Lisp Lesser GNU Public License for more details. (subseq (string (c-state c)) 0 1) (symbol-name (or (c-slot-name c) :anoncell)) (print-cell-model (c-model c)) - (c-value c))))))) + (if (consp (c-value c)) + "LST" (c-value c)))))))) (export! print-cell-model) @@ -80,8 +87,9 @@ See the Lisp Lesser GNU Public License for more details. (:method (other) (print-object other nil))) (defmethod trcp :around ((c cell)) - (or (c-debug c) - (call-next-method))) + (and ;*c-debug* + (or (c-debug c) + (call-next-method)))) (defun c-callers (c) "Make it easier to change implementation" @@ -107,7 +115,7 @@ See the Lisp Lesser GNU Public License for more details. ; ; as of Cells3 we defer resetting ephemerals because everything ; else gets deferred and we cannot /really/ reset it until - ; within finish-business we are sure all callers have been recalculated + ; within finish_business we are sure all callers have been recalculated ; and all outputs completed. ; ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? cell-types.lisp @@ -9,21 +9,18 @@ :long-description "Informatively-commented regression tests for Cells" :serial t :depends-on (:cells) - :components ((:module "cells-test" - :serial t - :components ((:file "test") - (:file "hello-world") - (:file "test-kid-slotting") - (:file "test-lazy") - (:file "person") - (:file "df-interference") - (:file "test-family") - (:file "output-setf") - (:file "test-cycle") - (:file "test-ephemeral") - (:file "test-synapse") - (:file "deep-cells"))))) + :components ((:file "test") + (:file "hello-world") + (:file "test-kid-slotting") + (:file "test-lazy") + (:file "person") + (:file "df-interference") + (:file "test-family") + (:file "output-setf") + (:file "test-cycle") + (:file "test-ephemeral") + (:file "test-synapse") + (:file "deep-cells"))) + -(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) - (funcall (find-symbol "TEST-CELLS" "CELLS"))) cells-test/cells-test.asd @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -16,8 +16,11 @@ (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") (make-instance 'module :name "test-synapse.lisp") - (make-instance 'module :name "deep-cells.lisp")) - :projects (list (make-instance 'project-module :name "..\\cells")) + (make-instance 'module :name "deep-cells.lisp") + (make-instance 'module :name "clos-training.lisp") + (make-instance 'module :name "do-req.lisp")) + :projects (list (make-instance 'project-module :name "..\\cells" + :show-modules nil)) :libraries nil :distributed-files nil :internally-loaded-files nil @@ -94,6 +97,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'cells::test-cells :on-restart 'do-default-restart) cells-test/cells-test.lpr @@ -4,9 +4,9 @@ (defvar *obs-1-count*) (defmodel deep () - ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor :cell-2) - (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor :cell-1) - (cell-3 :initform (c-in 'c3-unset) :accessor :cell-3))) + ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2) + (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1) + (cell-3 :initform (c-in 'c3-unset) :accessor cell-3))) (defobserver cell-1 () (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value) cells-test/deep-cells.lisp @@ -36,6 +36,16 @@ (incf *name-ct-calc*) (length (names self)))))) +#+test +(progn + (cells-reset) + (inspect + (make-instance 'person + :names '("speedy" "chill") + :pulse (c-in 60) + :speech (c? (car (names self))) + :thought (c? (when (< (pulse self) 100) (speech self)))))) + (defobserver names ((self person) new-names) (format t "~&you can call me ~a" new-names)) @@ -124,6 +134,8 @@ ;; (ct-assert (null (thought p))))) + + (def-cell-test cv-test-person-3 () ;; ------------------------------------------------------- ;; dynamic dependency graph maintenance @@ -154,6 +166,7 @@ (setf (pulse p) 50) (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))))) + (def-cell-test cv-test-person-4 () (let ((p (make-instance 'person :names '("speedy" "chill") @@ -167,8 +180,10 @@ ;; - all cells accessed are constant. ;; (ct-assert (null (md-slot-cell p 'speech))) - (ct-assert (assoc 'speech (cells-flushed p))) - (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))) + #-its-alive! + (progn + (ct-assert (assoc 'speech (cells-flushed p))) + (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p)))))) (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used @@ -195,6 +210,8 @@ ;; make sure cyclic dependencies are trapped: ;; (cells-reset) + #+its-alive! t + #-its-alive! (ct-assert (handler-case (progn @@ -205,10 +222,9 @@ (length (names self))))) nil) (t (error) - (describe error) + (describe error) (setf *stop* nil) - t))) - ) + t)))) ;; ;; we'll toss off a quick class to test tolerance of cyclic cells-test/person.lisp @@ -69,15 +69,21 @@ subclass for them?) (defun test-cells () - (loop for test in (reverse *cell-tests*) - when t ; (eq 'cv-test-person-5 test) - do (cell-test-init test) - (funcall test)) - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*)) - (print "*** Cells-test successfully completed **") - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*))) + (dribble "c:/0algebra/cells-test.txt") + (progn ;prof:with-profiling (:type :time) + (time + (progn + (loop for test in (reverse *cell-tests*) + when t ; (eq 'cv-test-person-5 test) + do (cell-test-init test) + (funcall test)) + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*)) + (print "*** Cells-test successfully completed **") + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*))))) + ;(prof:show-call-graph) + (dribble)) (defun cell-test-init (name) (print (make-string 40 :initial-element #\!)) cells-test/test.lisp @@ -33,8 +33,9 @@ (:file "family") (:file "fm-utilities") (:file "family-values") - (:file "test-propagation") - (:file "cells-store"))) + (:file "test-propagation") + (:file "cells-store") + (:file "test-cc"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) cells.asd @@ -31,17 +31,17 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be. |# - -(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) - (in-package :cells) (defparameter *c-prop-depth* 0) (defparameter *causation* nil) (defparameter *data-pulse-id* 0) +(define-symbol-macro .dpid *data-pulse-id*) +(defparameter *finbiz-id* 0) ;; debugging tool only +(define-symbol-macro .fbid *finbiz-id*) +(export! .dpid .fbid) (defparameter *c-debug* nil) (defparameter *defer-changes* nil) (defparameter *within-integrity* nil) @@ -50,6 +50,9 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be. (defparameter *unfinished-business* nil) (defparameter *not-to-be* nil) +(defparameter *awake* nil) +(defparameter *awake-ct* nil) + #+test (cells-reset) @@ -58,7 +61,11 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be. (setf *c-debug* debug *c-prop-depth* 0 + *awake-ct* nil + *awake* nil + *not-to-be* nil *data-pulse-id* 0 + *finbiz-id* 0 *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil @@ -77,7 +84,10 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be. (defun c-stopped () *stop*) -(export! .stopped) +(export! .stopped .cdbg) + +(define-symbol-macro .cdbg + *c-debug*) (define-symbol-macro .stopped (c-stopped)) cells.lisp @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -25,9 +25,11 @@ (make-instance 'module :name "fm-utilities.lisp") (make-instance 'module :name "family-values.lisp") (make-instance 'module :name "test-propagation.lisp") - (make-instance 'module :name "cells-store.lisp")) + (make-instance 'module :name "cells-store.lisp") + (make-instance 'module :name "test-cc.lisp")) :projects (list (make-instance 'project-module :name - "utils-kt\\utils-kt")) + "utils-kt\\utils-kt" :show-modules + nil)) :libraries nil :distributed-files nil :internally-loaded-files nil @@ -48,7 +50,8 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::tcprop + :build-number 0 + :on-initialization 'cells::test-with-cc :on-restart 'do-default-restart) ;; End of Project Definition cells.lpr @@ -58,28 +58,38 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c? (&body body) `(make-c-dependent - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :rule (c-lambda ,@body))) (defmacro c?+n (&body body) `(make-c-dependent :inputp t - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :rule (c-lambda ,@body))) (defmacro c?n (&body body) `(make-c-dependent - :code '(without-c-dependency ,@body) + :code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body) :inputp t :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body)))) +(export! c?n-dbg) + +(defmacro c?n-dbg (&body body) + `(make-c-dependent + :code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body) + :inputp t + :debug t + :value-state :unevaluated + :rule (c-lambda (without-c-dependency ,@body)))) + (defmacro c?n-until (args &body body) `(make-c-dependent :optimize :when-value-t - :code ',body + :code #+its-alive! nil #-its-alive! ',body :inputp t :value-state :unevaluated :rule (c-lambda ,@body) @@ -87,14 +97,14 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c?once (&body body) `(make-c-dependent - :code '(without-c-dependency ,@body) + :code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body) :inputp nil :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body)))) (defmacro c_1 (&body body) `(make-c-dependent - :code '(without-c-dependency ,@body) + :code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body) :inputp nil :lazy t :value-state :unevaluated @@ -105,14 +115,14 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c?dbg (&body body) `(make-c-dependent - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :debug t :rule (c-lambda ,@body))) (defmacro c?_ (&body body) `(make-c-dependent - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :lazy t :rule (c-lambda ,@body))) @@ -120,7 +130,7 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c_? (&body body) "Lazy until asked, then eagerly propagating" `(make-c-dependent - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :lazy :until-asked :rule (c-lambda ,@body))) @@ -128,7 +138,7 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" `(make-c-dependent - :code ',body + :code #+its-alive! nil #-its-alive! ',body :value-state :unevaluated :lazy :until-asked :rule (c-lambda ,@body) @@ -155,7 +165,7 @@ See the Lisp Lesser GNU Public License for more details. (defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms) (assert (member lazy '(nil t :once-asked :until-asked :always))) `(make-c-dependent - :code ',forms + :code #+its-alive! nil #-its-alive! ',forms :value-state :unevaluated :rule (c-lambda ,@forms) ,@keys)) @@ -173,6 +183,14 @@ See the Lisp Lesser GNU Public License for more details. :value-state :valid :value ,value)) +(export! c-in-lazy c_in) + +(defmacro c-in-lazy (&body body) + `(c-input (:lazy :once-asked) (progn ,@body))) + +(defmacro c_in (&body body) + `(c-input (:lazy :once-asked) (progn ,@body))) + (defmacro c-input-dbg (&optional (value nil valued-p)) `(make-cell :inputp t constructors.lisp @@ -21,107 +21,110 @@ See the Lisp Lesser GNU Public License for more details. ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) (assert (not (find class directsupers))() "~a cannot be its own superclass" class) `(progn - (eval-when (:compile-toplevel :execute :load-toplevel) - (setf (get ',class :cell-types) nil) - (setf (get ',class 'slots-excluded-from-persistence) - ',(loop for slotspec in slotspecs - unless (and (getf (cdr slotspec) :ps t) - (getf (cdr slotspec) :persistable t)) - collect (car slotspec)))) + (setf (get ',class :cell-types) nil) + (setf (get ',class 'slots-excluded-from-persistence) + (loop for slotspec in ',slotspecs + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec))) + (loop for slotspec in ',slotspecs + do (destructuring-bind + (slotname &rest slotargs + &key (cell t) + &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when cell + (setf (md-slot-cell-type ',class slotname) cell)))) ;; define slot macros before class so they can appear in - ;; initforms and default-initargs - ,@(delete nil - (loop for slotspec in slotspecs - nconcing (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning (accessor slotname) reader - &allow-other-keys) - slotspec - - (declare (ignorable slotargs owning)) - (list - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn)))) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self))) - #+sbcl (unless (fboundp ',reader-fn) - (defgeneric ,reader-fn (slot)))))))))) + ;; initforms and default-initargs + ,@(loop for slotspec in slotspecs + nconcing (destructuring-bind + (slotname &rest slotargs + &key (cell t) (accessor slotname) reader + &allow-other-keys) + slotspec + (declare (ignorable slotargs )) + (when cell + (list (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self))) + #+sbcl (unless (fboundp ',reader-fn) + (defgeneric ,reader-fn (slot))))))))) ; ; ------- defclass --------------- (^slot-value ,model ',',slotname) ; - - (eval-now! ;; suppress style warning in SBCL - (prog1 - (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :persistable) - (remf ias :ps) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) + (prog1 + (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class))) - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) - (declare (ignore slot-names iargs)) - ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) + (declare (ignore slot-names iargs)) + ,(when (and directsupers (not (member 'model-object directsupers))) + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning unchanged-if (accessor slotname) reader writer type - &allow-other-keys) - slotspec + + ; + ; slot accessors once class is defined... + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) unchanged-if (accessor slotname) reader writer type + &allow-other-keys) + slotspec - (declare (ignorable slotargs)) - (when cell - (let* ((reader-fn (or reader accessor)) - (writer-fn (or writer accessor)) - ) - `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning - (setf (md-slot-cell-type ',class ',slotname) ,cell) - ,(when owning - `(setf (md-slot-owning-direct? ',class ',slotname) ,owning)) - ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) - - ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) - - ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) - ) - )) - )) - slotspecs))))) + (declare (ignorable slotargs)) + (when cell + (let* ((reader-fn (or reader accessor)) + (writer-fn (or writer accessor)) + ) + `(progn + ,(when writer-fn + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) + ,(when reader-fn + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) + ,(when unchanged-if + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))))))) + slotspecs)) + (loop for slotspec in ',slotspecs + do (destructuring-bind + (slotname &rest slotargs &key (cell t) owning &allow-other-keys) + slotspec + (declare (ignorable slotargs)) + (when (and cell owning) + (setf (md-slot-owning-direct? ',class slotname) owning)))))) (defun defmd-canonicalize-slot (slotname &key defmodel.lisp @@ -23,27 +23,27 @@ (in-package :common-lisp-user) (defpackage :cells - (:use #:common-lisp #:utils-kt) - (:import-from - ;; MOP - #+allegro #:excl - #+clisp #:clos - #+cmu #:mop - #+cormanlisp #:common-lisp - #+lispworks #:clos - #+sbcl #:sb-mop - #+openmcl-partial-mop #:openmcl-mop - #+(and mcl (not openmcl-partial-mop)) #:ccl - - #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl) - #.(cerror "Provide a package name." - "Don't know how to find the MOP package for this Lisp.") - - #:class-precedence-list - #-(and mcl (not openmcl-partial-mop)) #:class-slots - #:slot-definition-name - #:class-direct-subclasses - ) + (:use #:common-lisp #:excl #:utils-kt) + (:import-from + ;; MOP + #+allegro #:excl + #+clisp #:clos + #+cmu #:mop + #+cormanlisp #:common-lisp + #+lispworks #:clos + #+sbcl #:sb-mop + #+openmcl-partial-mop #:openmcl-mop + #+(and mcl (not openmcl-partial-mop)) #:ccl + + #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl) + #.(cerror "Provide a package name." + "Don't know how to find the MOP package for this Lisp.") + + #:class-precedence-list + #-(and mcl (not openmcl-partial-mop)) #:class-slots + #:slot-definition-name + #:class-direct-subclasses + ) (:export #:cell #:.md-name #:c-input #:c-in #:c-in8 #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c?? @@ -61,3 +61,4 @@ #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx) #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) ) + defpackage.lisp @@ -25,10 +25,14 @@ See the Lisp Lesser GNU Public License for more details. (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) + (.dbg-par :cell nil :initform nil) (.value :initform nil :accessor value :initarg :value) (register? :cell nil :initform nil :initarg :register? :reader register?) - (zdbg :initform nil :accessor dbg :initarg :dbg)) - ) + (zdbg :initform nil :accessor dbg :initarg :dbg))) + +(defmethod not-to-be :around ((self model)) + (setf (slot-value self '.dbg-par) (fm-parent self)) ;; before it gets zapped + (call-next-method)) (defmethod initialize-instance :after ((self model) &key) (when (register? self) @@ -85,7 +89,6 @@ See the Lisp Lesser GNU Public License for more details. (when new-value (not-to-be self))) - (defvar *parent* nil) (defmodel family (model) @@ -229,7 +232,7 @@ See the Lisp Lesser GNU Public License for more details. (assert self) (if (registry? self) (progn - (trc "fm-registering" (md-name guest) :with self) + ;(trc "fm-registering" (md-name guest) :with self) (setf (gethash (md-name guest) (registry self)) guest)) (fm-register (fm-parent self) guest))) family.lisp @@ -14,9 +14,10 @@ the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. -$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.21 2008/06/16 12:38:04 ktilton Exp $ +$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.22 2008/10/12 01:21:07 ktilton Exp $ |# + (in-package :cells) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -26,7 +27,7 @@ $Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1. mk-part mk-part-spec upper - ^u + u^ container container-typed @@ -143,12 +144,19 @@ $Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1. (defmethod container (self) (fm-parent self)) +;;;(defmethod container-typed ((self model-object) type) +;;; (let ((parent (container self))) ;; fm- or ps-parent +;;; (cond +;;; ((null parent) nil) +;;; ((typep parent type) parent) +;;; (t (container-typed parent type))))) + (defmethod container-typed ((self model-object) type) - (let ((parent (container self))) ;; fm- or ps-parent - (cond - ((null parent) nil) - ((typep parent type) parent) - (t (container-typed parent type))))) + (let ((parent (fm-parent self))) ;; fm- or ps-parent + (cond + ((null parent) nil) + ((typep parent type) parent) + (t (container-typed parent type))))) (defun fm-descendant-typed (self type) (when self @@ -585,6 +593,8 @@ $Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1. :must-find ,must-find :global-search t))) + +(export! fm^v) (defmacro fm^v (id) `(value (fm^ ,id))) fm-utilities.lisp @@ -16,7 +16,7 @@ See the Lisp Lesser GNU Public License for more details. (defpackage #:gui-geometry (:nicknames #:geo) - (:use #:common-lisp #:utils-kt #:cells) + (:use #:common-lisp #:excl #:utils-kt #:cells) (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height gui-geometry/defpackage.lisp @@ -17,7 +17,7 @@ See the Lisp Lesser GNU Public License for more details. (in-package :gui-geometry) (export! geo-inline-lazy ^px-self-centered justify py-maintain-pt - ^prior-sib-pb spacing lr-maintain-pr) + ^prior-sib-pb spacing lr-maintain-pr orientation) ;--------------- geo-inline ----------------------------- ; @@ -146,7 +146,10 @@ See the Lisp Lesser GNU Public License for more details. (setf pl 0 pt (+ max-pb (downs (^spacing-vt)))) - collect (cons pl pt) into pxys + collect (cons (+ pl (case (justify self) + (:center (/ (- kw (l-width k)) 2)) + (:right (- kw (l-width k))) + (otherwise 0))) pt) into pxys do (incf pl (+ kw (^spacing-hz))) (setf max-pb (min max-pb (+ pt (downs (l-height k))))) finally (return (cons max-pb pxys))))) gui-geometry/geo-family.lisp @@ -61,7 +61,7 @@ See the Lisp Lesser GNU Public License for more details. ;---------- gOffset ------------------- -(export! offset-within) +(export! offset-within inset-lb) ; (defun offset-within (inner outer &optional dbg) (declare (ignorable dbg)) @@ -212,6 +212,9 @@ See the Lisp Lesser GNU Public License for more details. (defun inset-lb (self) (+ (lb self) (outset self))) +(defun inset-lt (self) + (downs (lt self) (outset self))) + (defun inset-height (self) (- (l-height self) (outset self) (outset self))) @@ -219,7 +222,7 @@ See the Lisp Lesser GNU Public License for more details. ;---------------------------------- -(export! geo-kid-wrap) +(export! geo-kid-wrap inset-lt) (defun geo-kid-wrap (self bound) (funcall (ecase bound ((pl pb) '-)((pr pt) '+)) gui-geometry/geometer.lisp @@ -40,13 +40,13 @@ See the Lisp Lesser GNU Public License for more details. (defmethod awaken-cell ((c c-ruled)) (let (*depender*) - (calculate-and-set c))) + (calculate-and-set c :fn-awaken-cell nil))) #+cormanlisp ; satisfy CormanCL bug (defmethod awaken-cell ((c c-dependent)) (let (*depender*) (trc nil "awaken-cell c-dependent clearing *depender*" c) - (calculate-and-set c))) + (calculate-and-set c :fn-awaken-cell nil))) (defmethod awaken-cell ((c c-drifter)) ; @@ -57,7 +57,7 @@ See the Lisp Lesser GNU Public License for more details. ; awakening, because awakening's other role is to get an instance up to speed ; at once upon instantiation ; - (calculate-and-set c) + (calculate-and-set c :fn-awaken-cell nil) (cond ((c-validp c) (c-value c)) ((c-unboundp c) nil) (t "illegal state!!!"))) initialize.lisp @@ -25,17 +25,21 @@ See the Lisp Lesser GNU Public License for more details. :change)) (defmacro with-integrity ((&optional opcode defer-info debug) &rest body) + (declare (ignorable debug)) (when opcode (assert (find opcode *ufb-opcodes*) () "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*)) `(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)) + ;;; ,(when debug + ;;; `(trc "integrity action entry" opcode defer-info ',body)) + ;;; (when *c-debug* + ;;; (when (eq opcode :change) + ;;; (trc "-------w/integ :change go--------------->:" defer-info))) ,@body) - (when *c-debug* - ',body))) + nil + #+noway (when *c-debug* ',body))) (export! with-cc) @@ -47,34 +51,39 @@ See the Lisp Lesser GNU Public License for more details. *within-integrity*) (defun call-with-integrity (opcode defer-info action code) + (declare (ignorable code)) (when *stop* (return-from call-with-integrity)) (if *within-integrity* (if opcode - (progn - (ufb-add opcode (cons defer-info action)) - ; - ; SETF is supposed to return the value being installed + (prog1 + :deferred-to-ufb-1 ; SETF is supposed to return the value being installed ; in the place, but if the SETF is deferred we return ; something that will help someone who tries to use ; the setf'ed value figure out what is going on: - ; - :deferred-to-ufb-1) + (ufb-add opcode (cons defer-info action))) + + ; thus by not supplying an opcode one can get something + ; executed immediately, potentially breaking data integrity + ; but signifying by having coded the with-integrity macro + ; that one is aware of this. If you read this comment. (funcall action opcode defer-info)) + (flet ((go-go () (let ((*within-integrity* t) *unfinished-business* *defer-changes*) (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) - (when *c-debug* (assert (boundp '*istack*))) + ;(when *c-debug* (assert (boundp '*istack*))) (when (or (zerop *data-pulse-id*) (eq opcode :change)) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 (funcall action opcode defer-info) + (setf *finbiz-id* 0) (finish-business))))) - (if *c-debug* + (if nil ;; *c-debug* (let ((*istack* (list (list opcode defer-info) (list :trigger code) (list :start-dp *data-pulse-id*)))) @@ -106,20 +115,22 @@ See the Lisp Lesser GNU Public License for more details. (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) (fifo-add (ufb-queue-ensure opcode) continuation)) -(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; make-better +(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; [mb] &aux (q (if (keywordp op-or-q) (ufb-queue op-or-q) op-or-q))) + (declare (ignorable op-code)) (trc nil "----------------------------just do it doing---------------------" op-or-q) (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) - (when *c-debug* + #+chill (when *c-debug* (push (list op-code defer-info) *istack*)) (funcall task op-or-q defer-info))) (defun finish-business () (when *stop* (return-from finish-business)) + (incf *finbiz-id*) (tagbody tell-dependents (just-do-it :tell-dependents) @@ -135,8 +146,9 @@ See the Lisp Lesser GNU Public License for more details. ; during their awakening to be handled along with those enqueued by cells of ; existing model instances. ; + #-its-alive! (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) - (trcx finish-business uqp) + (trcx fin-business uqp) (dolist (b (fifo-data (ufb-queue :tell-dependents))) (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) (break "unexpected 1> ufb needs to tell dependnents after telling dependents")) @@ -184,7 +196,9 @@ See the Lisp Lesser GNU Public License for more details. (go handle-clients))) ;--- now we can reset ephemerals -------------------- ; - ; one might be wondering when the observers got notified. That happens + ; one might be wondering when the observers got notified. That happens right during + ; slot.value.assume, via c-propagate. + ; ; Nice historical note: by accident, in the deep-cells test to exercise the new behavior ; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime ; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been integrity.lisp @@ -22,10 +22,11 @@ See the Lisp Lesser GNU Public License for more details. (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used) (return-from record-caller nil)) - (trc nil "record-caller entry: used=" used :caller *depender*) - #+cool (when (and (eq :ccheck (md-name (c-model *depender*))) - (eq :cview (md-name (c-model used)))) - (break "bingo")) + #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*) + (assert *depender*) + #+shhh (trc used "record-caller caller entry: used=" (qci used) + :caller *depender*) + (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds *depender*) @@ -43,7 +44,15 @@ See the Lisp Lesser GNU Public License for more details. (push used (cd-useds *depender*)) (caller-ensure used *depender*) ;; 060604 experiment was in unlink ) - + (let ((cd-usage (cd-usage *depender*))) + (when (>= used-pos (array-dimension cd-usage 0)) + (setf cd-usage + (setf (cd-usage *depender*) + (adjust-array (cd-usage *depender*) + (+ used-pos 16) + :initial-element 0)))) + (setf (sbit cd-usage used-pos) 1)) + #+nonportable (handler-case (setf (sbit (cd-usage *depender*) used-pos) 1) (type-error (error) @@ -68,8 +77,7 @@ See the Lisp Lesser GNU Public License for more details. (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) - #+save (when (eq 'mathx::progress (c-slot-name c)) - (trc "c-unlink-unused" c :dropping-used (car useds)) ) + (trc nil "c-unlink-unused" c :dropping-used (car useds)) (c-unlink-caller (car useds) c) (rplaca useds nil)) (progn @@ -82,8 +90,10 @@ See the Lisp Lesser GNU Public License for more details. (handle-used (incf rev-pos))) (handle-used (setf rev-pos 0)))))) (trc nil "cd-useds length" (length (cd-useds c)) c) + (nail-unused (cd-useds c)) - (setf (cd-useds c) (delete nil (cd-useds c))))))) + (setf (cd-useds c) (delete nil (cd-useds c))) + (trc nil "useds of" c :now (mapcar 'qci (cd-useds c))))))) (defun c-caller-path-exists-p (from-used to-caller) (count-it :caller-path-exists-p) @@ -95,7 +105,12 @@ See the Lisp Lesser GNU Public License for more details. ; --------------------------------------------- (defun cd-usage-clear-all (c) - (setf (cd-usage c) (blank-usage-mask))) + (setf (cd-usage c) (blank-usage-mask)) + #+wowo (loop with mask = (cd-usage c) + for n fixnum below (array-dimension mask 0) + do (setf (sbit mask n) 0) + finally (return mask)) + ) ;--- unlink from used ---------------------- link.lisp @@ -21,20 +21,22 @@ See the Lisp Lesser GNU Public License for more details. (defparameter *ide-app-hard-to-kill* t) (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) - (when (and (not *not-to-be*) - (mdead self)) + (when (and (not *not-to-be*) (mdead self)) + ;#-its-alive! (unless *stop* - (setf *stop* t) - (trc "md-slot-value passed dead self, returning NIL" self slot-name c) - #-sbcl (inspect self) - (break "see inspector for dead ~a" self)) - (return-from md-slot-value nil)) + (trc nil "md-slot-value passed dead self:" self :asked4slot slot-name :cell c) + ;#-sbcl (inspect self) + ;(setf *stop* t) + ;(break "md-slot-value sees dead ~a" self) + ) + (return-from md-slot-value (slot-value self slot-name))) ;; we can dream (tagbody retry (when *stop* (if *ide-app-hard-to-kill* (progn (princ #\.) + (princ "stopped") (return-from md-slot-value)) (restart-case (error "Cells is stopped due to a prior error.") @@ -65,84 +67,122 @@ See the Lisp Lesser GNU Public License for more details. (defvar *trc-ensure* nil) -(defmethod ensure-value-is-current (c debug-id ensurer) +(defun qci (c) + (when c + (cons (md-name (c-model c)) (c-slot-name c)))) + + +(defun ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure ; dependencies are up-to-date before deciding if it itself is up-to-date ; (declare (ignorable debug-id ensurer)) - - (count-it :ensure-value-is-current) - ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) - - (when *not-to-be* + ;(count-it! :ensure.value-is-current) + ;(trc "evic entry" (qci c)) + (wtrcx (:on? nil) ("evic>" (qci c) debug-id (qci ensurer)) + ;(count-it! :ensure.value-is-current ) + #+chill + (when ensurer ; (trcp c) + (count-it! :ensure.value-is-current (c-slot-name c) (md-name (c-model c))(c-slot-name ensurer) (md-name (c-model ensurer)))) + #+chill + (when (and *c-debug* (trcp c) + (> *data-pulse-id* 650)) + (bgo ens-high)) + + (trc nil ; c ;; (and *c-debug* (> *data-pulse-id* 495)(trcp c)) + "ensure.value-is-current > entry1" debug-id (qci c) :st (c-state c) :vst (c-value-state c) + :my/the-pulse (c-pulse c) *data-pulse-id* + :current (c-currentp c) :valid (c-validp c)) + + #+nahhh + (when ensurer + (trc (and *c-debug* (> *data-pulse-id* 495)(trcp c)) + "ensure.value-is-current > entry2" + :ensurer (qci ensurer))) + + (when *not-to-be* + (when (c-unboundp c) + (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) + (return-from ensure-value-is-current + (when (c-validp c) ;; probably accomplishes nothing + (c-value c)))) + + (when (and (not (symbolp (c-model c))) ;; damn, just here because of playing around with global vars and cells + (eq :eternal-rest (md-state (c-model c)))) + (break "model ~a of cell ~a is dead" (c-model c) c)) + + (cond + ((c-currentp c) + (count-it! :ensvc-is-indeed-currentp) + (trc nil "EVIC yep: 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) + (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first + (not (and (typep c 'c-dependent) + (eq (cd-optimize c) :when-value-t) + (null (c-value c))))) + (trc nil "evic: cool: inputp" (qci c))) + + ((or (bwhen (nv (not (c-validp c))) + (count-it! :ens-val-not-valid) + (trc nil "not c-validp, gonna run regardless!!!!!!" c) + nv) + ;; + ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been + ;; refreshed when checked, but was going to be checked last because it was the first used, useds + ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells + ;; still being encountered by consulting the prior useds list, but checking now in same order as + ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign). + ;; + (labels ((check-reversed (useds) + (when useds + (or (check-reversed (cdr useds)) + (let ((used (car useds))) + (ensure-value-is-current used :nested c) + #+slow (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + (when (> (c-pulse-last-changed used)(c-pulse c)) + (count-it! :ens-val-someused-newer) + (trc nil "used changed and newer !!!!######!!!!!! used" (qci used) :oldpulse (c-pulse used) + :lastchg (c-pulse-last-changed used)) + #+shhh (when (trcp c) + (describe used)) + t)))))) + (assert (typep c 'c-dependent)) + (check-reversed (cd-useds c)))) + (trc nil "kicking off calc-set of!!!!" (c-state c) (c-validp c) (qci c) :vstate (c-value-state c) + :stamped (c-pulse c) :current-pulse *data-pulse-id*) + (calculate-and-set c :evic ensurer) + (trc nil "kicked off calc-set of!!!!" (c-state c) (c-validp c) (qci c) :vstate (c-value-state c) + :stamped (c-pulse c) :current-pulse *data-pulse-id*)) + + ((mdead (c-value c)) + (trc nil "ensure.value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) + (let ((new-v (calculate-and-set c :evic-mdead ensurer))) + (trc nil "ensure.value-is-current> GOT new value ~a to replace dead!!" new-v) + new-v)) + + (t (trc nil "ensure.current decided current, updating pulse" (c-slot-name c) debug-id) + (c-pulse-update c :valid-uninfluenced))) + (when (c-unboundp c) (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) - (return-from ensure-value-is-current - (when (c-validp c) ;; probably accomplishes nothing - (c-value c)))) - - (when (and (not (symbolp (c-model c))) ;; damn, just here because of playing around with global vars and cells - (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 "EVIC yep: 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) - (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first - (not (and (typep c 'c-dependent) - (eq (cd-optimize c) :when-value-t) - (null (c-value c)))))) - - ((or (not (c-validp c)) - ;; - ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been - ;; refreshed when checked, but was going to be checked last because it was the first used, useds - ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells - ;; still being encountered by consulting the prior useds list, but checking now in same order as - ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign). - ;; - (labels ((check-reversed (useds) - (when useds - (or (check-reversed (cdr useds)) - (let ((used (car useds))) - (ensure-value-is-current used :nested c) - #+slow (trc c "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) - (when (> (c-pulse-last-changed used)(c-pulse c)) - #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used)) - #+shhh (when (trcp c) - (describe used)) - t)))))) - (assert (typep c 'c-dependent)) - (check-reversed (cd-useds c)))) - #+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c) - :stamped (c-pulse c) :current-pulse *data-pulse-id*) - (calculate-and-set c)) - - ((mdead (c-value c)) - (trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) - (let ((new-v (calculate-and-set c))) - (trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v) - new-v)) - - (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) - (c-pulse-update c :valid-uninfluenced))) - - (when (c-unboundp c) - (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) - - (bwhen (v (c-value c)) - (if (mdead v) - (progn - #+shhh (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) - nil) - v))) + + (bwhen (v (c-value c)) + (if (mdead v) + (progn + #-its-alive! + (progn + (format t "~&on pulse ~a ensure.value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) + (inspect v)) + nil) + v)))) -(defun calculate-and-set (c) +(defun calculate-and-set (c dbgid dbgdata) + (declare (ignorable dbgid dbgdata)) ;; just there for inspection of the stack during debugging (flet ((body () (when (c-stopped) (princ #\.) @@ -187,25 +227,12 @@ See the Lisp Lesser GNU Public License for more details. (*depender* c) (*defer-changes* t)) (assert (typep c 'c-ruled)) - #+shhh (trc c "calculate-and-link" c) + (trc nil "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) (c-unlink-unused c)))) -#+theabove! -(defun calculate-and-set (c) - (multiple-value-bind (raw-value propagation-code) - (let ((*call-stack* (cons c *call-stack*)) - (*depender* c) - (*defer-changes* t)) - (cd-usage-clear-all c) - (multiple-value-prog1 - (funcall (cr-rule c) c) - (c-unlink-unused c))) - (unless (c-optimized-away-p c) - (md-slot-value-assume c raw-value propagation-code)))) - ;------------------------------------------------------------- @@ -237,7 +264,7 @@ See the Lisp Lesser GNU Public License for more details. (c-state c) :awake) (bd-slot-makunbound self slot-name) ; - ; --- data flow propagation ----------- + ; --- data flow propagation ----------- ; (without-c-dependency (c-propagate c prior-value t))))))) @@ -277,9 +304,9 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" ;; anyway, if they no longer diverge the question of which to return is moot ) -(defmethod md-slot-value-assume (c raw-value propagation-code) +(defun md-slot-value-assume (c raw-value propagation-code) (assert c) - #+shhh (trc c "md-slot-value-assume entry" (c-state c)) + (trc nil "md-slot-value-assume entry" (qci c)(c-state c)) (without-c-dependency (let ((prior-state (c-value-state c)) (prior-value (c-value c)) @@ -291,13 +318,14 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" (when (and (not (eq propagation-code :propagate)) (find prior-state '(:valid :uncurrent)) (c-no-news c absorbed-value prior-value)) + (setf (c-value-state c) :valid) ;; new for 2008-07-15 (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value) (count-it :nonews) (return-from md-slot-value-assume absorbed-value)) ; --- slot maintenance --- - (unless (c-synaptic c) + (unless (c-synaptic c) (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value)) ; --- cell maintenance --- @@ -316,7 +344,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound)) - + (trc nil "exiting md-slot-val-assume" (c-state c) (c-value-state c)) absorbed-value))) (defun cache-bound-p (c) @@ -333,7 +361,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" (rassoc c (cells-flushed (c-model c)))) (defun c-optimize-away?! (c) - #+shhh (trc c "c-optimize-away?! entry" (c-state c) c) + #+shhh (trc nil "c-optimize-away?! entry" (c-state c) c) (when (and (typep c 'c-dependent) (null (cd-useds c)) (cd-optimize c) md-slot-value.lisp @@ -32,7 +32,7 @@ See the Lisp Lesser GNU Public License for more details. (defgeneric mdead (self) (:method ((self model-object)) - (unless *not-to-be* + (unless *not-to-be* ;; weird (eq :eternal-rest (md-state self)))) (:method (self) @@ -40,10 +40,13 @@ See the Lisp Lesser GNU Public License for more details. nil)) + (defgeneric not-to-be (self) - (:method ((self list)) - (dolist (s self) - (not-to-be s))) + (:method (other) + (declare (ignore other))) + (:method ((self cons)) + (not-to-be (car self)) + (not-to-be (cdr self))) (:method ((self array)) (loop for s across self do (not-to-be s))) @@ -53,6 +56,7 @@ See the Lisp Lesser GNU Public License for more details. (not-to-be v)) self)) (:method ((self model-object)) + (setf (md-census-count self) -1) (md-quiesce self)) (:method :before ((self model-object)) @@ -65,19 +69,23 @@ See the Lisp Lesser GNU Public License for more details. (dbg nil)) (flet ((gok () - (unless (eq (md-state self) :eternal-rest) - (call-next-method) - - (setf (fm-parent self) nil - (md-state self) :eternal-rest) - - (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c)) () - "Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by - a primary method? Use :before instead."))) ;; fails if user obstructs not.to-be with primary method (use :before etc) - - ))) + (if (eq (md-state self) :eternal-rest) + (trc nil "n2be already dead" self) + (progn + (call-next-method) + (setf (fm-parent self) nil + (md-state self) :eternal-rest) +;;; (bif (a (assoc (type-of self) *awake-ct*)) +;;; (decf (cdr a)) +;;; (break "no awake for" (type-of self) *awake-ct*)) +;;; (setf *awake* (delete self *awake*)) + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c)) () + "Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by + a primary method? Use :before instead." c self))) ;; fails if user obstructs not.to-be with primary method (use :before etc) + + )))) (if (not dbg) (gok) (wtrc (0 100 "not.to-be nailing" self (when (typep self 'family) @@ -85,6 +93,8 @@ See the Lisp Lesser GNU Public License for more details. (gok) (when dbg (trc "finished nailing" self)))))))) + + (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) @@ -101,7 +111,7 @@ See the Lisp Lesser GNU Public License for more details. (c-unlink-from-used c) (dolist (caller (c-callers c)) (setf (c-value-state caller) :uncurrent) - (trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller) + (trc nil "c-quiesce totlalaly unlinking caller and making uncurrent" .dpid :q c :caller caller) (c-unlink-caller c caller)) (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho ))) @@ -113,59 +123,104 @@ See the Lisp Lesser GNU Public License for more details. ,@initargs :fm-parent (progn (assert self) self))) -(export! self-owned self-owned?) +(defvar *c-d-d*) +(defvar *max-d-d*) -(defun (setf self-owned) (new-value self thing) - (if (consp thing) - (loop for e in thing do - (setf (self-owned self e) new-value)) - (if new-value - (progn - (assert (not (find thing (z-owned self)))) - (push thing (z-owned self))) - (progn - (assert (find thing (z-owned self))) - (setf (z-owned self)(delete thing (z-owned self))))))) +(defparameter *model-pop* nil) -(defun self-owned? (self thing) - (find thing (z-owned self))) +(export! md-census-start md-census-report md-census-count) -(defvar *c-d-d*) -(defvar *max-d-d*) +(defun md-census-start () + (setf *model-pop* (make-hash-table :test 'eq))) +(defun (setf md-census-count) (delta self) + (when *model-pop* + (incf (gethash (type-of self) *model-pop* 0) delta))) -(defun count-model (self) +(defun md-census-report () + (when *model-pop* + (loop for (ct . type) + in (sort (let (raw) + (maphash (lambda (k v) + (push (cons v k) raw)) + *model-pop*) + raw) '< :key 'car) + unless (zerop ct) + do (trc "pop" ct type)))) + +#+test +(md-census-report) + +#+test +(md-census-count) + +(defun md-census-count (&optional type) + (when *model-pop* + (if type + (gethash type *model-pop* 0) + (loop for v being the hash-values of *model-pop* + summing v)))) + + +(defun count-model (self &key count-cells &aux (ccc 0)) + (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0) - (with-metrics (t nil "cells statistics for" self) - (labels ((cc (self) - (count-it :thing) - (count-it :thing (type-of self)) - ;(count-it :thing-type (type-of self)) - (loop for (id . c) in (cells self) - do (count-it :live-cell) - ;(count-it :live-cell id) - - (typecase c - (c-dependent - (count-it :dependent-cell) - (loop repeat (length (c-useds c)) - do (count-it :cell-useds) - (count-it :dep-depth (c-depend-depth c)))) - (otherwise (if (c-inputp c) - (count-it :c-input id) - (count-it :c-unknow)))) - - (loop repeat (length (c-callers c)) - do (count-it :cell-callers))) - - (loop repeat (length (cells-flushed self)) - do (count-it :flushed-cell #+toomuchinfo id)) - - (loop for slot in (md-owning-slots self) do - (loop for k in (let ((sv (SLOT-VALUE self slot))) - (if (listp sv) sv (list sv))) - do (cc k))))) - (cc self)))) + (let ((*counted* (make-hash-table :test 'eq :size 5000))) + (with-metrics (t nil "cells statistics for" self) + (labels ((cc (self from) + (unless (gethash self *counted*) + (setf (gethash self *counted*) t) + (typecase self + (cons (cc (car self) from) + (cc (cdr self) from)) + #+nahhhh (mathx::box (count-it! :mathx-box-struct) + (cc (mathx::bx-mx self) from)) + (model + (when (zerop (mod (incf ccc) 100)) + (trc "cc" (md-name self) (type-of self))) + (count-it! :thing) + (count-it! :thing (type-of self)) + #+nahhhh (when (typep self 'mathx::problem) + (count-it! :thing-from (type-of self) (type-of from))) + (when count-cells + (loop for (nil . c) in (cells self) + do (count-it! :live-cell) + ;(count-it! :live-cell id) + (when (c-lazy c) + (count-it! :lazy) + (count-it! :lazy (c-value-state c))) + (typecase c + (c-dependent + (count-it! :dependent-cell) + #+chill (loop repeat (length (c-useds c)) + do (count-it! :cell-useds) + (count-it! :dep-depth (c-depend-depth c)))) + (otherwise (if (c-inputp c) + (progn + (count-it! :c-input-altogether) + ;(count-it! :c-input id) + ) + (count-it! :c-unknown)))) + + (loop repeat (length (c-callers c)) + do (count-it! :cell-callers))) + + (loop repeat (length (cells-flushed self)) + do (count-it! :flushed-cell #+toomuchinfo id))) + + (loop for slot in (md-owning-slots self) do + (loop for k in (let ((sv (SLOT-VALUE self slot))) + (if (listp sv) sv (list sv))) + do (cc k self))) + #+nahhh + (progn + (when (typep self 'mathx::mx-optr) + (cc (mathx::opnds self) from)) + (when (typep self 'mathx::math-expression) + (count-it! :math-expression)))) + (otherwise + (count-it (type-of self))))))) + (cc self nil))))) (defun c-depend-depth (ctop) (if (null (c-useds ctop)) md-utilities.lisp @@ -21,7 +21,7 @@ See the Lisp Lesser GNU Public License for more details. ;;; --- model-object ---------------------- (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(md-name fm-parent .parent z-owned))) + (export '(md-name fm-parent .parent ))) (defclass model-object () ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed] @@ -29,9 +29,9 @@ See the Lisp Lesser GNU Public License for more details. (.cells :initform nil :accessor cells) (.cells-flushed :initform nil :accessor cells-flushed :documentation "cells supplied but un-whenned or optimized-away") - (adopt-ct :initform 0 :accessor adopt-ct) - (z-owned :initform nil :accessor z-owned ;; experimental, not yet operative - :documentation "Things such as kids to be taken down when self is taken down"))) + (adopt-ct :initform 0 :accessor adopt-ct))) + +(defmethod register? ((self model-object))) (defmethod md-state ((self symbol)) :alive) @@ -40,6 +40,7 @@ See the Lisp Lesser GNU Public License for more details. (defmethod shared-initialize :after ((self model-object) slotnames &rest initargs &key fm-parent) (declare (ignorable initargs slotnames fm-parent)) + (setf (md-census-count self) 1) ;; bad idea if we get into reinitializing ; ; for convenience and transparency of mechanism we allow client code ; to intialize a slot to a cell, but we want the slot to hold the functional @@ -104,8 +105,23 @@ See the Lisp Lesser GNU Public License for more details. ; -- do initial evaluation of all ruled slots ; -- call observers of all slots + + +(export! md-awake-ct md-awake-ct-ct) +(defun md-awake-ct () + *awake-ct*) + +(defun md-awake-ct-ct () + (reduce '+ *awake-ct* :key 'cdr)) + + (defmethod md-awaken :around ((self model-object)) - (when (eql :nascent (md-state self)) + (when (eql :nascent (md-state self)) + #+nahh (bif (a (assoc (type-of self) *awake-ct*)) + (incf (cdr a)) + (push (cons (type-of self) 1) *awake-ct*)) + ;(trc "awake" (type-of self)) + #+chya (push self *awake*) (call-next-method)) self) @@ -160,7 +176,6 @@ See the Lisp Lesser GNU Public License for more details. (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed)))) - ((find (c-lazy c) '(:until-asked :always t)) (trc nil "md-awaken deferring c-awaken since lazy" self esd)) @@ -263,6 +278,9 @@ See the Lisp Lesser GNU Public License for more details. (md-slot-owning? st sn)) collect sn)))) +#+test +(md-slot-owning? 'cells::family '.kids) + (defun md-slot-value-store (self slot-name new-value) (trc nil "md-slot-value-store" self slot-name new-value) (if self @@ -290,12 +308,15 @@ See the Lisp Lesser GNU Public License for more details. ; before any dependency-ing could have happened, but a math-editor ; is silently switching between implied-multiplication and mixed numbers ; while they type and it - (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 "second cell same slot:" slot-name :old entry :new new-cell) + (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (declare (ignorable old)) + (c-assert (null (c-callers old))) + (when (typep entry 'c-dependent) + (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) model-object.lisp @@ -41,8 +41,8 @@ See the Lisp Lesser GNU Public License for more details. (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) (unless *one-pulse?* - (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) - (when *c-debug* + ;(trc "dp-next> " (1+ *data-pulse-id*) pulse-info) + #+chill (when *c-debug* (push (list :data-pulse-next pulse-info) *istack*)) (incf *data-pulse-id*))) @@ -85,7 +85,7 @@ See the Lisp Lesser GNU Public License for more details. (princ #\.)(princ #\!) (return-from c-propagate)) (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) - #+slow (trc c "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) + #+slow (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) (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) @@ -104,11 +104,11 @@ See the Lisp Lesser GNU Public License for more details. (when (and prior-value-supplied prior-value (md-slot-owning? (type-of (c-model c)) (c-slot-name c))) - (trc nil "c.propagate> contemplating lost" c) + (trc nil "c.propagate> contemplating lost" (qci c)) (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn - (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c)) + (trc nil "prop nailing owned!!!!!!!!!!!" (qci c) :lost (length lost)) ;; :leaving (c-value c)) (loop for l in lost when (numberp l) do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c) @@ -153,6 +153,8 @@ See the Lisp Lesser GNU Public License for more details. (defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args)))) (when aroundp (setf args (cdr args))) + (when (find slotname '(value kids)) + (break "d: did you mean .value or .kids when you coded ~a?" slotname)) (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value) (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c)) &body output-body) args @@ -217,11 +219,14 @@ See the Lisp Lesser GNU Public License for more details. (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) (let ((causation (cons c *causation*))) ;; in case deferred - #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c)) + #+slow (trc nil "c.propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (assert (null *depender*)) - (let ((*causation* causation)) + ; + (if (mdead (c-model c)) + (trc nil "WHOAA!!!! dead by time :tell-deps dispatched; bailing" c) + (let ((*causation* causation)) (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) @@ -231,27 +236,29 @@ See the Lisp Lesser GNU Public License for more details. (member (c-lazy caller) '(t :always :once-asked))) (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c) )) - (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list... + (dolist (caller (c-callers c)) (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller)) - (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced - (member (c-lazy caller) '(t :always :once-asked))) - (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) - #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c)) - (let ((*trc-ensure* (trcp c))) - ; - ; we just c-calculate-and-set? at the first level of dependency because - ; we do not need to check the next level (as ensure-value-is-current does) - ; because we already know /this/ notifying dependency has changed, so yeah, - ; any first-level cell /has to/ recalculate. (As for ensuring other dependents - ; of the first level guy are current, that happens automatically anyway JIT on - ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would - ; very quickly decide it has to re-run, but maybe it makes the logic clearer. - ; - ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason - ; - (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse - (calculate-and-set caller)) - )))))))) + (block do-a-caller + (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced + (member (c-lazy caller) '(t :always :once-asked))) + (unless (find c (cd-useds caller)) + (trc "WHOA!!!! Bailing on Known caller:" caller :does-not-in-its-used c) + (return-from do-a-caller)) + #+slow (trc nil "propagating to caller is used" c :caller caller (c-currentp c)) + (let ((*trc-ensure* (trcp c))) + ; + ; we just calculate-and-set at the first level of dependency because + ; we do not need to check the next level (as ensure-value-is-current does) + ; because we already know /this/ notifying dependency has changed, so yeah, + ; any first-level cell /has to/ recalculate. (As for ensuring other dependents + ; of the first level guy are current, that happens automatically anyway JIT on + ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would + ; very quickly decide it has to re-run, but maybe it makes the logic clearer. + ; + ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason + ; + (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse + (calculate-and-set caller :propagate c)))))))))))) (defparameter *the-unpropagated* nil) propagate.lisp @@ -60,18 +60,21 @@ See the Lisp Lesser GNU Public License for more details. (force-output stream) (values)) -(export! brk brkx .bgo) +(export! brk brkx .bgo bgo) -(define-symbol-macro .bgo (break "go")) +(define-symbol-macro .bgo + #+gimme-a-break (break "go") + #-gimme-a-break nil) -(defun brk (&rest args) - #+its-alive! (print args) - #-its-alive! (progn - ;;(setf *ctk-dbg* t) - (apply 'break args))) +(defmacro bgo (msg) + (declare (ignorable msg)) + #+gimme-a-break `(break "BGO ~a" ',msg) + #-gimme-a-break `(progn)) (defmacro brkx (msg) - `(break "At ~a: OK?" ',msg)) + (declare (ignorable msg)) + #+gimme-a-break `(break "At ~a: OK?" ',msg) + #-gimme-a-break `(progn)) (defmacro trcx (tgt-form &rest os) (if (eql tgt-form 'nil) @@ -80,10 +83,6 @@ See the Lisp Lesser GNU Public License for more details. (call-trc t ,(format nil "TX> ~(~s~)" tgt-form) ,@(loop for obj in (or os (list tgt-form)) nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) - - - - (defun call-trc-to-string (fmt$ &rest fmt-args) (let ((o$ (make-array '(0) :element-type 'base-char @@ -122,6 +121,19 @@ See the Lisp Lesser GNU Public License for more details. (when (< *trcdepth* ,max) ,@body))) +(defmacro wtrcx ((&key (min 1) (max 50) (on? t))(&rest banner) &body body ) + `(let ((*trcdepth* (if *trcdepth* + (1+ *trcdepth*) + 0))) + ,(when banner `(when (and ,on? (>= *trcdepth* ,min)) + (if (< *trcdepth* ,max) + (trc ,@banner) + (progn + (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) + nil)))) + (when (< *trcdepth* ,max) + ,@body))) + (defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) (declare (ignore min max banner)) `(progn ,@body)) trc-eko.lisp @@ -17,6 +17,8 @@ See the Lisp Lesser GNU Public License for more details. (in-package :utils-kt) + + (defmacro with-gensyms ((&rest symbols) &body body) `(let ,(loop for sym in symbols collecting `(,sym (gensym ,(string sym)))) @@ -47,7 +49,7 @@ resulting in implementation-specific behavior." ,@(when docstring (list docstring))))) (defun test-setup (&optional drib) - #+(and allegro ide) + #+(and allegro ide (or (not its-alive!) debugging-alive!)) (ide.base::find-new-prompt-command (cg.base::find-window :listener-frame)) (when drib @@ -58,8 +60,9 @@ resulting in implementation-specific behavior." (export! test-setup test-prep test-init) (export! project-path) (defun project-path () - #+(and allegro ide) - (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) + #+(and allegro ide (not its-alive!)) + (excl:path-pathname (ide.base::project-file ide.base:*current-project*)) + ) #+test (test-setup) utils-kt/core.lisp @@ -40,7 +40,7 @@ See the Lisp Lesser GNU Public License for more details. `(if ,onp (let ((*counting* (cons t *counting*))) (prog2 - (count-clear ,@msg) + (count-clear nil ,@msg) (progn ,@body) (show-count t ,@msg))) (progn ,@body))) @@ -48,28 +48,38 @@ See the Lisp Lesser GNU Public License for more details. (defun count-of (key) (cdr (assoc key *count* :key 'car))) -(defun count-clear (&rest msg) +(defun count-clear (announce &rest msg) (declare (ignorable msg)) - (format t "~&count-clear > ~a" msg) + (when announce (format t "~&count-clear > ~a" msg)) (setf *count* nil)) (defmacro count-it (&rest keys) (declare (ignorable keys)) + #+nahhh `(progn) - #+(or) `(when (car *counting*) + `(when (car *counting*) + (call-count-it ,@keys))) + +(export! count-it!) +(defmacro count-it! (&rest keys) + (declare (ignorable keys)) + #+(and its-alive! (not debugging-alive!)) + `(progn) + #-(and its-alive! (not debugging-alive!)) + `(when (car *counting*) (call-count-it ,@keys))) (defun call-count-it (&rest keys) (declare (ignorable keys)) #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL)) - (break "clean up time ~a" keys)) + (break "clean up time ~a" keys)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) (push (cons keys 1) *count*)))) -(defun show-count (clearp &rest msg) - (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) +(defun show-count (clearp &rest msg &aux announced) + (let ((res (sort (copy-list *count*) (lambda (v1 v2) (let ((v1$ (symbol-name (caar v1))) (v2$ (symbol-name (caar v2)))) @@ -81,10 +91,11 @@ See the Lisp Lesser GNU Public License for more details. for occs = (cdr entry) when (plusp occs) sum occs into running - and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) - (when clearp (count-clear "show-count"))) - - + and do (unless announced + (setf announced t) + (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)) + (format t "~&~4d ... ~2d ... ~(~{~a ~}~)" running occs (car entry)))) + (when clearp (count-clear announced "show-count" ))) ;-------------------- timex --------------------------------- utils-kt/debug.lisp @@ -15,14 +15,27 @@ See the Lisp Lesser GNU Public License for more details. |# + (in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) - (setf *features* (delete :its-alive! *features*))) + (setf *features* (remove :its-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (pushnew :gimme-a-break *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (remove :debugging-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; #+(and its-alive! (not debugging-alive!)) + ;;; (proclaim '(optimize (speed 3) (safety 1) (space 1) (debug 0))) + ;;; #-(and its-alive! (not debugging-alive!)) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) (defpackage :utils-kt (:nicknames #:ukt) - (:use #:common-lisp + (:use #:common-lisp #:excl #+(or allegro lispworks clisp) #:clos #+cmu #:mop #+sbcl #:sb-mop utils-kt/defpackage.lisp @@ -20,7 +20,7 @@ See the Lisp Lesser GNU Public License for more details. (in-package :utils-kt) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(eval-now! export! assocd rassoca))) + (export '(eval-now! export! assocd rassoca class-proto brk))) (defmacro wdbg (&body body) `(let ((*dbg* t)) @@ -29,11 +29,37 @@ See the Lisp Lesser GNU Public License for more details. (defun assocd (x y) (cdr (assoc x y))) (defun rassoca (x y) (car (assoc x y))) -;;;(defmethod class-slot-named ((classname symbol) slotname) -;;; (class-slot-named (find-class classname) slotname)) -;;; -;;;(defmethod class-slot-named (class slotname) -;;; (find slotname (class-slots class) :key #'slot-definition-name)) +(defun class-proto (c) + (let ((cc (find-class c))) + (when cc + (finalize-inheritance cc)) + (mop::class-prototype cc))) + + +(defun brk (&rest args) + #+its-alive! (apply 'error args) + #-its-alive! (progn + ;;(setf *ctk-dbg* t) + (apply 'break args))) + +(defun find-after (x l) + (bIf (xm (member x l)) + (cadr xm) + (brk "find-after ~a not member of ~a" x l))) + +(defun find-before (x l) + (loop with prior = nil + for i in l + if (eql i x) + return prior + else do (setf prior i) + finally (brk "find-before ~a not member of ~a" x l))) + +(defun list-insert-after (list after new ) + (let* ((new-list (copy-list list)) + (m (member after new-list))) + (rplacd m (cons new (cdr m))) + new-list)) #+(and mcl (not openmcl-partial-mop)) (defun class-slots (c) @@ -49,7 +75,7 @@ See the Lisp Lesser GNU Public License for more details. (defun xor (c1 c2) (if c1 (not c2) c2)) -(export! collect collect-if) +(export! collect collect-if find-after find-before list-insert-after) (defun collect (x list &key (key 'identity) (test 'eql)) (loop for i in list @@ -121,6 +147,8 @@ See the Lisp Lesser GNU Public License for more details. (loop until (fifo-empty q) do (print (fifo-pop q))))) +#+test +(line-count "/openair" t 10 t) #+allegro (defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0)) @@ -167,14 +195,14 @@ See the Lisp Lesser GNU Public License for more details. #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "ALGCOUNT" )) + :directory `(:absolute "0algcount" )) nil 5 t) #+(or) (loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml") summing (line-count (make-pathname :device "c" - :directory `(:absolute "1-devtools" ,d1)))) + :directory `(:absolute "0Algebra" "1-devtools" ,d1)))) (export! tree-includes tree-traverse tree-intersect) utils-kt/detritus.lisp @@ -131,11 +131,15 @@ See the Lisp Lesser GNU Public License for more details. ,yup ,nope))) +(defmacro b1 ((bindvar boundform) &body body) + `(let ((,bindvar ,boundform)) + ,@body)) + (defmacro maptimes ((nvar count) &body body) `(loop for ,nvar below ,count collecting (progn ,@body))) -(export! maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when) +(export! b1 maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when) (defun maphash* (f h) (loop for k being the hash-keys of h @@ -213,6 +217,7 @@ See the Lisp Lesser GNU Public License for more details. (head (let ((v (shuffle all))) (nconc v v)))) (lambda () + ;(print (list "without-repeating-generator sees len all =" len :decent-interval decent-interval)) (if (< len 2) (car all) (prog2 @@ -233,11 +238,17 @@ See the Lisp Lesser GNU Public License for more details. (export! without-repeating shuffle) -(let ((generators (make-hash-table :test 'equalp))) - (defun reset-without-repeating () - (setf generators (make-hash-table :test 'equalp))) - (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) - (funcall (or (gethash key generators) - (setf (gethash key generators) +(defparameter *without-repeating-generators* nil) + +(defun reset-without-repeating () + (if *without-repeating-generators* + (clrhash *without-repeating-generators*) + (setf *without-repeating-generators* (make-hash-table :test 'equalp)))) + +(defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) + (funcall (or (gethash key *without-repeating-generators*) + (progn + ;(print (list "without-repeating makes new gen" key :all-len (length all) :int decent-interval)) + (setf (gethash key *without-repeating-generators*) (without-repeating-generator decent-interval all)))))) utils-kt/flow-control.lisp @@ -24,8 +24,8 @@ See the Lisp Lesser GNU Public License for more details. left$ mid$ seg$ right$ insert$ remove$ trim$ trunc$ abbrev$ empty$ find$ num$ normalize$ down$ lower$ up$ upper$ equal$ - min$ numeric$ alpha$ assoc$ member$ match-left$ - +return$+ +lf$+))) + min$ numeric$ alpha$ assoc$ member$ starts$ + +return$+ +lf$+ case-string-equal))) (defmacro case$ (string-form &rest cases) (let ((v$ (gensym)) @@ -40,6 +40,19 @@ See the Lisp Lesser GNU Public License for more details. cases) (t ,@(or (cdr default) `(nil))))))) +(defmacro case-string-equal (string-form &rest cases) + (let ((v$ (gensym)) + (default (or (find 'otherwise cases :key #'car) + (find 'otherwise cases :key #'car)))) + (when default + (setf cases (delete default cases))) + `(let ((,v$ ,string-form)) + (cond + ,@(mapcar (lambda (case-forms) + `((string-equal ,v$ ,(string (car case-forms))) ,@(rest case-forms))) + cases) + (t ,@(or (cdr default) `(nil))))))) + ;-------- (defmethod shortc (other) @@ -200,8 +213,9 @@ See the Lisp Lesser GNU Public License for more details. (defmacro member$ (item list &rest kws) `(member ,item ,list :test #'string= ,@kws)) -(defun match-left$ (a b) - (string-equal a (subseq b 0 (length a)))) +(defun starts$ (a b) + (bwhen (s (search b a)) + (zerop s))) (defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) (defparameter *lf$* (string #\linefeed)) utils-kt/strings.lisp @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -32,6 +32,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'default-init-function :on-restart 'do-default-restart) utils-kt/utils-kt.lpr d565d1228fa96c6392f74d0be0264ab07c71a5fe ktilton ktilton http://github.com/Ramarren/cells/commit/8e89a4ceb1f3099da4cfa84b9b02b644eadcb53d 8e89a4ceb1f3099da4cfa84b9b02b644eadcb53d 2008-10-11T18:21:07-07:00 2008-10-11T18:21:07-07:00 Just trying to get a patch in for record-caller d8c3a032a39a2eed82f8ba3a0056298904f77c96 ktilton ktilton