April 2008 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS cells/utils-kt
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv5826/utils-kt Modified Files: datetime.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2007/11/30 16:51:20 1.4 +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2008/04/11 09:19:47 1.5 @@ -193,12 +193,13 @@ month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A" - year month date hours minutes seconds (floor (now) 10)))) + year month date hours minutes seconds (floor (* 10 (mod (now) 1.0)))))) (defun hyphenated-time-string () (substitute #\- #\: (ymdhmsh))) #+test (hyphenated-time-string) - +#+test +(ymdhmsh) \ No newline at end of file

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv5826/gui-geometry Modified Files: geo-family.lisp geo-macros.lisp geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2007/11/30 16:51:19 1.12 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/04/11 09:19:41 1.13 @@ -120,64 +120,35 @@ ;--------------- geo.row.flow ---------------------------- (export! geo-row-flow) -(defmodel geo-row-flow (geo-inline) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (geo-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) - 0 - ph))))))))) - -#| archive - -(defmodel geo-row-fv (family-values geo-row)()) -(defmodel geo-inline-fv (family-values geo-inline)()) - -;-------------------------- IMMatrix ------------------------------------------ - -(defmodel im-matrix (geo-zero-tl) - ((columns :cell nil :initarg :columns :initform nil :accessor columns) - (indent-hz :cell nil :initarg :indent-hz :initform 0 :accessor indent-hz) - (spacing-hz :cell nil :initarg :spacing-hz :initform 0 :accessor spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :accessor spacing-vt)) - (:default-initargs - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (px) - (c? (let ((parent (fm-parent self))) - (+ (indent-hz parent) - (if (zerop (mod (fm-pos self) - (or (columns parent) - (length (kids parent))))) - 0 - (+ (spacing-hz parent) - (pr (find-prior self (kids parent))))))))) - (mk-kid-slot (py) - (c? (let* ((parent (fm-parent self)) - (psib (find-prior self (kids parent)))) - (if (and psib (columns parent)) - (if (zerop (mod (fm-pos self) (columns parent))) - (+ (- (abs (spacing-vt parent))) (pb psib)) - (pt psib)) - 0)))))))) +(defmd geo-row-flow (geo-inline) + (spacing-hz 0) + (spacing-vt 0) + (aligned :cell nil) + (row-flow-layout + (c? (loop with max-pb = 0 and pl = 0 and pt = 0 + for k in (^kids) + for kpr = (+ pl (l-width k)) + when (unless (= pl 0) + (> kpr (- (l-width self) (outset self)))) do + (setf pl 0 + pt (+ max-pb (downs (^spacing-vt)))) + + collect (cons pl pt) into pxys + do (incf pl (+ (l-width k)(^spacing-hz))) + (setf max-pb (min max-pb (+ pt (downs (l-height k))))) + finally (return (cons max-pb pxys))))) + :lb (c? (+ (bif (xys (^row-flow-layout)) + (car xys) 0) + (downs (outset self)))) + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (px) + (c? (px-maintain-pl (car (nth (kid-no self) (cdr (row-flow-layout .parent))))))) + (mk-kid-slot (py) + (c? (py-maintain-pt (cdr (nth (kid-no self) (cdr (row-flow-layout .parent)))))))))) + -|# --- /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2008/04/11 09:19:41 1.2 @@ -77,7 +77,7 @@ (defmacro py-maintain-pB (pB) `(- ,pB (^lB))) -(export! centered-h? centered-v?) +(export! centered-h? centered-v? lb-maintain-pB) (defmacro ^fill-down (upper-type &optional (padding 0)) (let ((filled (gensym))) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2007/11/30 16:51:19 1.13 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/11 09:19:41 1.14 @@ -110,13 +110,26 @@ ;sum pXYs up the family tree ;gave an odd result for cursor display.... (defun v2-xlate (outer inner outer-v2) - (if (eql outer inner) + (if (eq outer inner) outer-v2 (v2-xlate outer (fm-parent inner) (v2-subtract outer-v2 (mkv2 (px inner) (py inner)))))) -(export! h-xlate v-xlate) +(defun v2-xlate-out (inner outer inner-v2) + (if (eq outer inner) + inner-v2 + (v2-xlate (fm-parent inner) outer + (v2-add inner-v2 + (mkv2 (px inner) (py inner)))))) + +(defun v2-xlate-between (from-v2 from to) + (cond + ((fm-includes from to)(v2-xlate from to from-v2)) + ((fm-includes to from)(v2-xlate-out from to from-v2)) + (t (break "time to extend v2-xlate-between")))) + +(export! h-xlate v-xlate v2-xlate-between) (defun h-xlate (outer inner outer-h) (if (eql outer inner)

1 0

[cells-cvs] CVS cells
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5826 Modified Files: cells.lisp family.lisp fm-utilities.lisp integrity.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25 +++ /project/cells/cvsroot/cells/cells.lisp 2008/04/11 09:19:29 1.26 @@ -16,14 +16,26 @@ |# -(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) +#| Notes +I don't like the way with-cc defers twice, first the whole thing and then when the +body finally runs we are still within the original integrity and each setf gets queued +to UFB separately before md-slot-value-assume finally runs. I think all that is going on here +is that we want the programmer to use with-cc to show they know the setf will not be returning +a useful value. But since they have coded the with-cc we should be able to figure out a way to +let those SETFs thru as if they were outside integrity, and then we get a little less UFBing +but even better SETF behaves as it should. +It would be nice to do referential integrity and notice any time a model object gets stored in +a cellular slot (or in a list in such) and then mop those up on not-to-be. + +|# -(in-package :cells) +(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) @@ -94,11 +106,8 @@ `t)))) (defmacro without-c-dependency (&body body) - `(call-without-c-dependency (lambda () ,@body))) - -(defun call-without-c-dependency (fn) - (let (*depender*) - (funcall fn))) + ` (let (*depender*) + ,@body)) (export! .cause) @@ -117,7 +126,8 @@ (slot-name self new old old-boundp cell) (declare (ignorable slot-name self new old old-boundp cell))) - +#+hunh +(fmakunbound 'slot-value-observe) ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 --- /project/cells/cvsroot/cells/family.lisp 2008/02/16 09:34:29 1.23 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/11 09:19:30 1.24 @@ -91,9 +91,7 @@ (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids - :initarg :kids) - ) - (:default-initargs :fm-parent (when (boundp '*parent*) *parent*))) + :initarg :kids))) (defmacro the-kids (&rest kids) `(let ((*parent* self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2008/01/29 04:29:52 1.17 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/04/11 09:19:31 1.18 @@ -115,6 +115,17 @@ :with-dependency dependently) (nreverse collection))) +(export! fm-collect-some) + +(defun fm-collect-some (tree test &optional skip-top dependently) + (let (collection) + (fm-traverse tree (lambda (node) + (unless (and skip-top (eq node tree)) + (bwhen (s (funcall test node)) + (push s collection)))) + :with-dependency dependently) + (nreverse collection))) + (defun fm-value-dictionary (tree value-fn &optional include-top) (let (collection) (fm-traverse tree --- /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/04/11 09:19:32 1.21 @@ -48,7 +48,15 @@ (return-from call-with-integrity)) (if *within-integrity* (if opcode - (ufb-add opcode (cons defer-info action)) + (progn + (ufb-add opcode (cons defer-info action)) + ; + ; 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) (funcall action opcode defer-info)) (let ((*within-integrity* t) *unfinished-business* @@ -63,18 +71,15 @@ (finish-business))))) (defun ufb-queue (opcode) - (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) (defun ufb-queue-ensure (opcode) - (assert (find opcode *ufb-opcodes*)) (or (ufb-queue opcode) (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*))))) (defparameter *no-tell* nil) (defun ufb-add (opcode continuation) - (assert (find opcode *ufb-opcodes*)) #+trythis (when (and *no-tell* (eq opcode :tell-dependents)) (break "truly queueing tell under no-tell")) (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) @@ -137,7 +142,7 @@ ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem. (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) - (trc "retelling dependenst, one new one being" uqp) + #+x42 (trc "retelling dependenst, one new one being" uqp) (go tell-dependents)) ;--- process client queue ------------------------------ @@ -175,7 +180,7 @@ (bwhen (task-info (fifo-pop (ufb-queue :change))) (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info - (trc nil "finbiz: deferred state change" defer-info) + #+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change))) (data-pulse-next (list :finbiz defer-info)) (funcall task-fn :change defer-info) ; --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/11 09:19:32 1.41 @@ -131,7 +131,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) + #+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))) @@ -227,7 +227,8 @@ (defun (setf md-slot-value) (new-value self slot-name &aux (c (md-slot-cell self slot-name))) - + #+shhh (when *within-integrity* + (trc "mdsetf>" self (type-of self) slot-name :new new-value)) (when *c-debug* (c-setting-debug self slot-name c new-value))

1 0

[cells-cvs] CVS Cells-js
by ktilton 06 Apr '08

06 Apr '08

Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv6206 Modified Files: cell-types.js cells.js constructors.js defmodel.js family-values.js family.js fm-utilities.js initialize.js integrity.js link.js md-slot-value.js md-utilities.js model-object.js propagate.js slot-utilities.js synapse-types.js synapse.js test.js trc-eko.js variables.js Log Message: --- /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,9 +14,9 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ -#| Notes +/* Notes I don't like the way with-cc defers twice, first the whole thing and then when the body finally runs we are still within the original integrity and each setf gets queued @@ -29,7 +29,7 @@ It would be nice to do referential integrity and notice any time a model object gets stored in a cellular slot (or in a list in such) and then mop those up on not-to-be. -|# +*/ (eval-when (compile load) --- /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) (defmacro defmodel (class directsupers slotspecs &rest options) --- /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) @@ -249,10 +249,10 @@ ;; -#| +/* (defun fm-member-named (kidname kids) (member kidname kids :key #'md-name)) - |# + */ (defun true-that (that) (declare (ignore that)) t) ;; --- /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) @@ -88,10 +88,10 @@ (slot-makunbound self slot-name) (makunbound self))) -#| sample incf +/* sample incf (defmethod c-value-incf ((base fpoint) delta) (declare (ignore model)) (if delta (fp-add base delta) base)) -|# +*/ --- /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:35:38 1.2 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -#| Synapse Cell Unification Notes +/* Synapse Cell Unification Notes - start by making Cells synapse-y @@ -47,16 +47,16 @@ - do diff unchanged tests such as string-equal work -|# +*/ -#| do list +/* do list -- can we lose the special handling of the .kids slot? -- test drifters (and can they be handled without creating a special subclass for them?) -|# +*/ (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) --- /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* The Newly Cells-aware TRC trace and EKO value echo facilities @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells)

1 0

[cells-cvs] CVS Cells-js
by ktilton 06 Apr '08

06 Apr '08

Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv32532 Added Files: cell-types.js cells.js constructors.js defmodel.js defpackage.js family-values.js family.js fm-utilities.js initialize.js integrity.js link.js md-slot-value.js md-utilities.js model-object.js propagate.js slot-utilities.js synapse-types.js synapse.js test-cycle.js test-ephemeral.js test-propagation.js test-synapse.js test.js trc-eko.js variables.js Log Message: Initial load of Lisp Cells source prior to revision into JS --- /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html) known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (defstruct (cell (:conc-name c-)) model slot-name value inputp ;; t for old c-variable class synaptic (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid} ; uncurrent (aka dirty) new for 06-10-15. we need this so ; c-quiesce can force a caller to update when asked ; in case the owner of the quiesced cell goes out of existence ; in a way the caller will not see via any kids dependency. Saw ; this one coming a long time ago: depending on cell X implies ; a dependency on the existence of instance owning X (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP (pulse-observed 0 :type fixnum) lazy (optimize t) debug md-info) ;_____________________ print __________________________________ #+sigh (defmethod print-object :before ((c cell) stream) (declare (ignorable stream)) #+shhh (unless (or *stop* *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) (declare (ignorable stream)) (unless *stop* (let ((*print-circle* t)) #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) (if *print-readably* (call-next-method) (progn (c-print-value c stream) (format stream "=~d/~a/~a/~a]" (c-pulse c) (c-state c) (symbol-name (or (c-slot-name c) :anoncell)) (print-cell-model (c-model c)))))))) (export! print-cell-model) (defgeneric print-cell-model (md) (:method (other) (print-object other nil))) (defmethod trcp :around ((c cell)) (or (c-debug c) (call-next-method))) (defun c-callers (c) "Make it easier to change implementation" (fifo-data (c-caller-store c))) (defun caller-ensure (used new-caller) (unless (find new-caller (c-callers used)) (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used) (fifo-add (c-caller-store used) new-caller))) (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) ; --- ephemerality -------------------------------------------------- ; ; Not a type, but an option to the :cell parameter of defmodel ; (defun ephemeral-p (c) (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) (defun ephemeral-reset (c) (when (ephemeral-p c) ;; so caller does not need to worry about this ; ; 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 ; and all outputs completed. ; ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? ; ;;(trcx bingo-ephem c) (with-integrity (:ephemeral-reset c) (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) (md-slot-value-store (c-model c) (c-slot-name c) nil) (setf (c-value c) nil)))) ; ----------------------------------------------------- (defun c-validate (self c) (when (not (and (c-slot-name c) (c-model c))) (format t "~&unadopted cell: ~s md:~s" c self) (c-break "unadopted cell ~a ~a" self c) (error 'c-unadopted :cell c))) (defstruct (c-ruled (:include cell) (:conc-name cr-)) (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) (eq :optimized-away (c-state c))) ;---------------------------- (defmethod trcp-slot (self slot-name) (declare (ignore self slot-name))) (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) ;; chop (synapses nil :type list) (useds nil :type list) (usage (blank-usage-mask))) (defun blank-usage-mask () (make-array 16 :element-type 'bit :initial-element 0)) (defstruct (c-drifter (:include c-dependent))) (defstruct (c-drifter-absolute (:include c-drifter))) ;_____________________ accessors __________________________________ (defmethod c-useds (other) (declare (ignore other))) (defmethod c-useds ((c c-dependent)) (cd-useds c)) (defun c-validp (c) (eql (c-value-state c) :valid)) (defun c-unboundp (c) (eql :unbound (c-value-state c))) ;__________________ (defmethod c-print-value ((c c-ruled) stream) (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>")) ((c-unboundp c) "<unb>") ((not (c-currentp c)) "dirty") (t "<err>")))) (defmethod c-print-value (c stream) (declare (ignore c stream))) --- /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html) known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# #| Notes I don't like the way with-cc defers twice, first the whole thing and then when the body finally runs we are still within the original integrity and each setf gets queued to UFB separately before md-slot-value-assume finally runs. I think all that is going on here is that we want the programmer to use with-cc to show they know the setf will not be returning a useful value. But since they have coded the with-cc we should be able to figure out a way to let those SETFs thru as if they were outside integrity, and then we get a little less UFBing but even better SETF behaves as it should. It would be nice to do referential integrity and notice any time a model object gets stored in 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) (defparameter *c-debug* nil) (defparameter *defer-changes* nil) (defparameter *within-integrity* nil) (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) #+test (cells-reset) (defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf *c-debug* debug *c-prop-depth* 0 *data-pulse-id* 0 *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil *unfinished-business* nil *trcdepth* 0) (trc nil "------ cell reset ----------------------------")) (defun c-stop (&optional why) (setf *stop* t) (print `(c-stop-entry ,why)) (format t "~&C-STOP> stopping because ~a" why) ) (define-symbol-macro .stop (c-stop :user)) (defun c-stopped () *stop*) (export! .stopped) (define-symbol-macro .stopped (c-stopped)) (defmacro c-assert (assertion &optional places fmt$ &rest fmt-args) (declare (ignorable assertion places fmt$ fmt-args)) #+(or)`(progn) `(unless *stop* (unless ,assertion ,(if fmt$ `(c-break ,fmt$ ,@fmt-args) `(c-break "failed assertion: ~a" ',assertion))))) (defvar *call-stack* nil) (defvar *depender* nil) ;; 2008-03-15: *depender* let's us differentiate between the call stack and ;; and dependency. The problem with overloading *call-stack* with both roles ;; is that we miss cyclic reentrance when we use without-c-dependency in a ;; rule to get "once" behavior or just when fm-traversing to find someone (defmacro def-c-trace (model-type &optional slot cell-type) `(defmethod trcp ((self ,(case cell-type (:c? 'c-dependent) (otherwise 'cell)))) (and (typep (c-model self) ',model-type) ,(if slot `(eq (c-slot-name self) ',slot) `t)))) (defmacro without-c-dependency (&body body) ` (let (*depender*) ,@body)) (export! .cause) (define-symbol-macro .cause (car *causation*)) (define-condition unbound-cell (unbound-slot) ((cell :initarg :cell :reader cell :initform nil))) (defgeneric slot-value-observe (slotname self new old old-boundp cell) #-(or cormanlisp) (:method-combination progn)) #-cells-testing (defmethod slot-value-observe #-(or cormanlisp) progn (slot-name self new old old-boundp cell) (declare (ignorable slot-name self new old old-boundp cell))) ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 ((cell :initarg :cell :reader cell :initform nil) (app-func :initarg :app-func :reader app-func :initform 'bad-cell) (error-text :initarg :error-text :reader error-text :initform "<???>") (other-data :initarg :other-data :reader other-data :initform "<nootherdata>")) (:report (lambda (c s) (format s "~& trouble with cell ~a in function ~s,~s: ~s" (cell c) (app-func c) (error-text c) (other-data c))))) (define-condition c-enabling () ((name :initarg :name :reader name) (model :initarg :model :reader model) (cell :initarg :cell :reader cell)) (:report (lambda (condition stream) (format stream "~&unhandled <c-enabling>: ~s" condition) (break "~&i say, unhandled <c-enabling>: ~s" condition)))) (define-condition c-fatal (xcell) ((name :initarg :name :reader name) (model :initarg :model :reader model) (cell :initarg :cell :reader cell)) (:report (lambda (condition stream) (format stream "~&fatal cell programming error: ~s" condition) (format stream "~& : ~s" (name condition)) (format stream "~& : ~s" (model condition)) (format stream "~& : ~s" (cell condition))))) (define-condition c-unadopted (c-fatal) () (:report (lambda (condition stream) (format stream "~&unadopted cell >: ~s" (cell condition)) (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) (defun c-break (&rest args) (unless *stop* (let ((*print-level* 5) (*print-circle* t) (args2 (mapcar 'princ-to-string args))) (c-stop args) (format t "~&c-break > stopping > ~{~a ~}" args2) (print `(c-break-args ,@args2)) (apply 'error args2))))--- /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html) known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (eval-now! (export '(.cache-bound-p ;; Cells Constructors c?n c?once c?n-until c?1 c_1 c?+n ;; Debug Macros and Functions c?dbg c_?dbg c-input-dbg ))) ;___________________ constructors _______________________________ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) ,@body)) [158 lines skipped] --- /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 1.1 [359 lines skipped] --- /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 1.1 [422 lines skipped] --- /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 1.1 [518 lines skipped] --- /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 1.1 [729 lines skipped] --- /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 1.1 [1374 lines skipped] --- /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 1.1 [1437 lines skipped] --- /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 1.1 [1636 lines skipped] --- /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 1.1 [1775 lines skipped] --- /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 1.1 [2134 lines skipped] --- /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 1.1 [2222 lines skipped] --- /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 1.1 [2504 lines skipped] --- /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 1.1 [2786 lines skipped] --- /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 1.1 [2883 lines skipped] --- /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 1.1 [3035 lines skipped] --- /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 1.1 [3124 lines skipped] --- /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 1.1 [3201 lines skipped] --- /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 1.1 [3258 lines skipped] --- /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 1.1 [3303 lines skipped] --- /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 1.1 [3405 lines skipped] --- /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 1.1 [3633 lines skipped] --- /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 1.1 [3792 lines skipped] --- /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 1.1 [3910 lines skipped]

1 0

[cells-cvs] CVS Cells-js/web-pages
by ktilton 06 Apr '08

06 Apr '08

Update of /project/cells/cvsroot/Cells-js/web-pages In directory clnet:/tmp/cvs-serv32422/web-pages Log Message: Directory /project/cells/cvsroot/Cells-js/web-pages added to the repository

1 0

[cells-cvs] CVS Cells-js
by ktilton 06 Apr '08

06 Apr '08

Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv32148 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import

1 0