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

[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

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

23 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4313 Modified Files: multichoice.lisp Log Message: Changed: event id handling (see also entry.lisp) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 22:58:41 1.14 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2008/03/23 11:38:16 1.15 @@ -66,12 +66,22 @@ :event-handler (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc ":virtualevent" (xsv name xe)) - (case (read-from-string (string-upcase (xsv name xe))) - (ListboxSelect - (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) - (setf (selection (tk-selector self)) - (value (elt (^kids) selection))))))))))) + (trc nil "LISTBOX :virtualevent" (xsv name xe)) + (let ((event-id + (intern (read-from-string + (string-upcase (xsv name xe))) + :keyword))) + (case event-id + (:listboxselect + (let ((selection + (parse-integer + (tk-eval "~a curselection" (^path)) + :junk-allowed t))) + (trc nil "LISTBOX :virtualevent => selection: " selection) + (when selection + (setf (selection (tk-selector self)) + (value (elt (^kids) selection)))))))) + ))))) (defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text

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-serv4140 Modified Files: entry.lisp Log Message: changed: entry widget: in order to detect events reliably the event id is interned as a keyword. --- /project/cells/cvsroot/Celtk/entry.lisp 2007/01/29 06:48:41 1.18 +++ /project/cells/cvsroot/Celtk/entry.lisp 2008/03/23 11:36:42 1.19 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.18 2007/01/29 06:48:41 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.19 2008/03/23 11:36:42 fgoenninger Exp $ (in-package :Celtk) @@ -40,21 +40,25 @@ :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) :event-handler (lambda (self xe) - (TRC nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) + (trc nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc nil "ENTRY virtual event" (xsv name xe)) - (case (read-from-string (string-upcase (xsv name xe))) - (trace - (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) - (tcl-get-string (xsv user-data xe)))) - ;; assuming write op, but data field shows that - (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^value)) - (setf (^value) new-value)))))))) - - :value (c-in ""))) + (trc "ENTRY virtual event" (xsv name xe)) + (let ((event-id (intern + (read-from-string + (string-upcase (xsv name xe))) + :keyword))) + (case event-id + (:trace + (TRC "entry e/h trace" self + (when (plusp (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) + ;; assuming write op, but data field shows that + (let ((new-value (tcl-get-var *tki* (^path) + (var-flags :TCL-NAMESPACE-ONLY)))) + (unless (string= new-value (^value)) + (setf (^value) new-value))))))))) + :value (c-in ""))) (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) @@ -64,10 +68,12 @@ ;;; those leverage the COMMAND mechanism, which entry lacks ;; (defobserver .value ((self entry)) + (trc nil "ENTRY self new-value old-value" self new-value old-value) (when new-value (unless (string= new-value old-value) - (trc nil "value output" self new-value) - (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) + (trc "ENTRY value output self new-value old-value" self new-value old-value) ;; frgo, 2007-11-22 + (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY)) + #+frgo (tk-format-now "~a -text ~A" (^path) new-value)))) (deftk text-widget (widget) ((modified :initarg :modified :accessor modified :initform nil)) @@ -97,7 +103,7 @@ (:virtualevent (case (read-from-string (string-upcase (xsv name xe))) (modified - (eko (nil "<<Modified>> !!TK value for text-widget" self) + (eko (nil "<<Modified>> !!TK value for text-widget" self) ;; frgo, 2007-11-22 (setf (^modified) t))))) ))))

1 0

[cells-cvs] Take MBA that you deserve from an Established Prestigious Institution.
by Lloyd 20 Mar '08

20 Mar '08

F A S T T R A C K D E G R E E P R O G R A M Obtain the degree you deserve, based on your present knowledge and life experience. A prosperous future, money earning power, and the Admiration of all. Degrees from an Established, Prestigious, Leading Institution. Your Degree will show exactly what you really can do. Get the Job, Promotion, Business Opportunity and Social Advancement you Desire! Eliminates classrooms and traveling. Achieve your Bachelors, Masters, MBA, or PhD in the field of your expertise Professional and affordable Call now - your Graduation is a phone call away. Please call: +1 206 30 90 336

1 0

[cells-cvs] CVS cells
by ktilton 17 Mar '08

17 Mar '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv4791 Modified Files: defmodel.lisp Log Message: --- /project/cells/cvsroot/cells/defmodel.lisp 2008/02/16 09:40:51 1.17 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/03/17 20:34:45 1.18 @@ -54,7 +54,7 @@ ; ------- defclass --------------- (^slot-value ,model ',',slotname) ; - (progn + (prog1 (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class ,(mapcar (lambda (s) (list* (car s) @@ -120,8 +120,7 @@ ) )) )) - slotspecs) - (find-class ',class)))) + slotspecs)))) (defun defmd-canonicalize-slot (slotname &key

1 0

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

17 Mar '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4567 Modified Files: CELTK.lpr composites.lisp run.lisp tk-object.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/01/03 20:23:30 1.23 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/17 20:33:57 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -32,7 +32,8 @@ (make-instance 'module :name "run.lisp") (make-instance 'module :name "ltktest-ci.lisp") (make-instance 'module :name "lotsa-widgets.lisp") - (make-instance 'module :name "demos.lisp")) + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name "andy-expander.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name @@ -113,7 +114,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::tk-test + :on-initialization 'celtk::test-andy-expander :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/composites.lisp 2008/01/03 20:23:30 1.25 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/03/17 20:33:57 1.26 @@ -146,6 +146,9 @@ :width (c?n 800) :height (c?n 600)) +(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 (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value))))) --- /project/cells/cvsroot/Celtk/run.lisp 2008/01/03 20:23:30 1.26 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/03/17 20:33:57 1.27 @@ -28,7 +28,7 @@ (defparameter *ctk-dbg* nil) (defun run-window (root-class &optional (resetp t) &rest window-initargs) - (declare (ignorable root-class)) + (assert (symbolp root-class)) (setf *tkw* nil) (when resetp (cells-reset 'tk-user-queue-handler)) @@ -80,13 +80,13 @@ ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") - (bwhen (ifn (start-up-fn *tkw*)) - (funcall ifn *tkw*)) - (CG:kill-splash-screen) - (tcl-do-one-event-loop) - ) - - + (block nil + (bwhen (ifn (start-up-fn *tkw*)) + (funcall ifn *tkw*)) + (CG:kill-splash-screen) + (unless #-rms-s3 nil #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" ) + (not (eval (read-from-string bail$)))) + (tcl-do-one-event-loop)))) (defun ensure-destruction (w key) (declare (ignorable key)) @@ -126,11 +126,8 @@ (:configurenotify (setf (^width) (parse-integer (tk-eval "winfo width ."))) (with-cc :height - (setf (^height) (parse-integer (tk-eval "winfo height .")))) - ) + (setf (^height) (parse-integer (tk-eval "winfo height ."))))) - - (:destroyNotify (pushnew *tkw* *windows-destroyed*) (ensure-destruction *tkw* :destroyNotify)) @@ -159,7 +156,7 @@ (window-destroyed (ensure-destruction *tkw* :window-destroyed)) - + (otherwise (give-to-window))))) (otherwise (give-to-window))) @@ -177,7 +174,6 @@ (loop while (plusp (tk-get-num-main-windows)) do (loop until (zerop (Tcl_DoOneEvent 2)) ;; 2== TCL_DONT_WAIT do (when (and *ctk-dbg* (> (- (now) *doe-last*) 1)) - (trcx doe-loop) (setf *doe-last* (now))) (app-idle *app*)) (app-idle *app*) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/01/03 20:23:30 1.13 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/17 20:33:57 1.14 @@ -105,8 +105,8 @@ (defun tk-config-option (self slot-name) (second (assoc slot-name (tk-class-options self)))) -(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp) - (declare (ignorable old-value)) +(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp cell) + (declare (ignorable old-value cell)) (when old-value-boundp ;; initial propagation to Tk happens during make-tk-instance (bwhen (tco (tk-config-option self slot-name)) ;; (get slot-name 'tk-config-option)) (tk-configure self (string tco) (or new-value ""))))) --- /project/cells/cvsroot/Celtk/togl.lisp 2008/01/03 20:23:30 1.27 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/17 20:33:57 1.28 @@ -198,11 +198,10 @@ ;;(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)))) -;;; ^^^^^ above two needed only for cello ^^^^^^ -;;; + (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) + ;;; ^^^^^ above two needed only for cello ^^^^^^ + ;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) --- /project/cells/cvsroot/Celtk/widget.lisp 2008/01/03 20:23:30 1.21 +++ /project/cells/cvsroot/Celtk/widget.lisp 2008/03/17 20:33:57 1.22 @@ -31,9 +31,15 @@ xwin)))) (defun tkwin-widget (tkwin) - (assert *tkw*) - (assert (tkwins *tkw*) () "Widget hash NIL for *tkw* ~a" *tkw*) - (gethash (pointer-address tkwin) (tkwins *tkw*))) +;;; (assert *tkw*) +;;; (assert (tkwins *tkw*) () "Widget hash NIL for *tkw* ~a" *tkw*) +;;; (gethash (pointer-address tkwin) (tkwins *tkw*)) + (if (and *tkw* (tkwins *tkw*)) + (gethash (pointer-address tkwin) (tkwins *tkw*)) + (unless .stopped + (trc "tkw issues" *tkw* (when *tkw* (tkwins *tkw*))) + .stop + nil))) (defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. (when (plusp xwin) @@ -132,7 +138,7 @@ (bif (self (tkwin-widget client-data)) (widget-event-handle self xe) ;; sometimes I hit the next branch restarting after crash.... - (trc "widget-event-handler > no widget for tkwin ~a" client-data)) + (trc nil "widget-event-handler > no widget for tkwin ~a" client-data)) #+nahhh(handler-case (bif (self (tkwin-widget client-data)) (widget-event-handle self xe)

1 0