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

[cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/widget-item.lisp
by Kenny Tilton 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv4446/celtic Modified Files: menu.lisp scrolling.lisp widget-item.lisp Log Message: Date: Tue Jul 6 18:25:41 2004 Author: ktilton Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.1 cell-cultures/celtic/menu.lisp:1.2 --- cell-cultures/celtic/menu.lisp:1.1 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/menu.lisp Tue Jul 6 18:25:41 2004 @@ -79,6 +79,13 @@ (path l))) (read *w*)) +(defmethod tk-eval (form$) + (tk-send + (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" + form$)) + (loop for value = (read *w* nil :eof) + While (not (eq value :eof)) + collecting value)) Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.1 cell-cultures/celtic/scrolling.lisp:1.2 --- cell-cultures/celtic/scrolling.lisp:1.1 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/scrolling.lisp Tue Jul 6 18:25:41 2004 @@ -30,23 +30,25 @@ -activerelief -command -elementborderwidth -width)) (defmodel scrolled-list (frame-row) - ((list-items :initarg :list-items :accessor list-items :initform nil) + ((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)) (:default-initargs - :list-height (c? (max 1 (length (^list-items)))) - :kids (c? (list + :list-height (c? (max 1 (length (^list-item-keys)))) + :kids (c? (the-kids (listbox :md-name :list - :kids (c? (list-items .parent)) + :kids (c? (mapcar (list-item-factory .parent) + (list-item-keys .parent))) :font "courier 9" :state (c? (if (enabled .parent) 'normal 'disabled)) :height (c? (list-height .parent)) :layout (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) - :yscrollcommand (c? (format nil "~a set" (path (nsib))))) + :yscrollcommand (c? (when (enabled .parent) + (format nil "~a set" (path (nsib)))))) (scrollbar :md-name :vscroll - :layout (c? (format nil "pack ~a -side right -fill y" (^path))) - :state (c? (if (enabled .parent) 'normal 'disabled)) - :command (c? (format nil "~a yview" (path (psib)))) - :command-is-callback nil))))) + :layout (c? (format nil "pack ~a -side right -fill y" (^path))) + :command (c? (format nil "~a yview" (path (psib)))) + :command-is-callback nil))))) (defun scrolled-list (&rest inits) (apply 'make-instance 'scrolled-list inits)) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.4 cell-cultures/celtic/widget-item.lisp:1.5 --- cell-cultures/celtic/widget-item.lisp:1.4 Mon Jul 5 12:29:53 2004 +++ cell-cultures/celtic/widget-item.lisp Tue Jul 6 18:25:41 2004 @@ -47,8 +47,9 @@ :md-name (create-name))) (defmethod not-to-be :after ((self widget)) - (trc "whacking true widget" self) - (tk-send (format nil "pack forget ~a" (^path)))) + (trc "not-to-be tk-forgetting true widget" self) + (tk-send (format nil "pack forget ~a" (^path))) + (tk-send (format nil "destroy ~a" (^path)))) (def-c-output command ((self widget)) (when (^command-is-callback) @@ -105,6 +106,7 @@ (apply 'make-instance ',class inits)) ,(when std-factory `(defmethod make-tk-instance ((self ,class)) + (trc nil "!!! tk-creating" self) (tk-send (format nil ,(concatenate 'string (down$ class) " ~A") (path self))))) ,@outputs))))

1 0

[cells-cvs] CVS update: cell-cultures/cells/cells.lisp cell-cultures/cells/family.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/md-utilities.lisp cell-cultures/cells/propagate.lisp
by Kenny Tilton 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv4446/cells Modified Files: cells.lisp family.lisp integrity.lisp md-slot-value.lisp md-utilities.lisp propagate.lisp Log Message: Date: Tue Jul 6 18:25:40 2004 Author: ktilton Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.3 cell-cultures/cells/cells.lisp:1.4 --- cell-cultures/cells/cells.lisp:1.3 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/cells.lisp Tue Jul 6 18:25:40 2004 @@ -38,15 +38,13 @@ (defparameter *c-debug* nil) (defun cell-reset () - (setf *count* nil - *stop* nil - *dbg* nil - *trcdepth* 0 - *c-prop-depth* 0 - *data-pulse-id* 0 - *data-pulses* nil - *unfinished-business* nil - ) + (utils-kt-reset) + (setf + *c-debug* nil + *c-prop-depth* 0 + *data-pulse-id* 0 + *data-pulses* nil + *unfinished-business* nil) (trc nil "------ cell reset ----------------------------")) (defun c-stop (&optional why) Index: cell-cultures/cells/family.lisp diff -u cell-cultures/cells/family.lisp:1.1 cell-cultures/cells/family.lisp:1.2 --- cell-cultures/cells/family.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/family.lisp Tue Jul 6 18:25:40 2004 @@ -182,6 +182,7 @@ (when (find-if 'zerop new-kids :key 'adopt-ct) (dolist (k new-kids) + (trc nil "kids change sees new kid" self k) (unless (member k old-kids) (if (eql :nascent (md-state k)) (progn Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.2 cell-cultures/cells/integrity.lisp:1.3 --- cell-cultures/cells/integrity.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/integrity.lisp Tue Jul 6 18:25:40 2004 @@ -102,20 +102,25 @@ (count-it :ufb-wasted)) (finish-business))))) + + (defun finish-business (&aux task some-output setfs (setf-ct 0)) (declare (ignorable setfs)) (tagbody - start ;--------------------------------- - (setf task (cdr (fifo-pop (ufb-queue :user-notify)))) - - (when task - (trc nil "finish-business notifying--------------------------") - (funcall task) - (go start)) + notify-users + ;--- notify users ------------------------------ + (let ((user-q-item (fifo-pop (ufb-queue :user-notify)))) + (when user-q-item + (destructuring-bind (defer-info . task) user-q-item + (declare (ignorable defer-info)) + (trc nil "finbiz notifying users of cell" (car defer-info)) + (funcall task) + (go notify-users)))) (setf some-output nil) - next-output ;-------------------------- + next-output + ;--- do c-output-slot-name ----------------------- (setf task (cdr (fifo-pop (ufb-queue :output)))) (cond @@ -125,8 +130,9 @@ (funcall task) (go next-output)) (some-output - (go start))) + (go notify-users))) + ; --- do deferred setfs ------------------------ (setf task (fifo-pop (ufb-queue :setf))) (when task (incf setf-ct) @@ -139,4 +145,4 @@ (push c setfs) (data-pulse-next (list :finbiz c new-value)) (funcall task-fn)))) - (go start)))) + (go notify-users)))) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.2 cell-cultures/cells/md-slot-value.lisp:1.3 --- cell-cultures/cells/md-slot-value.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/md-slot-value.lisp Tue Jul 6 18:25:40 2004 @@ -38,6 +38,7 @@ (defun c-value-ensure-current (c) (count-it :c-value-ensure-current) + (trc nil "c-value-ensure-current>" c) (cond ((c-inputp c)) ((c-currentp c)) @@ -46,6 +47,7 @@ (c-calculate-and-set c)) (t (c-pulse-update c :valid-uninfluenced))) + ;;(unless (cmdead c) (when (c-unboundp c) (error 'unbound-cell :instance (c-model c) :name (c-slot-name c))) @@ -64,34 +66,37 @@ (c-useds c)))) (defun c-calculate-and-set (c) - (when (c-stopped) - (princ #\.) - (return-from c-calculate-and-set)) - - (when (find c *c-calculators*) ;; circularity - (trc "c-calculate-and-set breaking on circularity" c) - (c-break ;; break is problem when testing cells on some CLs - "cell ~a midst askers: ~a" c *c-calculators*)) - - (count-it :c-calculate-and-set) - ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) - - (cd-usage-clear-all c) - - (let ((raw-value - (progn - (let ((*c-calculators* (cons c *c-calculators*))) - (trc nil "c-calculate-and-set> just added to *c-calculators*:" - *c-calculators*) - (c-assert (c-model c)) - (funcall (cr-rule c) c))))) + (flet ((body () + (when (c-stopped) + (princ #\.) + (return-from c-calculate-and-set)) - (when (and *c-debug* (typep raw-value 'cell)) - (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c raw-value)) + (when (find c *c-calculators*) ;; circularity + (trc "c-calculate-and-set breaking on circularity" c) + (c-break ;; break is problem when testing cells on some CLs + "cell ~a midst askers: ~a" c *c-calculators*)) - (c-unlink-unused c) - (md-slot-value-assume c raw-value))) + (count-it :c-calculate-and-set) + ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) + + (cd-usage-clear-all c) + + (let ((raw-value + (progn + (let ((*c-calculators* (cons c *c-calculators*))) + (trc nil "c-calculate-and-set> just added to *c-calculators*:" + *c-calculators*) + (c-assert (c-model c)) + (funcall (cr-rule c) c))))) + (progn ;; unless (cmdead c) ;; eg, rule includes (nsib), then parent decides (c-model c) is no more + (when (and *c-debug* (typep raw-value 'cell)) + (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c raw-value)) + + (c-unlink-unused c) + (md-slot-value-assume c raw-value))))) + (if nil ;; *dbg* + (ukt::wtrc (0 100 "calcnset" c) (body))(body)))) ;------------------------------------------------------------- Index: cell-cultures/cells/md-utilities.lisp diff -u cell-cultures/cells/md-utilities.lisp:1.1 cell-cultures/cells/md-utilities.lisp:1.2 --- cell-cultures/cells/md-utilities.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/md-utilities.lisp Tue Jul 6 18:25:40 2004 @@ -63,8 +63,9 @@ (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) (defmethod not-to-be ((self model-object)) - (trc nil "not to be!!!" self) - (unless (md-untouchable self) + (trc self "not to be!!!" self) + (if (md-untouchable self) + (trc "not-to-be not quiescing untouchable" self) (md-quiesce self))) (defmethod md-untouchable (self) ;; would be t for closed-stream under acl @@ -72,7 +73,7 @@ nil) (defun md-quiesce (self) - (trc nil "md-quiesce doing" self) + (trc nil "md-quiesce doing" self (type-of self)) (md-map-cells self nil (lambda (c) (trc nil "quiescing" c) (c-assert (not (find c *c-calculators*))) Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.2 cell-cultures/cells/propagate.lisp:1.3 --- cell-cultures/cells/propagate.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/propagate.lisp Tue Jul 6 18:25:40 2004 @@ -63,9 +63,14 @@ (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) - (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) - (when (c-user-cares user) - (c-value-ensure-current user))))))) + (bwhen (dead (catch :mdead + (trc nil "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) + (when (c-user-cares user) + (c-value-ensure-current user)))) + (when (eq dead (c-model c)) + (trc nil "!!! aborting further user prop of dead" dead) + (return-from c-propagate-to-users)) + (trc nil "!!! continuing user prop following: user => dead" user dead))))))) (defun c-user-cares (c) (not (or (c-currentp c) @@ -139,13 +144,13 @@ (not (c-optimized-away-p c)) ;; the other way above condition can be met (mdead (c-model c)))) -(defmethod cmdead :around (c) +(defmethod cmdead :around (c ) (when (call-next-method) (break "still reaching dead cells ~a" c))) (defun mdead (m) (when (eq :eternal-rest (md-state m)) - (break "still reaching dead instances ~a" m))) + (throw :mdead m))) (defmacro def-c-output (slotname (&optional (self-arg 'self) (new-varg 'new-value)

1 0

[cells-cvs] CVS update: cell-cultures/celtic/celtic.asd
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv2175/celtic Added Files: celtic.asd Log Message: Changes for SBCL Date: Mon Jul 5 12:31:42 2004 Author: tburdick

1 0

[cells-cvs] CVS update: cell-cultures/clyde/clyde.asd
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde In directory common-lisp.net:/tmp/cvs-serv1859/clyde Added Files: clyde.asd Log Message: Changes for SBCL Date: Mon Jul 5 12:31:22 2004 Author: tburdick

1 0

[cells-cvs] CVS update: cell-cultures/celtic/widget-item.lisp
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv20704/celtic Modified Files: widget-item.lisp Log Message: Changes for SBCL Date: Mon Jul 5 12:29:53 2004 Author: tburdick Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.3 cell-cultures/celtic/widget-item.lisp:1.4 --- cell-cultures/celtic/widget-item.lisp:1.3 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/widget-item.lisp Mon Jul 5 12:29:53 2004 @@ -83,8 +83,9 @@ (loop for tk-option-def in tk-options for slot-name = (de- (if (atom tk-option-def) tk-option-def (car tk-option-def))) - collecting `(,slot-name :initform nil :initarg ,(intern slot-name :keyword) - :accessor ,slot-name) + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) into slot-defs when (or (atom tk-option-def) (cadr tk-option-def)) @@ -142,8 +143,9 @@ tk-option-def (cadr tk-option-def)) for slot-name = (de- (if (atom tk-option-def) tk-option-def (car tk-option-def))) - collecting `(,slot-name :initform nil :initarg ,(intern slot-name :keyword) - :accessor ,slot-name) + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) into slot-defs collecting `(def-c-output ,slot-name ((self ,class)) (when (and (id-no self) new-value)

1 0

[cells-cvs] CVS update: cell-cultures/celtic/celtic.lisp
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv19339/celtic Modified Files: celtic.lisp Log Message: Changes for SBCL Date: Mon Jul 5 12:29:30 2004 Author: tburdick Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.3 cell-cultures/celtic/celtic.lisp:1.4 --- cell-cultures/celtic/celtic.lisp:1.3 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/celtic.lisp Mon Jul 5 12:29:30 2004 @@ -56,7 +56,9 @@ (error "Cannot create process.")) proc ) - #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt))) + #+:sbcl (let ((proc (sb-ext:run-program + program args :search t + :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream @@ -83,8 +85,7 @@ ;;; start wish and set *w* (defun tk-start () - #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos")))) + (setf *w* (do-execute "wish" '("-name" "Visual Apropos")))) (defun tk-send (text) "send a string to wish"

1 0

[cells-cvs] CVS update: cell-cultures/asdf-registry/create-symlinks.sh
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-registry In directory common-lisp.net:/tmp/cvs-serv5212/asdf-registry Modified Files: create-symlinks.sh Log Message: Added celtic and clyde. Date: Mon Jul 5 12:26:44 2004 Author: tburdick Index: cell-cultures/asdf-registry/create-symlinks.sh diff -u cell-cultures/asdf-registry/create-symlinks.sh:1.1 cell-cultures/asdf-registry/create-symlinks.sh:1.2 --- cell-cultures/asdf-registry/create-symlinks.sh:1.1 Tue Jun 29 18:08:33 2004 +++ cell-cultures/asdf-registry/create-symlinks.sh Mon Jul 5 12:26:44 2004 @@ -1,61 +1,65 @@ +rm -f asdf-aclproj.asd; if [ -d ../asdf-aclproj ]; then echo Adding asdf-aclproj.asd; - rm -f asdf-aclproj.asd; ln -s ../asdf-aclproj/asdf-aclproj.asd asdf-aclproj.asd; fi +rm -f cello.asd cellocore.asd; if [ -d ../cello ]; then echo Adding cello.asd; - rm -f cello.asd; ln -s ../cello/cello.asd cello.asd; echo Adding cellocore.asd; - rm -f cellocore.asd; ln -s ../cello/cellocore.asd cellocore.asd; fi +rm -f cellodemo.asd; if [ -d ../cellodemo ]; then echo Adding cellodemo.asd; - rm -f cellodemo.asd; ln -s ../cellodemo/cellodemo.asd cellodemo.asd; fi +rm -f cells.asd cells-test.asd; if [ -d ../cells ]; then echo Adding cells.asd; - rm -f cells.asd; ln -s ../cells/cells.asd cells.asd; echo Adding cells-test.asd; - rm -f cells-test.asd; - ln -s ../cells/cells-test.asd cells-test.asd; + ln -s ../cells/cells-test/cells-test.asd cells-test.asd; fi +rm -f celtic.asd; +if [ -d ../celtic ]; then + echo Adding celtic.asd; + ln -s ../celtic/celtic.asd celtic.asd; +fi + +rm -f clyde.asd; +if [ -d ../clyde ]; then + echo Adding clyde.asd; + ln -s ../clyde/clyde.asd clyde.asd; +fi + +rm -f cl-magick.asd; if [ -d ../cl-magick ]; then echo Adding cl-magick.asd; - rm -f cl-magick.asd; ln -s ../cl-magick/cl-magick.asd cl-magick.asd; fi +rm -f cl-openal.asd; if [ -d ../cl-openal ]; then echo Adding cl-openal.asd; - rm -f cl-openal.asd; ln -s ../cl-openal/cl-openal.asd cl-openal.asd; fi +rm -f cl-opengl.asd; if [ -d ../cl-opengl ]; then echo Adding cl-opengl.asd; - rm -f cl-opengl.asd; ln -s ../cl-opengl/cl-opengl.asd cl-opengl.asd; fi +rm -f ffi-extender.asd; if [ -d ../ffi-extender ]; then echo Adding ffi-extender.asd; - rm -f ffi-extender.asd; ln -s ../ffi-extender/ffi-extender.asd ffi-extender.asd; -fi - -if [ -d ../ide/cloucell ]; then - echo Adding cloucell.asd; - rm -f cloucell.asd; - ln -s ../ide/cloucell/cloucell.asd cloucell.asd; fi

1 0

[cells-cvs] CVS update: cell-cultures/asdf-aclproj/asdf-aclproj.lisp
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-aclproj In directory common-lisp.net:/tmp/cvs-serv29624/asdf-aclproj Modified Files: asdf-aclproj.lisp Log Message: Cleaned up the packages a bit. Date: Mon Jul 5 12:26:00 2004 Author: tburdick Index: cell-cultures/asdf-aclproj/asdf-aclproj.lisp diff -u cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.4 --- cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 Wed Jun 30 20:48:54 2004 +++ cell-cultures/asdf-aclproj/asdf-aclproj.lisp Mon Jul 5 12:26:00 2004 @@ -22,19 +22,27 @@ ;;; A hack to load Allegro's .lpr project files with ASDF. ;;; -(defpackage :asdf-aclproj +(defpackage :asdf-aclproj-impl (:use :cl) - (:export #:lpr-project-file)) + (:export #:lpr-project-file + #:define-project + #:project + #:module + #:project-module)) -(in-package :asdf-aclproj) +(defpackage :asdf-aclproj + (:use :asdf-aclproj-impl) + (:export #:lpr-project-file)) (defpackage :asdf-aclproj-user (:use :cl) (:import-from :asdf-aclproj - asdf-aclproj::define-project - asdf-aclproj::project - asdf-aclproj::module - asdf-aclproj::project-module)) + #:define-project + #:project + #:module + #:project-module)) + +(in-package :asdf-aclproj-impl) ;;; ;;; Classes for ASDF

1 0

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/ide/cloucell In directory common-lisp.net:/tmp/cvs-serv5472/ide/cloucell Removed Files: 01-cell-basics.lisp cloucell.asd cloucell.lpr ct-item-stack.lisp ct-slot-stack.lisp edt-window.lisp inspection.lisp inspector-toolbar.lisp inspector-window.lisp object-inspector-01.lisp object-inspector-02.lisp outline.lisp slot-inspector.lisp structure-view.lisp Log Message: Date: Sun Jul 4 11:59:48 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/clyde/clyde.lpr
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde In directory common-lisp.net:/tmp/cvs-serv5472/clyde Added Files: clyde.lpr Log Message: Date: Sun Jul 4 11:59:48 2004 Author: ktilton

1 0