[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Mon Mar 17 20:33:58 UTC 2008
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)
More information about the Cells-cvs
mailing list