I'm happy to report that the one-button-window test appears to run correctly. I've attached the appropriate patch.
(The patch works from the current version in CVS, so it includes the previous changes)
Additionally, menu-button-test, spinbox-test,
lotsa-widgets almost works. When I selected File|Quit, it quit my lisp process too. Other than that, it appears okay.
I can't find gears, and ltktest-cells-inside doesn't work.
One major change: SBCL has a special type for pointers. This type does not work in hashtables, so the integer address must be stored there.
Also, I managed to get anonymous CVS working.
Enjoy, -Stu Glaser
Index: composites.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/composites.lisp,v retrieving revision 1.8 diff -u -r1.8 composites.lisp --- composites.lisp 15 May 2006 05:15:37 -0000 1.8 +++ composites.lisp 24 May 2006 06:19:00 -0000 @@ -85,8 +85,8 @@ #+wishful (ewish :initarg :ewish :accessor ewish :initform nil :cell nil) ;; vestigial? (title$ :initarg :title$ :accessor title$ :initform (c? (string-capitalize (class-name (class-of self))))) - (dictionary :initarg :dictionary :initform (make-hash-table :test 'string-equal) :accessor dictionary) - (tkwins :initform (make-hash-table) :reader tkwins) + (dictionary :initarg :dictionary :initform (make-hash-table :test 'equalp) :accessor dictionary) + (tkwins :initform (make-hash-table) :reader tkwins) ; Stores integers corresponding to addresses (xwins :initform (make-hash-table) :reader xwins) (callbacks :initarg :callbacks :accessor callbacks :initform (make-hash-table :test #'eq)) Index: run.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/run.lisp,v retrieving revision 1.11 diff -u -r1.11 run.lisp --- run.lisp 17 May 2006 00:40:55 -0000 1.11 +++ run.lisp 24 May 2006 06:19:00 -0000 @@ -39,7 +39,7 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") - (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) 42 0) + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
(with-integrity () (setf *tkw* (make-instance root-class)) @@ -51,7 +51,7 @@
(tcl-do-one-event-loop))
-(defcallback main-window-proc :void ((client-data :int)(xe :pointer)) +(defcallback main-window-proc :void ((client-data :pointer)(xe :pointer)) (declare (ignore client-data)) (when (eq (xevent-type xe) :virtualevent) (bwhen (n$ (xsv name xe)) Index: tk-events.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/tk-events.lisp,v retrieving revision 1.3 diff -u -r1.3 tk-events.lisp --- tk-events.lisp 17 May 2006 00:40:55 -0000 1.3 +++ tk-events.lisp 24 May 2006 06:19:00 -0000 @@ -6,13 +6,13 @@
(defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void (tcl-idle-proc :pointer) - (client-data :int)) + (client-data :pointer))
(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer (interp :pointer) (cmdName :string) (proc :pointer) - (client-data :int) + (client-data :pointer) (delete-proc :pointer))
(defcfun ("Tcl_SetResult" tcl-set-result) :void @@ -23,7 +23,7 @@ (defcfun ("Tcl_GetString" tcl-get-string) :string (tcl-obj :pointer))
-(defcallback tcl-idle-proc :void ((client-data :int)) +(defcallback tcl-idle-proc :void ((client-data :pointer)) (unless (c-stopped) (print (list :idle-proc :client-data client-data))))
@@ -35,7 +35,7 @@ (tkwin :pointer) (mask :int) (proc :pointer) - (client-data :int)) + (client-data :pointer))
(defcenum tk-event-type ;; do not try to generate masks from these! "Ok for interpreting type field in event, but not for (expt 2 etype) to get mask" @@ -130,7 +130,7 @@
;; sample event handler
-(defcallback dump-event :void ((client-data :int)(xe :pointer)) +(defcallback dump-event :void ((client-data :pointer)(xe :pointer)) (call-dump-event client-data xe))
(defun call-dump-event (client-data xe) @@ -149,7 +149,7 @@ (xwin-widget (xsv root-window xe)) (xwin-widget (xsv sub-window xe)))))
- (trc " > data" (when (plusp (xsv user-data xe)) + (trc " > data" (when (not (null-pointer-p (xsv user-data xe))) (tcl-get-string (xsv user-data xe)))))))
Index: tk-interp.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/tk-interp.lisp,v retrieving revision 1.9 diff -u -r1.9 tk-interp.lisp --- tk-interp.lisp 16 May 2006 21:17:15 -0000 1.9 +++ tk-interp.lisp 24 May 2006 06:19:01 -0000 @@ -36,15 +36,22 @@
(define-foreign-library Tcl (:darwin (:framework "Tcl")) - (:windows (:or "/tcl/bin/Tcl85.dll"))) + (:windows (:or "/tcl/bin/Tcl85.dll")) + (:unix "libtcl.so") + (t (:default "libtcl"))) (define-foreign-library Tk (:darwin (:framework "Tk")) - (:windows (:or "/tcl/bin/tk85.dll"))) + (:windows (:or "/tcl/bin/tk85.dll")) + (:unix "libtk.so") + (t (:default "libtk")))
;; Togl (define-foreign-library Togl (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) - (:windows (:or "/tcl/lib/togl/togl17.dll"))) + (:windows (:or "/tcl/lib/togl/togl17.dll")) + (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) + +(use-foreign-library Togl)
(defctype tcl-retcode :int)
@@ -233,7 +240,8 @@
(defun argv0 () #+allegro (sys:command-line-argument 0) - #+lispworks (nth 0 (io::io-get-command-line-arguments))) + #+lispworks (nth 0 (io::io-get-command-line-arguments)) + #+sbcl (nth 0 sb-ext:*posix-argv*))
(defun tk-interp-init-ensure () (unless *initialized* Index: togl.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/togl.lisp,v retrieving revision 1.5 diff -u -r1.5 togl.lisp --- togl.lisp 15 May 2006 09:00:47 -0000 1.5 +++ togl.lisp 24 May 2006 06:19:01 -0000 @@ -115,7 +115,7 @@ (callback :pointer)) (defcallback ,(intern cb$) :void ((,ptr-var :pointer)) (unless (c-stopped) - (let ((,self-var (or (gethash ,ptr-var (tkwins *tkw*)) + (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*)) (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))) ,@preamble (,(intern uc$) ,self-var)))) Index: widget.lisp =================================================================== RCS file: /project/cells/cvsroot/Celtk/widget.lisp,v retrieving revision 1.8 diff -u -r1.8 widget.lisp --- widget.lisp 17 May 2006 00:40:55 -0000 1.8 +++ widget.lisp 24 May 2006 06:19:01 -0000 @@ -35,11 +35,13 @@ xwin))))
(defun tkwin-widget (tkwin) - (gethash tkwin (tkwins *tkw*))) + (gethash (pointer-address tkwin) (tkwins *tkw*)))
(defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. (when (plusp xwin) (or (gethash xwin (xwins *tkw*)) + ;; Next block might need changing for SBCL. (tkwins *tkw*) does NOT + ;; store pointers, so (cffi:pointer-address) should probably be called somewhere (loop for self being the hash-values of (tkwins *tkw*) using (hash-key tkwin) unless (xwin self) ;; we woulda found it by now @@ -78,14 +80,14 @@
(defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) - (assert (plusp self-tkwin)) + (assert (not (null-pointer-p self-tkwin))) (trc nil "setting up widget virtual-event handler" widget :tkwin self-tkwin) (tk-create-event-handler self-tkwin (apply 'foreign-masks-combine 'tk-event-mask masks) (get-callback callback-name) self-tkwin)))
-(defcallback widget-event-handler :void ((client-data :int)(xe :pointer)) +(defcallback widget-event-handler :void ((client-data :pointer) (xe :pointer)) (let ((self (tkwin-widget client-data))) (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) (bif (h (^event-handler)) @@ -97,7 +99,7 @@ (:default-initargs :command (c? (format nil "do-on-command ~a" (^path)))))
-(defcallback do-on-command :int ((client-data :int)(interp :pointer)(argc :int)(argv :pointer)) +(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) (declare (ignore client-data)) (destructuring-bind (path &rest args) (loop for argn upfrom 1 below argc @@ -122,7 +124,7 @@ (let ((tkwin (or (tkwin self) (setf (tkwin self) (tk-name-to-window *tki* (^path) (tk-main-window *tki*)))))) - (setf (gethash tkwin (tkwins .tkw)) self))) + (setf (gethash (pointer-address tkwin) (tkwins .tkw)) self)))
(defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self)