Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv27365/cells-gtk
Modified Files: cells-gtk.lisp tree-view.lisp widgets.lisp Log Message: Both AllegroCL and Lispworks now run Cells-gtk on win32. Pretty much. All of Vasilis's examples work, with one known fault in Lispworks and bigger problems in AllegroCL in a couple of examples. This means a huge amount works, because vasilis did an extraordinary coverage of Gtk2 in his examples. I be moving on to see if I can score OS/X. Date: Thu Dec 16 05:51:11 2004 Author: ktilton
Index: root/cells-gtk/cells-gtk.lisp diff -u root/cells-gtk/cells-gtk.lisp:1.2 root/cells-gtk/cells-gtk.lisp:1.3 --- root/cells-gtk/cells-gtk.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/cells-gtk.lisp Thu Dec 16 05:51:11 2004 @@ -25,11 +25,7 @@
(defun gtk-tree-store-set-kids (model val-tree par-iter index column-types items-factory &optional path) - (with-foreign-object (iter 'gtk-tree-iter) - (setf (get-slot-value iter 'gtk-tree-iter 'stamp) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data2) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data3) 0) + (with-tree-iter (iter) (gtk-ffi::gtk-tree-store-append model iter par-iter) (gtk-ffi::gtk-tree-store-set model iter column-types
Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.4 root/cells-gtk/tree-view.lisp:1.5 --- root/cells-gtk/tree-view.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/tree-view.lisp Thu Dec 16 05:51:11 2004 @@ -102,24 +102,25 @@
(ff-defun-callable :cdecl :int tree-view-select-handler ((column-widget (* :void)) (event (* :void)) (data (* :void))) - (let ((tree-view (gtk-object-find column-widget t))) + (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) - (funcall cb tree-view column-widget event data)))) + (funcall cb tree-view column-widget event data)) + (trc "dude, clean up old widgets after runs" column-widget)))
(def-c-output on-select ((self tree-view)) (when new-value (trc "output on-select" self new-value) (let* ((selected-widget (gtk-tree-view-get-selection (id self))) - (selected-clos (gtk-object-find selected-widget nil))) - (unless selected-clos - (trc "whoa!!! no clos for selected" self selected-widget)) - (when selected-clos - (assert (eql self selected-clos)) - (gtk-object-store selected-widget self) ;; tie column widg to clos tree-view - (callback-register self :on-select new-value) - (let ((cb (ff-register-callable 'tree-view-select-handler))) - (trc "tree-view on-select pcb:" cb selected-widget "changed") - (gtk-signal-connect selected-widget "changed" cb)))))) + (selected-clos (gtk-object-find selected-widget))) + (if (not selected-clos) + (trc "whoa!!! no clos for selected" self selected-widget) + (when selected-clos + (assert (eql self selected-clos)) + (gtk-object-store selected-widget self) ;; tie column widg to clos tree-view + (callback-register self :on-select new-value) + (let ((cb (ff-register-callable 'tree-view-select-handler))) + (trc "tree-view on-select pcb:" cb selected-widget "changed") + (gtk-signal-connect selected-widget "changed" cb)))))))
(defmodel listbox (tree-view) () @@ -171,13 +172,15 @@ (append (column-types self) (list :string)) (items-factory self)))))
-(ff-defun-callable :cdecl :int tree-view-render-call-callback +(ff-defun-callable :cdecl :int tree-view-render-cell-callback ((tree-column (* :void)) (cell-renderer (* :void)) (tree-model (* :void)) (iter (* :void)) (data (* :void))) - (let* ((self (gtk-object-find tree-column t)) - (cb (callback-recover self :render-cell))) - (assert cb () "No :render-cell callback for ~a" self) - (funcall cb tree-column cell-renderer tree-model iter data))) + (bif (self (gtk-object-find tree-column)) + (let ((cb (callback-recover self :render-cell))) + (assert cb () "No :render-cell callback for ~a" self) + (funcall cb tree-column cell-renderer tree-model iter data)) + (trc "dude, clean up old widgets from prior runs" tree-column)) + 1)
(def-c-output columns ((self tree-view)) (when new-value @@ -189,7 +192,7 @@ (t (gtk-cell-renderer-text-new))) do (gtk-tree-view-column-pack-start (id col) renderer t) (gtk-tree-view-column-set-cell-data-func (id col) renderer - (let ((cb (ff-register-callable 'tree-view-render-call-callback))) + (let ((cb (ff-register-callable 'tree-view-render-cell-callback))) (trc "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos
Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.4 root/cells-gtk/widgets.lisp:1.5 --- root/cells-gtk/widgets.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/widgets.lisp Thu Dec 16 05:51:11 2004 @@ -80,11 +80,11 @@ (when *gtk-objects* (let ((clos-widget (gethash hash-id *gtk-objects*))) (when (and must-find-p (not clos-widget)) - (format t "~>k-object-find> ID ~a not found!!!!!!!" hash-id) + (format t "~>k.object.find> ID ~a not found!!!!!!!" hash-id) (maphash (lambda (key value) (format t "~& known: ~a | ~a" key value)) *gtk-objects*) - (break "gtk-object-find ID not found ~a" hash-id)) + (break "gtk.object.find ID not found ~a" hash-id)) clos-widget)))
;; ----- fake callbackable closures ------------ @@ -120,9 +120,10 @@ `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) ((widget (* :void)) (event (* :void)) (data (* :void))) ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) - (let ((self (gtk-object-find widget t))) + (bif (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) - (funcall cb self widget event data))))) + (funcall cb self widget event data)) + (trc "unknown widget. from prior run. clean up on errors" widget))))
(def-gtk-event-handler clicked) (def-gtk-event-handler changed)