cells-cvs

cells-cvs@common-lisp.net

721 discussions

[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

[cells-cvs] 100% Safe To Take, With NO Side Effects.
by Candice 31 Mar '08

31 Mar '08

Men are going to stand up and clap their hands at these penis enlargement capsules. It has produced remarkable results that have never been seen before with NO negative side effects. These penis enlargement capsules offer women what they really want, more to play with! Those extra inches really do make the difference! http://yutoutye.com regards,

1 0

[cells-cvs] CVS Celtk
by ktilton 23 Mar '08

23 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv29619 Modified Files: CELTK.lpr composites.lisp keysym.lisp run.lisp tk-object.lisp togl.lisp Log Message: Sorting out some confusion after commititng from wrong directory (but a recent backup of the real deal so not too bad). But folks might want to rebuild and test to see if anything got messed up. --- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/17 20:33:57 1.24 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25 @@ -114,7 +114,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-andy-expander + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/composites.lisp 2008/03/17 20:33:57 1.26 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/03/23 23:47:42 1.27 @@ -117,7 +117,7 @@ (defun app-idle (self) (loop for w in (^kids) - do (when (not (eq :arrow (cursor w))) + do (when (eq :watch (cursor w)) (setf (cursor w) :arrow))) (setf (^app-time) (now)) (loop for task in *app-idle-tasks* @@ -139,18 +139,20 @@ start-up-fn close-fn initial-focus - (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. + (focus-state (c-in nil) + :documentation "This is about the window having the focus on the desktop, not the key focus. Actually holds last event code, :focusin or :focusout") on-key-down on-key-up :width (c?n 800) :height (c?n 600)) -(defobserver focus-state ((self window)) - (trc "focus-state" self new-value :old old-value)) +;;;(defobserver focus-state ((self window)) +;;; (trc "focus-state" self new-value :old old-value)) (defmethod (setf cursor) :after (new-value (self window)) (when new-value + (trc nil "configure cursor" self new-value) (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value))))) (export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state) --- /project/cells/cvsroot/Celtk/keysym.lisp 2008/01/03 20:23:30 1.1 +++ /project/cells/cvsroot/Celtk/keysym.lisp 2008/03/23 23:47:42 1.2 @@ -951,6 +951,85 @@ ;;; (at . #\@) ;;; (tab . #\tab))) +(export! *cursors*) +(defparameter *cursors* + (apply 'vector '(X_cursor + arrow + based_arrow_down + based_arrow_up + boat + bogosity + bottom_left_corner + bottom_right_corner + bottom_side + bottom_tee + box_spiral + center_ptr + circle + clock + coffee_mug + cross + cross_reverse + crosshair + diamond_cross + dot + dotbox + double_arrow + draft_large + draft_small + draped_box + exchange + fleur + gobbler + gumby + hand1 + hand2 + heart + icon + iron_cross + left_ptr + left_side + left_tee + leftbutton + ll_angle + lr_angle + man + middlebutton + mouse + pencil + pirate + plus + question_arrow + right_ptr + right_side + right_tee + rightbutton + rtl_logo + sailboat + sb_down_arrow + sb_h_double_arrow + sb_left_arrow + sb_right_arrow + sb_up_arrow + sb_v_double_arrow + shuttle + sizing + spider + spraycan + star + target + tcross + top_left_arrow + top_left_corner + top_right_corner + top_side + top_tee + trek + ul_angle + umbrella + ur_angle + watch + xterm))) (export! keysym-char keysym-sym minus period asciicircum plus backspace delete bar parenleft parenright bracketleft bracketright braceleft braceright less greater --- /project/cells/cvsroot/Celtk/run.lisp 2008/03/17 20:33:57 1.27 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/03/23 23:47:42 1.28 @@ -18,8 +18,6 @@ (in-package :Celtk) - - ;;; --- running a Celtk (window class, actually) -------------------------------------- (eval-now! @@ -45,13 +43,6 @@ #-unix ;;(tk-format-now "package require QuickTimeTcl") (tk-format-now "snack::sound s") -;;; (tk-format-now (conc$ "snack::sound s -load " -;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") -;;; :name "ahem_x" :type "wav") -;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) -;;; (tk-format-now "s play -blocking yes") -;;; (sleep 2) -;;; (tk-format-now "s play") (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 11:52:56 1.15 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16 @@ -50,34 +50,30 @@ ;;; --- deftk -------------------- -(defmacro deftk (class superclasses - (&rest std-slots) - &rest defclass-options) +(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options) (destructuring-bind (&optional tk-class &rest tk-options) (cdr (find :tk-spec defclass-options :key 'car)) (setf tk-options (tk-options-normalize tk-options)) `(eval-now! - (defmodel ,class ,(or superclasses '(tk-object)) - (,@(append std-slots (loop for (slot-name nil) in tk-options - collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name)))) - ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) - (:default-initargs - ,@(when tk-class `(:tk-class ',tk-class)) - ,@(cdr (find :default-initargs defclass-options :key 'car)))) - (defmethod tk-class-options append ((self ,class)) - ',tk-options) - (export ',class) - (export ',(loop for (slot nil) in tk-options - nconcing (list slot (intern (conc$ "^" slot))))) - (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) - `(make-instance ',',class - :fm-parent *parent* - ,@inits)) - (export ',(intern (conc$ "MK-" (symbol-name class))))))) + (defmodel ,class ,(or superclasses '(tk-object)) + (,@(append std-slots (loop for (slot-name nil) in tk-options + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name)))) + ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) + (:default-initargs + ,@(when tk-class `(:tk-class ',tk-class)) + ,@(cdr (find :default-initargs defclass-options :key 'car)))) + (defmethod tk-class-options append ((self ,class)) + ',tk-options) + (export ',(loop for (slot nil) in tk-options + nconcing (list slot (intern (conc$ "^" slot))))) + (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) + `(make-instance ',',class + :fm-parent *parent* + ,@inits))))) (defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 17:07:59 1.29 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 23:47:42 1.30 @@ -191,6 +191,8 @@ (call-next-method))) (defmethod ,(intern uc$) ((self togl)))))) + + (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) ;; @@ -199,8 +201,13 @@ ;;(eval-when (:compile-toplevel :execute) ;; (if (member :cello cl-user::*features*) ;; (progn - (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready - (kt-opengl:kt-opengl-reset) + + (when (find-package "CL-FTGL") + (set (find-symbol "*FTGL-OGL*" "CL-FTGL") togl-ptr)) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready + + (when (find-package "KT-OPENGL") + (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "CL-FTGL")))) + ;;; ^^^^^ above two needed only for cello ^^^^^^ ;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred

1 0

[cells-cvs] CVS Celtk
by ktilton 23 Mar '08

23 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17817 Modified Files: togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/17 20:33:57 1.28 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 17:07:59 1.29 @@ -19,6 +19,7 @@ (in-package :celtk) + (define-foreign-library Togl (:darwin (:or "libTogl1.7.dylib" "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 23 Mar '08

23 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8667 Modified Files: tk-object.lisp Log Message: added: 1. deftk now automatically export the class of the widget 2. it also exports the mk- macro for that class. fixed: bug in tk-class-options generic function. --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/17 20:33:57 1.14 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 11:52:56 1.15 @@ -70,12 +70,14 @@ ,@(cdr (find :default-initargs defclass-options :key 'car)))) (defmethod tk-class-options append ((self ,class)) ',tk-options) + (export ',class) (export ',(loop for (slot nil) in tk-options nconcing (list slot (intern (conc$ "^" slot))))) (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) `(make-instance ',',class :fm-parent *parent* - ,@inits))))) + ,@inits)) + (export ',(intern (conc$ "MK-" (symbol-name class))))))) (defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" @@ -99,7 +101,7 @@ (case (type-of self) (label '(pady padx height indicatoron relief tk-label)) (otherwise '(pady padx #+hmmm height indicatoron relief tk-label))));; - do (setf old (delete old all :key 'car)) + do (setf all (delete old all :key 'car)) finally (return all)))))) (defun tk-config-option (self slot-name)

1 0

[cells-cvs] CVS Celtk
by fgoenninger 23 Mar '08

23 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6379 Modified Files: scroll.lisp Log Message: Added: scrollbar widget: support for width, activestyle, selectforeground, selectbackground, selectmode --- /project/cells/cvsroot/Celtk/scroll.lisp 2007/11/16 10:01:44 1.5 +++ /project/cells/cvsroot/Celtk/scroll.lisp 2008/03/23 11:43:15 1.6 @@ -38,7 +38,17 @@ ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) (list-height :initarg :list-height :accessor list-height :initform nil) - (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9)))) + (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9))) + (width :initarg :width :accessor width :initform (c-in 20)) + (activestyle :initarg :activestyle :accessor activestyle :initform (c-in nil)) + (selectforeground :initarg :selectforeground + :accessor selectforeground :initform (c-in "black")) + (selectbackground :initarg :selectbackground + :accessor selectbackground :initform (c-in nil)) + (selectmode :initarg :selectmode + :accessor selectmode :initform (c-in 'single)) + + ) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids-packing nil @@ -48,6 +58,11 @@ (mapcar (list-item-factory .parent) (list-item-keys .parent)))) :tkfont (c? (tkfont .parent)) + :width (c? (width .parent)) + :activestyle (c? (activestyle .parent)) + :selectforeground (c? (selectforeground .parent)) + :selectbackground (c? (selectbackground .parent)) + :selectmode (c? (selectmode .parent)) :state (c? (if (enabled .parent) 'normal 'disabled)) :takefocus (c? (if (enabled .parent) 1 0)) :height (c? (list-height .parent)) @@ -64,6 +79,8 @@ (when new-value (let ((lb (car (^kids))) (item-no (position new-value (^list-item-keys) :test 'equal))) + (trc nil "tk-output selection: lb | item-no | path of lb " lb item-no (path lb)) + (if item-no (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no) (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys))))))

1 0

← Newer
1
...
8
9
10
11
12
13
14
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs