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)