- cells-gtk-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp
by ktilton＠common-lisp.net 22 Dec '04

22 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv13131/gtk-ffi Modified Files: gtk-ffi.lisp gtk-utilities.lisp Log Message: Fix for Lispworks for, inter alia, GDK-BUTTON-EVENT-HANDLER Date: Wed Dec 22 17:23:54 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.6 root/gtk-ffi/gtk-ffi.lisp:1.7 --- root/gtk-ffi/gtk-ffi.lisp:1.6 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-ffi.lisp Wed Dec 22 17:23:53 2004 @@ -22,7 +22,7 @@ (in-package :gtk-ffi) -(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* void))) +(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* :void))) (defconstant c-null-int #+clisp nil #-clisp (make-null-pointer :int)) (defvar *gtk-debug* nil) @@ -61,34 +61,37 @@ (:gdk "libgdk-win32-2.0-0.dll") (:gtk "libgtk-win32-2.0-0.dll"))) #-(or win32 mswindows) - (ecase lib - (:gobject "libgobject-2.0.so") - (:glib "libglib-2.0.so") - (:gthread "libgthread-2.0.so") - (:gdk "libgdk-x11-2.0.so") - (:gtk "libgtk-x11-2.0.so"))) + (concatenate 'string + "/usr/lib" + (ecase lib + (:gobject "libgobject-2.0.so") + (:glib "libglib-2.0.so") + (:gthread "libgthread-2.0.so") + (:gdk "libgdk-x11-2.0.so") + (:gtk "libgtk-x11-2.0.so")))) (defun ffi-to-uffi-type (clisp-type) #+clisp clisp-type #-clisp (if (consp clisp-type) (mapcar 'ffi-to-uffi-type clisp-type) (case clisp-type - (uint :UNSIGNED-INT) - (c-pointer :pointer-void) - (c-ptr-null '*) - (c-array-ptr '*) - (c-ptr '*) - (c-string :cstring) - (sint32 :int) - (uint32 :unsigned-int) - (uint8 :unsigned-byte) - (boolean :unsigned-int) - (ulong :unsigned-long) - (int :int) - (long :long) - (single-float :float) - (double-float :double) - (otherwise clisp-type)))) + ((nil) :void) + (uint :UNSIGNED-INT) + (c-pointer :pointer-void) + (c-ptr-null '*) + (c-array-ptr '*) + (c-ptr '*) + (c-string :cstring) + (sint32 :int) + (uint32 :unsigned-int) + (uint8 :unsigned-byte) + (boolean :unsigned-int) + (ulong :unsigned-long) + (int :int) + (long :long) + (single-float :float) + (double-float :double) + (otherwise clisp-type)))) #-clisp (defun ffi-to-native-type (ffi-type) Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.4 root/gtk-ffi/gtk-utilities.lisp:1.5 --- root/gtk-ffi/gtk-utilities.lisp:1.4 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-utilities.lisp Wed Dec 22 17:23:53 2004 @@ -74,14 +74,14 @@ (gdk-threads-leave))) (ffx:ff-defun-callable :cdecl :int button-press-event-handler - ((widget (* :void)) (signal (* :void)) (data (* :void))) - (declare (ignore data)) - (let ((event (uffi:deref-pointer signal :int))) + ((widget (* :void)) (signal (* gdk-event-button)) (data (* :void))) + (declare (ignorable data)) + (let ((event (gdk-event-button-type signal))) (when (eql (event-type event) :button_press) (when (= (gdk-event-button-button signal) 3) - (gtk-menu-popup widget nil nil nil nil - (gdk-event-button-button signal) - (gdk-event-button-time signal)))))) + (gtk-menu-popup widget nil nil nil nil 3 + (gdk-event-button-time signal))))) + 1) (defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" @@ -157,7 +157,7 @@ (loop for col from 0 for data in data-lst for type in types-lst - do (print (list :tree-store-set value type (as-gtk-type type))) + do ;; (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type (:date 'float) @@ -186,27 +186,6 @@ (:font (list "font" 'c-string val)) (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) - -(defun make-address-pointer (addr type) - #+(or allegro mcl) (declare (ignore type)) - (assert (or (null addr) (numberp addr))) - (if addr - (progn - #+(or cmu scl) - (alien:sap-alien (system:int-sap addr) - (* (convert-from-uffi-type type :type))) - #+sbcl - (sb-alien:sap-alien (sb-sys:int-sap addr) - (* (convert-from-uffi-type type :type))) - #+lispworks - (fli:make-pointer - :address addr - :type (convert-from-uffi-type type :type)) - #+allegro addr - #+mcl - (ccl:%int-to-ptr addr) - ) - c-null)) (uffi:def-struct all-types (:string :cstring)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/buttons.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp
by ktilton＠common-lisp.net 22 Dec '04

22 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv13131/cells-gtk Modified Files: buttons.lisp gtk-app.lisp menus.lisp tree-view.lisp Log Message: Fix for Lispworks for, inter alia, GDK-BUTTON-EVENT-HANDLER Date: Wed Dec 22 17:23:50 2004 Author: ktilton Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.4 root/cells-gtk/buttons.lisp:1.5 --- root/cells-gtk/buttons.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/buttons.lisp Wed Dec 22 17:23:50 2004 @@ -43,7 +43,7 @@ (def-c-output stock ((self button)) (when new-value (setf (label self) (string-downcase (format nil "gtk-~a" new-value))) - (trc "stock" (label self)) (force-output) + (trc nil "c-outputting stock" (label self)) (force-output) (setf (use-stock self) t))) (def-widget toggle-button (button) @@ -52,9 +52,9 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - (print (list :toggle-button :on-toggled-cb widget)) + ;;(print (list :toggle-button :on-toggled-cb widget)) (let ((state (gtk-toggle-button-get-active widget))) - (print (list :toggledstate state)) + ;;(print (list :toggledstate state)) (setf (md-value self) state)))) #+test @@ -88,7 +88,7 @@ c-null (id (first (kids (fm-parent self)))))))) :on-toggled (callback (widget event data) - (print (list :radio-button widget event data)) + ;;(print (list :radio-button widget event data)) (let ((state (gtk-toggle-button-get-active widget))) (setf (md-value self) state)))) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.4 root/cells-gtk/gtk-app.lisp:1.5 --- root/cells-gtk/gtk-app.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/gtk-app.lisp Wed Dec 22 17:23:50 2004 @@ -84,7 +84,7 @@ (gtk-main))))) (defvar *gtk-global-callbacks* nil) -(defvar *gtk-loaded* nil) +(defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own (defun gtk-reset () (cell-reset) @@ -104,12 +104,20 @@ (defun cells-gtk-init () (gtk-reset) + #-cmu (unless *gtk-loaded* (loop for lib in '(:gthread :glib :gobject :gdk :gtk) do (assert (uffi:load-foreign-library (gtk-ffi::libname lib) :force-load #+lispworks t #-lispworks nil :module (string lib))) finally (setf *gtk-loaded* t)))) + +#+cmu +(loop for lib in '(:gthread :glib :gobject :gdk :gtk) + do (assert (uffi:load-foreign-library (gtk-ffi::libname lib) + :force-load #+lispworks t #-lispworks nil + :module (string lib))) + finally (setf *gtk-loaded* t)) (eval-when (compile load eval) (export '(gtk-app gtk-reset cells-gtk-init title icon tooltips tooltips-enable tooltips-delay Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.4 root/cells-gtk/menus.lisp:1.5 --- root/cells-gtk/menus.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/menus.lisp Wed Dec 22 17:23:50 2004 @@ -196,16 +196,9 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - (trc "on-toggled" self widget event data) + (trc nil "on-toggled" self widget event data) (let ((state (gtk-check-menu-item-get-active widget))) (setf (md-value self) state)))) - -#+not -(DEF-GTK WIDGET CHECK-MENU-ITEM (MENU-ITEM) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) - (ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED - (CALLBACK (WIDGET EVENT DATA) (TRC "on-toggled" SELF WIDGET EVENT DATA) - (LET ((STATE (GTK-CHECK-MENU-ITEM-GET-ACTIVE WIDGET))) - (SETF (MD-VALUE SELF) STATE)))) (def-c-output init ((self check-menu-item)) (setf (active self) new-value) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.5 root/cells-gtk/tree-view.lisp:1.6 --- root/cells-gtk/tree-view.lisp:1.5 Thu Dec 16 05:51:11 2004 +++ root/cells-gtk/tree-view.lisp Wed Dec 22 17:23:50 2004 @@ -109,11 +109,11 @@ (def-c-output on-select ((self tree-view)) (when new-value - (trc "output on-select" self new-value) + (trc nil "output on-select" self new-value) (let* ((selected-widget (gtk-tree-view-get-selection (id self))) (selected-clos (gtk-object-find selected-widget))) (if (not selected-clos) - (trc "whoa!!! no clos for selected" self selected-widget) + (trc nil "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 @@ -193,7 +193,7 @@ (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-cell-callback))) - (trc "tree-view columns pcb:" cb (id col) :render-cell) + (trc nil "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos (nth pos (column-types self))

1 0

[cells-gtk-cvs] CVS update: root/INSTALL.TXT root/load.lisp
by ktilton＠common-lisp.net 16 Dec '04

16 Dec '04

Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv30140 Modified Files: INSTALL.TXT load.lisp Log Message: Adjust INSTALL.TXT and Load.lisp in UFFI version to conform with UFFI version Date: Thu Dec 16 17:36:26 2004 Author: ktilton Index: root/INSTALL.TXT diff -u root/INSTALL.TXT:1.1 root/INSTALL.TXT:1.2 --- root/INSTALL.TXT:1.1 Fri Nov 19 00:39:51 2004 +++ root/INSTALL.TXT Thu Dec 16 17:36:25 2004 @@ -1,36 +1,39 @@ +############################################################################################################# +The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and +call it Hello-C, but the idea is the same: portable FFI.) + +For the original version by Vasilis Margioulas, which uses native CLisp FFI to +good advantage, grab this: + + http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.… + +...and follow the INSTALL.TXT in that. + +############################################################################################################## + Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.… +Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.ta… Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz… On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zi… -[kenny says: I had to add the gtk libs to my path variable: +Add the gtk libs to your PATH variable: Start>Settings>Control Panel>System>Advanced>Environment Variables> Then select PATH and hit "Edit". Append to existing value: "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values... -// eokenny] - -Edit load.lisp and adjust the paths. - -CL> (load "load.lisp") - -For a sample application - -CL> (cells-gtk:start-app 'test-gtk::test-gtk) -[kenny says: I added to load.lisp a defun of GTK-DEMO which does the above -//eokenny] +Edit load.lisp and follow the instructions there. No, you cannot just load it. -Note: On windows under emacs with slime, gtk window dont popups. You must start the application from a dos prompt. +Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt. Tested on: - Windows xp with gtk 2.4.10 and clisp 2.33 - Linux (fedora 2) with clisp 2.33 + Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal Known bugs: On Windows: Clisp crash if Index: root/load.lisp diff -u root/load.lisp:1.3 root/load.lisp:1.4 --- root/load.lisp:1.3 Tue Dec 14 05:02:12 2004 +++ root/load.lisp Thu Dec 16 17:36:25 2004 @@ -1,14 +1,29 @@ (in-package :cl-user) +#| Step One: Get ASDF into the game. + + Obviously not necessary if you always have that + loaded. Note that you will have to adjust the pathname to point to where you + have ASDF.lisp. + +|# + #-asdf -(eval-when (compile load eval) - #+lispworks - (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) +(eval-when (compile load eval) (load (make-pathname :directory '(:absolute "00" "root") :name "asdf" :type "lisp"))) -(progn ;; setup +#| Step Two: Tell ASDF where to find stuff + + Again, adjust pathnames to match the locations of the various bits of source + +|# + +(progn + #+lispworks + (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) + (push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) asdf:*central-registry*) @@ -36,13 +51,22 @@ *cells-gtk-root*) asdf:*central-registry*)) -(Asdf:operate 'asdf:load-op :utils-kt :force nil) -(Asdf:operate 'asdf:load-op :cells :force nil) -(Asdf:operate 'asdf:load-op :hello-c :force nil) -(Asdf:operate 'asdf:load-op :gtk-ffi :force t) -(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +#| Step 3: Compile and load via ASDF + +; these are handy when one is first working up to getting things to build at all +; but the "test-gtk" ASDF has dependencies which will load everything else, so +; you can just execute that. +; +;(Asdf:operate 'asdf:load-op :utils-kt :force nil) +;(Asdf:operate 'asdf:load-op :cells :force nil) +;(Asdf:operate 'asdf:load-op :hello-c :force nil) +;(Asdf:operate 'asdf:load-op :gtk-ffi :force t) +;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +|# + (Asdf:operate 'asdf:load-op :test-gtk :force nil) -#+test +#+Step-4: + (test-gtk::gtk-demo)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp
by ktilton＠common-lisp.net 16 Dec '04

16 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv27365/gtk-ffi Modified Files: gtk-core.lisp gtk-ffi.lisp gtk-utilities.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:18 2004 Author: ktilton Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.1 root/gtk-ffi/gtk-core.lisp:1.2 --- root/gtk-ffi/gtk-core.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-core.lisp Thu Dec 16 05:51:17 2004 @@ -65,22 +65,33 @@ (g-type (:array :int 16))) (defmacro with-g-value ((var) &body body) - `(let ((,var (ffx:fgn-alloc 'g-value 1 :with-g-value ',var))) - (unwind-protect - (progn - (dotimes (n 16) - (setf (int-slot-indexed ,var 'g-value 'g-type n) 0)) - ,@body) - (ffx:fgn-free ,var)))) + `(call-with-g-value (lambda (,var) ,@body))) + +(defun call-with-g-value (fn) + (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) + (unwind-protect + (progn + (dotimes (n 16) + ;; (setf (int-slot-indexed ,var 'g-value 'g-type n) 0) + (let ((gv (ff-elt gva 'g-value 0))) + (let ((ns (get-slot-pointer gv 'g-value 'g-type))) + #+lispworks (setf (fli:foreign-aref ns n) 0) + #-lispworks (setf (deref-array ns '(:array :int) n) 0)))) + (funcall fn gva)) + (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value)) -(progn - (def-function ("g_value_init" g_value_init) ((value :pointer-void) (type :unsigned-long)) - :module :glib :call-direct t :returning :pointer-void) - (defun g-value-init (value type) - (g_value_init (or value c-null) type)) - (eval-when (compile load eval) (export 'g-value-init))) + +#+test +(def-gtk-lib-functions :gobject + (g-value-set-string ((value c-pointer) + (str c-string)))) + +#+test +(def-gtk-function :gobject g-value-set-string + :arguments ((value c-pointer) (str c-string)) + :return-type nil :call-direct t) (def-gtk-lib-functions :gobject ;; callbacks @@ -110,12 +121,12 @@ (g-object-set-property ((object c-pointer) (property-name c-string) (value c-pointer))) - #+above (g-value-init ((value c-pointer) + (g-value-init ((value c-pointer) (type ulong)) c-pointer) (g-value-unset ((value c-pointer))) (g-value-set-string ((value c-pointer) - (str c-pointer))) + (str c-string))) (g-value-set-int ((value c-pointer) (int int))) (g-value-set-long ((value c-pointer) Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.5 root/gtk-ffi/gtk-ffi.lisp:1.6 --- root/gtk-ffi/gtk-ffi.lisp:1.5 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.lisp Thu Dec 16 05:51:17 2004 @@ -316,6 +316,14 @@ (user-data2 c-pointer) (user-data3 c-pointer)) +(defmacro with-tree-iter ((iter-var) &body body) + `(with-foreign-object (,iter-var 'gtk-tree-iter) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'stamp) 0) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data2) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data3) c-null) + ,@body)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defun as-gtk-type-name (type) @@ -342,7 +350,7 @@ (defun col-type-to-ffi-type (col-type) - (cdr (assoc col-type '((:string . c-pointer) + (cdr (assoc col-type '((:string . c-string) ;;2004:12:15-00:17 was c-pointer (:icon . c-pointer) (:boolean . boolean) (:int . int) @@ -369,3 +377,5 @@ (export '(uint c-pointer c-ptr-null c-array-ptr c-ptr c-string sint32 uint32 uint8 boolean ulong int long single-float double-float otherwise *gtk-debug* col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter))) + + Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.3 root/gtk-ffi/gtk-utilities.lisp:1.4 --- root/gtk-ffi/gtk-utilities.lisp:1.3 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-utilities.lisp Thu Dec 16 05:51:17 2004 @@ -39,13 +39,9 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil) -(defun wrap-func (func-address) - (or func-address 0) - ;;(assert (or (null func-address) (numberp func-address))) - #+nahh - (if func-address - (uffi:make-pointer func-address '(* :void)) - c-null)) +(defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. + (or func-address 0)) + (defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) (g-signal-connect-closure widget signal @@ -53,16 +49,13 @@ (defun gtk-object-set-property (obj property val-type val) (with-g-value (value) - (let ((str-ptr (and (eql val-type 'c-string) (to-gtk-string val)))) (g-value-init value (value-type-as-int val-type)) (funcall (value-set-function val-type) - value - (or str-ptr val)) + value val) (g-object-set-property obj property value) - (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value))) (defun get-gtk-string (pointer) (with-foreign-object (bytes-written :int) @@ -144,16 +137,13 @@ (when str-ptr (free-cstring str-ptr))))) (defun gtk-list-store-set-items (store types-lst data-lst) - (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) (dolist (item data-lst) (gvi :pre-append) (gtk-list-store-append store iter) (gvi :pre-set) - (gtk-list-store-set store iter types-lst item)))) + (gtk-list-store-set store iter types-lst item) + (gvi :post-set)))) (defun gtk-tree-store-new (col-types) (let ((gtk-types (ffx:fgn-alloc :int (length col-types)))) @@ -167,8 +157,6 @@ (loop for col from 0 for data in data-lst for type in types-lst - for str-ptr = (when (find type '(:string :icon)) - (to-gtk-string data)) do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type @@ -177,10 +165,11 @@ (t type))) :gtk-ffi) value - (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) + (if (eql type :date) + (coerce data 'single-float) + data)) (gtk-tree-store-set-value tstore iter col value) - (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value)))) (defun gtk-tree-model-get-cell (model iter column-no cell-type) (with-foreign-object (item :pointer-void) @@ -198,41 +187,95 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) +(defun make-address-pointer (addr type) + #+(or allegro mcl) (declare (ignore type)) + (assert (or (null addr) (numberp addr))) + (if addr + (progn + #+(or cmu scl) + (alien:sap-alien (system:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+sbcl + (sb-alien:sap-alien (sb-sys:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+lispworks + (fli:make-pointer + :address addr + :type (convert-from-uffi-type type :type)) + #+allegro addr + #+mcl + (ccl:%int-to-ptr addr) + ) + c-null)) + +(uffi:def-struct all-types + (:string :cstring) + (:icon :cstring) + (:boolean :unsigned-int) + (:int :int) + (:long :long) + (:date :float) + (:float :float) + (:double :double)) + +(defmacro with-all-types ((var) &body body) + `(uffi:with-foreign-object (,var 'all-types) + (setf (get-slot-value ,var 'all-types :string) c-null + (get-slot-value ,var 'all-types :icon) c-null + (get-slot-value ,var 'all-types :boolean) 0 + (get-slot-value ,var 'all-types :int) 0 + (get-slot-value ,var 'all-types :long) 0 + (get-slot-value ,var 'all-types :date) 0f0 + (get-slot-value ,var 'all-types :float) 0f0 + (get-slot-value ,var 'all-types :double) 0d0) + ,@body)) + (defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - (declare (ignore col)) - #'(lambda (tree-column cell-renderer model iter data) - (DECLARE (ignore data)) - - (let ((return-buffer (ffx:fgn-alloc :int 16))) - (gtk-tree-model-get model iter tree-column - return-buffer -1) - (let* ((returned-value (deref-pointer-runtime-typed return-buffer - (ffi-to-uffi-type - (col-type-to-ffi-type col-type)))) - (item-value (case col-type - ((:string :icon) (convert-from-cstring returned-value)) - (:boolean (not (zerop returned-value))) - (otherwise returned-value)))) - (with-cstring (str (format nil "~a" - (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - item-value))) - (apply #'gtk-object-set-property cell-renderer - (case col-type - (:boolean (list "active" 'boolean item-value)) - (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-pointer str))))) - (when cell-attrib-f - (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do - (apply #'gtk-object-set-property cell-renderer property))) - (when (and (eql col-type :string) - (not (zerop returned-value))) - (uffi:free-foreign-object returned-value)) - (ffx:fgn-free return-buffer))))) + (lambda (tree-column cell-renderer model iter data) + (DECLARE (ignorable tree-column data)) + (ukt:trc nil "entering render cell callback" tree-column model) + (let ((return-buffer (ffx:fgn-alloc :int 16))) + (gtk-tree-model-get model iter col + return-buffer -1) + (let* ((returned-value (deref-pointer-runtime-typed return-buffer + (ffi-to-uffi-type + (col-type-to-ffi-type col-type)))) + (ret$ (when (find col-type '(:string :icon)) + (make-pointer returned-value :cstring))) + (item-value (case col-type + ((:string :icon) + #-lispworks (convert-from-cstring ret$) + #+lispworks (convert-from-foreign-string ret$ + :null-terminated-p t)) + (:boolean (not (zerop returned-value))) + (otherwise returned-value)))) + (ukt:trc nil "tv-render-cell: types, ret-value, item-value" + (List col-type (col-type-to-ffi-type col-type) (ffi-to-uffi-type + (col-type-to-ffi-type col-type))) + returned-value ret$ item-value) + (apply #'gtk-object-set-property cell-renderer + (case col-type + (:boolean (list "active" 'boolean item-value)) + (:icon (list "stock-id" 'c-string + (string-downcase (format nil "gtk-~a" item-value)))) + (t (list "text" 'c-string (if (eql col-type :date) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (truncate item-value)) + (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" + day month year hour min sec)) + (format nil "~a" item-value)))))) + (when cell-attrib-f + (ukt:trc nil "got cell-attrib-f" cell-attrib-f item-value) + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) + do (apply #'gtk-object-set-property cell-renderer property))) + (when ret$ + (ukt:trc nil "frreeing ret$" ret$) + (uffi:free-foreign-object ret$)) + (ukt:trc nil "frreeing return-buffer" return-buffer) + (ffx:fgn-free return-buffer))) + (ukt:trc nil "exiting render cell callback" tree-column model) + 1)) (defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser))) @@ -244,7 +287,7 @@ (eval-when (compile load eval) (export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property with-gtk-string get-gtk-string to-gtk-string - with-gdk-threads make-gtk-tree-iter + with-gdk-threads make-gtk-tree-iter with-tree-iter gtk-widget-set-popup gvi gtk-list-store-new gtk-list-store-set gtk-list-store-set-items gtk-tree-store-new gtk-tree-store-set gtk-tree-store-set-kids

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp
by ktilton＠common-lisp.net 16 Dec '04

16 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv27365/cells-gtk/test-gtk Modified Files: test-gtk.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:15 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.5 root/cells-gtk/test-gtk/test-gtk.lisp:1.6 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.5 Tue Dec 14 05:01:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Thu Dec 16 05:51:14 2004 @@ -17,7 +17,8 @@ "Display" "Layout" "Menus" "Textview" "Dialogs" "Addon" - "Entry" "Tree-view" + "Entry" + "Tree-view" ))) (list (mk-notebook :tab-labels nil #+not '("Buttons")

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
by ktilton＠common-lisp.net 16 Dec '04

16 Dec '04

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 "~&gtk-object-find> ID ~a not found!!!!!!!" hash-id) + (format t "~&gtk.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)

1 0

[cells-gtk-cvs] CVS update: root/load.lisp
by ktilton＠common-lisp.net 14 Dec '04

14 Dec '04

Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv11104 Modified Files: load.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:02:12 2004 Author: ktilton Index: root/load.lisp diff -u root/load.lisp:1.2 root/load.lisp:1.3 --- root/load.lisp:1.2 Sun Dec 5 07:33:21 2004 +++ root/load.lisp Tue Dec 14 05:02:12 2004 @@ -5,23 +5,22 @@ #+lispworks (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) - (load (make-pathname :directory '(:absolute "000000" "root") + (load (make-pathname :directory '(:absolute "00" "root") :name "asdf" :type "lisp"))) (progn ;; setup - (defparameter *utils-kt-path* "/cell-cultures/utils-kt/") - (defparameter *cells-path* "/cell-cultures/cells/") - (defparameter *cells-gtk-root* - (make-pathname :directory '(:absolute "000000" "root"))) - - (push (make-pathname :directory '(:absolute "000000" "uffi")) + (push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) + asdf:*central-registry*) + + (push (make-pathname :directory '(:absolute "cell-cultures" "cells")) asdf:*central-registry*) - (push *utils-kt-path* asdf:*central-registry*) - (push *cells-path* asdf:*central-registry*) - (push (make-pathname :directory '(:absolute "cell-cultures" "ffi-extender")) + (push (make-pathname :directory '(:absolute "cell-cultures" "hello-c")) asdf:*central-registry*) + (defparameter *cells-gtk-root* + (make-pathname :directory '(:absolute "00" "root"))) + (push (merge-pathnames (make-pathname :directory '(:relative "gtk-ffi")) *cells-gtk-root*) @@ -37,12 +36,11 @@ *cells-gtk-root*) asdf:*central-registry*)) -;(Asdf:operate 'asdf:load-op :utils-kt :force t) -;(Asdf:operate 'asdf:load-op :cells :force t) -;(Asdf:operate 'asdf:load-op :uffi :force t) -;(Asdf:operate 'asdf:load-op :ffi-extender :force t) -;(Asdf:operate 'asdf:load-op :gtk-ffi :force nil) -;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +(Asdf:operate 'asdf:load-op :utils-kt :force nil) +(Asdf:operate 'asdf:load-op :cells :force nil) +(Asdf:operate 'asdf:load-op :hello-c :force nil) +(Asdf:operate 'asdf:load-op :gtk-ffi :force t) +(Asdf:operate 'asdf:load-op :cells-gtk :force nil) (Asdf:operate 'asdf:load-op :test-gtk :force nil) #+test

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.asd root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-menu.lisp root/gtk-ffi/gtk-other.lisp root/gtk-ffi/gtk-utilities.lisp
by ktilton＠common-lisp.net 14 Dec '04

14 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv11104/gtk-ffi Modified Files: gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-menu.lisp gtk-other.lisp gtk-utilities.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:02:05 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.4 root/gtk-ffi/gtk-ffi.asd:1.5 --- root/gtk-ffi/gtk-ffi.asd:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.asd Tue Dec 14 05:02:05 2004 @@ -1,6 +1,6 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :uffi :ffi-extender) + :depends-on (:cells :hello-c) :components ((:file "gtk-ffi") (:file "gtk-core" :depends-on ("gtk-ffi")) Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.4 root/gtk-ffi/gtk-ffi.lisp:1.5 --- root/gtk-ffi/gtk-ffi.lisp:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lisp Tue Dec 14 05:02:05 2004 @@ -126,8 +126,7 @@ collect `(if ,(car arg) 1 0) into pass-args else if (eql 'c-pointer (cadr arg)) collect `(or ,(car arg) c-null) into pass-args - else - collect (car arg) into pass-args + else collect (car arg) into pass-args finally (return (list (mapcar 'list gsyms arg$s) pass-args))))) `(progn @@ -149,8 +148,9 @@ (if (eql return-type 'boolean) `(not (zerop ,bodyform)) bodyform)) - (print (list ,(symbol-name name) :after - ,@(mapcar 'car arguments))))) + (when *gtk-debug* + (print (list ,(symbol-name name) :after + ,@(mapcar 'car arguments)))))) (eval-when (compile load eval) (export ',name)))))) @@ -305,6 +305,10 @@ (type long) (val double-float) (val2 double-float)) + +(def-c-struct gslist + (data c-pointer) + (next c-pointer)) (def-c-struct gtk-tree-iter (stamp int) Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.2 root/gtk-ffi/gtk-ffi.lpr:1.3 --- root/gtk-ffi/gtk-ffi.lpr:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lpr Tue Dec 14 05:02:05 2004 @@ -7,13 +7,15 @@ (define-project :name :gtk-ffi :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "gtk-ffi.lisp") - (make-instance 'module :name "gtk-definitions.lisp") - (make-instance 'module :name "gtk-lib-gtk.lisp") + (make-instance 'module :name "gtk-core.lisp") + (make-instance 'module :name "gtk-button.lisp") + (make-instance 'module :name "gtk-list-tree.lisp") + (make-instance 'module :name "gtk-menu.lisp") + (make-instance 'module :name "gtk-tool.lisp") + (make-instance 'module :name "gtk-other.lisp") (make-instance 'module :name "gtk-utilities.lisp")) :projects (list (make-instance 'project-module :name - "c:\\000000\\uffi\\uffi") - (make-instance 'project-module :name - "c:\\cell-cultures\\ffi-extender\\ffi-extender")) + "c:\\cell-cultures\\hello-c\\hello-c")) :libraries nil :distributed-files nil :project-package-name :gtk-ffi Index: root/gtk-ffi/gtk-menu.lisp diff -u root/gtk-ffi/gtk-menu.lisp:1.1 root/gtk-ffi/gtk-menu.lisp:1.2 --- root/gtk-ffi/gtk-menu.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-menu.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,17 @@ (in-package :gtk-ffi) +(def-gtk-function :gtk gtk-check-menu-item-set-active :arguments + ((check-menu c-pointer) (active boolean)) + :return-type nil :call-direct t) + +#+test +(def-gtk-lib-functions :gtk + (gtk-check-menu-item-set-active ((check-menu c-pointer) + (active boolean)))) + + + (def-gtk-lib-functions :gtk ;;menu (gtk-menu-shell-append ((menu-shell c-pointer) @@ -76,7 +87,7 @@ c-pointer) (gtk-check-menu-item-new-with-label ((label c-string)) c-pointer) - (gtk-check-menu-item-set-active ((check-menu c-pointer) + #+above (gtk-check-menu-item-set-active ((check-menu c-pointer) (active boolean))) (gtk-check-menu-item-get-active ((check-menu c-pointer)) boolean) Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.1 root/gtk-ffi/gtk-other.lisp:1.2 --- root/gtk-ffi/gtk-other.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-other.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,7 @@ (in-package :gtk-ffi) + (def-gtk-lib-functions :gtk ;; main-loop (gtk-init ((argc (c-ptr-null int)) Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.2 root/gtk-ffi/gtk-utilities.lisp:1.3 --- root/gtk-ffi/gtk-utilities.lisp:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-utilities.lisp Tue Dec 14 05:02:05 2004 @@ -20,6 +20,7 @@ (in-package :gtk-ffi) (defun gtk-signal-connect (widget signal fun &key (after t) data destroy-data) + #+shhtk (print (list "passing fun to gtk-signal-connect" signal fun)) (g-signal-connect-data widget signal fun data destroy-data after)) (defun g-signal-connect-data (self detailed-signal c-handler data destroy-data after) @@ -28,9 +29,7 @@ (g_signal_connect_data self c-detailed-signal - (if c-handler - (uffi:make-pointer c-handler '(* :void)) - c-null) + (wrap-func c-handler) p4 (or destroy-data c-null) (if after 1 0))))) @@ -40,9 +39,17 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil) +(defun wrap-func (func-address) + (or func-address 0) + ;;(assert (or (null func-address) (numberp func-address))) + #+nahh + (if func-address + (uffi:make-pointer func-address '(* :void)) + c-null)) + (defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) (g-signal-connect-closure widget signal - (g-cclosure-new-swap fun data destroy-data) after)) + (g-cclosure-new-swap (wrap-func fun) data destroy-data) after)) (defun gtk-object-set-property (obj property val-type val) (with-g-value (value) @@ -85,7 +92,9 @@ (defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" - (ffx:ff-register-callable 'button-press-event-handler) + (let ((cbl (ffx:ff-register-callable 'button-press-event-handler))) + #+shhtk (print (list "gtk-widget-set-popup connecting callable" widget cbl)) + cbl) :data menu)) (defun gtk-list-store-new (col-types) @@ -160,7 +169,7 @@ for type in types-lst for str-ptr = (when (find type '(:string :icon)) (to-gtk-string data)) - do (print (list value type (as-gtk-type type))) + do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type (:date 'float)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-display.lisp root/cells-gtk/test-gtk/test-gtk.lisp root/cells-gtk/test-gtk/test-gtk.lpr
by ktilton＠common-lisp.net 14 Dec '04

14 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv11104/cells-gtk/test-gtk Modified Files: test-display.lisp test-gtk.lisp test-gtk.lpr Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:01:58 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.2 root/cells-gtk/test-gtk/test-display.lisp:1.3 --- root/cells-gtk/test-gtk/test-display.lisp:1.2 Sun Dec 5 07:33:31 2004 +++ root/cells-gtk/test-gtk/test-display.lisp Tue Dec 14 05:01:57 2004 @@ -1,5 +1,6 @@ (in-package :test-gtk) + (defmodel test-display (vbox) () (:default-initargs @@ -18,7 +19,7 @@ :ratio 1 :kids (list (mk-image :width 200 :height 250 - :filename "/000000/root/test-images/tst.gif"))) + :filename "/00/root/test-images/tst.gif"))) (mk-hseparator) (mk-hbox :kids (list @@ -32,7 +33,6 @@ (mk-button :label "Show in status bar" :on-clicked (callback (widget event data) - (format t "fraction is ~a" (fraction (fm-other :pbar))) (push-message (fm-other :statusbar) (format nil "~a" (fraction (fm-other :pbar)))))))) (mk-hbox Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.4 root/cells-gtk/test-gtk/test-gtk.lisp:1.5 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.4 Tue Dec 7 22:00:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Tue Dec 14 05:01:57 2004 @@ -11,12 +11,13 @@ ;;:tooltips-enable nil ;;dkwt :icon "test-images/small.png" :position :center - :splash-screen-image "/000000/root/test-images/splash.png" + :splash-screen-image "/00/root/test-images/splash.png" :width 550 :height 550 - :kids (let ((tabs '("Buttons" ;;"Display" "Layout" "Menus" - ;"Entry" - ;"Textview" "Dialogs" "Addon" - ;"Tree-view" + :kids (let ((tabs '("Buttons" + "Display" "Layout" + "Menus" + "Textview" "Dialogs" "Addon" + "Entry" "Tree-view" ))) (list (mk-notebook :tab-labels nil #+not '("Buttons") Index: root/cells-gtk/test-gtk/test-gtk.lpr diff -u root/cells-gtk/test-gtk/test-gtk.lpr:1.1 root/cells-gtk/test-gtk/test-gtk.lpr:1.2 --- root/cells-gtk/test-gtk/test-gtk.lpr:1.1 Tue Dec 7 22:00:58 2004 +++ root/cells-gtk/test-gtk/test-gtk.lpr Tue Dec 14 05:01:57 2004 @@ -17,9 +17,7 @@ (make-instance 'module :name "test-textview.lisp") (make-instance 'module :name "test-addon.lisp")) :projects (list (make-instance 'project-module :name - "c:\\00\\root\\cells-gtk\\cells-gtk") - (make-instance 'project-module :name - "c:\\cell-cultures\\ffi-extender\\ffi-extender")) + "c:\\00\\root\\cells-gtk\\cells-gtk")) :libraries nil :distributed-files nil :project-package-name :test-gtk

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/actions.lisp root/cells-gtk/buttons.lisp root/cells-gtk/cells-gtk.asd root/cells-gtk/entry.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/layout.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
by ktilton＠common-lisp.net 14 Dec '04

14 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv11104/cells-gtk Modified Files: actions.lisp buttons.lisp cells-gtk.asd entry.lisp gtk-app.lisp layout.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:01:51 2004 Author: ktilton Index: root/cells-gtk/actions.lisp diff -u root/cells-gtk/actions.lisp:1.1 root/cells-gtk/actions.lisp:1.2 --- root/cells-gtk/actions.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/actions.lisp Tue Dec 14 05:01:51 2004 @@ -48,7 +48,7 @@ (gtk-ffi::gtk-action-group-remove-action (id self) (id kid))) (dolist (kid new-value) (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid))) - (call-next-method)) + #+clisp (call-next-method)) (def-object ui-manager () ((action-groups :accessor action-groups :initform (c-in nil)) Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.3 root/cells-gtk/buttons.lisp:1.4 --- root/cells-gtk/buttons.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/buttons.lisp Tue Dec 14 05:01:51 2004 @@ -37,7 +37,8 @@ (def-c-output .kids ((self button)) (assert-bin self) (dolist (kid (kids self)) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-c-output stock ((self button)) (when new-value @@ -93,4 +94,5 @@ (def-c-output .md-value ((self radio-button)) (when (and new-value (upper self box)) - (setf (md-value (upper self box)) (md-name self)))) + (setf (md-value (upper self box)) (md-name self))) + #+clisp (call-next-method)) Index: root/cells-gtk/cells-gtk.asd diff -u root/cells-gtk/cells-gtk.asd:1.1 root/cells-gtk/cells-gtk.asd:1.2 --- root/cells-gtk/cells-gtk.asd:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/cells-gtk.asd Tue Dec 14 05:01:51 2004 @@ -5,14 +5,14 @@ :components ((:file "cells-gtk") (:file "widgets") - (:file "layout") - (:file "display") - (:file "buttons") - (:file "entry") - (:file "tree-view") - (:file "menus") - (:file "dialogs") - (:file "textview") - (:file "addon") + (:file "layout" :depends-on ("widgets")) + (:file "display" :depends-on ("widgets")) + (:file "buttons" :depends-on ("widgets")) + (:file "entry" :depends-on ("widgets")) + (:file "tree-view" :depends-on ("widgets")) + (:file "menus" :depends-on ("widgets")) + (:file "dialogs" :depends-on ("widgets")) + (:file "textview" :depends-on ("widgets")) + (:file "addon" :depends-on ("widgets")) (:file "gtk-app") -)) + )) Index: root/cells-gtk/entry.lisp diff -u root/cells-gtk/entry.lisp:1.2 root/cells-gtk/entry.lisp:1.3 --- root/cells-gtk/entry.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/entry.lisp Tue Dec 14 05:01:51 2004 @@ -23,6 +23,14 @@ (model) ()) +#+no +(def-gtk widget entry nil + ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) + (completion :accessor completion :initarg :completion :initform nil) + (text :accessor text :initarg :text :initform (c-in nil)) + (init :accessor init :initarg :init :initform nil)) + (editable has-frame max-length) (changed activate)) + (def-widget entry () ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) (completion :accessor completion :initarg :completion :initform nil) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.3 root/cells-gtk/gtk-app.lisp:1.4 --- root/cells-gtk/gtk-app.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/gtk-app.lisp Tue Dec 14 05:01:51 2004 @@ -97,6 +97,9 @@ *gtk-global-callbacks* 16)) (defun gtk-global-callback-funcall (n) + (trc nil "gtk-global-callback-funcall >" n + *gtk-global-callbacks* + (when n (aref *gtk-global-callbacks* n))) (funcall (aref *gtk-global-callbacks* n))) (defun cells-gtk-init () Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.2 root/cells-gtk/layout.lisp:1.3 --- root/cells-gtk/layout.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/layout.lisp Tue Dec 14 05:01:51 2004 @@ -30,7 +30,8 @@ (when new-value (dolist (kid new-value) (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))))) + (expand? kid) (fill? kid) (padding? kid))) + #+clisp (call-next-method))) (def-widget hbox (box) () () () @@ -83,7 +84,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method)) (def-widget vpaned () () () ()) @@ -96,7 +98,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method)) (def-widget frame () @@ -124,7 +127,8 @@ (def-c-output .kids ((self frame)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget aspect-frame (frame) ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -158,7 +162,8 @@ (def-c-output .kids ((self expander)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget scrolled-window () () @@ -173,7 +178,8 @@ (dolist (kid new-value) (if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal) (gtk-container-add (id self) (id kid)) - (gtk-scrolled-window-add-with-viewport (id self) (id kid))))) + (gtk-scrolled-window-add-with-viewport (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget notebook () ((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil) @@ -213,7 +219,8 @@ (loop for page from 0 to (length new-value) do (setf (current-page self) page)) (when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value))) - (setf (current-page self) (show-page self)))) + (setf (current-page self) (show-page self))) + #+clisp (call-next-method)) (def-widget alignment () ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -264,4 +271,5 @@ (def-c-output .kids ((self alignment)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.3 root/cells-gtk/menus.lisp:1.4 --- root/cells-gtk/menus.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/menus.lisp Tue Dec 14 05:01:51 2004 @@ -27,7 +27,9 @@ (changed) :new-tail '-text :on-changed (callback (widget event data) + (trc "combo-box onchanged cb" widget event data (id self)) (let ((pos (gtk-combo-box-get-active (id self)))) + (trc "combo-box pos" pos) (setf (md-value self) (and (not (= pos -1)) (nth pos (items self))))))) @@ -87,7 +89,8 @@ (assert-bin self) (when new-value (dolist (kid new-value) - (gtk-container-add (id self) (id kid))))) + (gtk-container-add (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget separator-tool-item (tool-item) () @@ -130,7 +133,8 @@ (def-c-output .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid))))) + (gtk-menu-shell-append (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget menu-bar (menu-shell) () () ()) @@ -192,9 +196,17 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) + (trc "on-toggled" self widget event data) (let ((state (gtk-check-menu-item-get-active widget))) (setf (md-value self) state)))) +#+not +(DEF-GTK WIDGET CHECK-MENU-ITEM (MENU-ITEM) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) + (ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED + (CALLBACK (WIDGET EVENT DATA) (TRC "on-toggled" SELF WIDGET EVENT DATA) + (LET ((STATE (GTK-CHECK-MENU-ITEM-GET-ACTIVE WIDGET))) + (SETF (MD-VALUE SELF) STATE)))) + (def-c-output init ((self check-menu-item)) (setf (active self) new-value) (setf (md-value self) new-value)) @@ -214,7 +226,8 @@ (def-c-output .md-value ((self radio-menu-item)) (when (and new-value (upper self menu-item)) - (setf (md-value (upper self menu-item)) (md-name self)))) + (setf (md-value (upper self menu-item)) (md-name self))) + #+clisp (call-next-method)) (def-widget image-menu-item (menu-item) ((stock :accessor stock :initarg :stock :initform nil) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.3 root/cells-gtk/tree-view.lisp:1.4 --- root/cells-gtk/tree-view.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/tree-view.lisp Tue Dec 14 05:01:51 2004 @@ -117,8 +117,9 @@ (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) - (gtk-signal-connect selected-widget "changed" - (ff-register-callable 'tree-view-select-handler)))))) + (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) () @@ -188,12 +189,13 @@ (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 - (progn + (let ((cb (ff-register-callable 'tree-view-render-call-callback))) + (trc "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos (nth pos (column-types self)) (getf (column-render self) pos))) - (ff-register-callable 'tree-view-render-call-callback)) + cb) nil nil) (gtk-tree-view-column-set-sort-column-id (id col) pos) (gtk-tree-view-insert-column (id self) (id col) pos)))) Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.3 root/cells-gtk/widgets.lisp:1.4 --- root/cells-gtk/widgets.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/widgets.lisp Tue Dec 14 05:01:51 2004 @@ -75,8 +75,6 @@ (break "gtk-object-store id ~a known as ~a, not forgettable ~a" hash-id known gtk-object))))) -#+shhh -(maphash (lambda (k v) (print (list k v))) *gtk-objects*) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) (when *gtk-objects* @@ -102,7 +100,11 @@ ; ------------------------------------------ (defmethod configure ((self gtk-object) gtk-function value) - (apply gtk-function (id self) (if (consp value) value (list value)))) + (apply gtk-function + (id self) + (if (consp value) + value + (list value)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun gtk-function-name (class option) @@ -117,17 +119,27 @@ (defmacro def-gtk-event-handler (event) `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) ((widget (* :void)) (event (* :void)) (data (* :void))) - (print (list :def-gtk-event-handler ,(symbol-name event))) + ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) (let ((self (gtk-object-find widget t))) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) (funcall cb self widget event data))))) (def-gtk-event-handler clicked) +(def-gtk-event-handler changed) +(def-gtk-event-handler activate) +(def-gtk-event-handler value-changed) +(def-gtk-event-handler day-selected) +(def-gtk-event-handler selection-changed) (def-gtk-event-handler toggled) (def-gtk-event-handler delete-event) - + (defparameter *widget-callbacks* (list (cons 'clicked (ff-register-callable 'clicked-handler)) + (cons 'changed (ff-register-callable 'changed-handler)) + (cons 'activate (ff-register-callable 'activate-handler)) + (cons 'value-changed (ff-register-callable 'value-changed-handler)) + (cons 'day-selected (ff-register-callable 'day-selected-handler)) + (cons 'selection-changed (ff-register-callable 'selection-changed-handler)) (cons 'toggled (ff-register-callable 'toggled-handler)) (cons 'delete-event (ff-register-callable 'delete-event-handler)))) @@ -157,7 +169,6 @@ new-value) #+shhh (when *gtk-debug* (TRC ,(format nil "output after ~a-~a" class slot-name) new-value) (force-output)))) - into outputs finally (return (values slot-defs outputs))) (multiple-value-bind (signals-slots signals-outputs) @@ -169,16 +180,15 @@ into signals-slots-defs collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - #+clisp (gtk-signal-connect (id self) - ,(string-downcase (string signal-slot)) - new-value) - #-clisp - (progn (callback-register self - ,(intern (string signal-slot) :keyword) - new-value) - (gtk-signal-connect (id self) - ,(string-downcase (string signal-slot)) - (cdr (assoc ',signal-slot *widget-callbacks*)))))) + (callback-register self + ,(intern (string signal-slot) :keyword) + new-value) + (let ((cb (cdr (assoc ',signal-slot *widget-callbacks*)))) + (assert cb) + #+shhtk (trc "in def-c-output gtk-signal-connect pcb:" + cb ',slot-name (id self)) + (gtk-signal-connect (id self) + ,(string-downcase (string signal-slot)) cb)))) into signals-outputs-defs finally (return (values signals-slots-defs signals-outputs-defs))) `(progn @@ -208,7 +218,7 @@ #-clisp `(lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback self ,widg ,event ,data)) (prog1 (progn ,@body @@ -222,24 +232,31 @@ ,@body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback-if self ,widg ,event ,data)) ,@body 1)))) -(ff-defun-callable :cdecl :int timeout-handler-callback - ((data (* :void))) - (print :timeout-handler-callback) - (let ((id (elti data 0))) - (gtk-global-callback-funcall id))) + +(ff-defun-callable :cdecl :boolean timeout-handler-callback + ((data (* :int))) + ;;(print (list :timeout-handler-callback data)) + (let* ((id (elti data 0)) + (r2 (gtk-global-callback-funcall id))) + (trc nil "timeout func really returning" r2) + r2)) + (defun timeout-add (milliseconds function) (let ((id (gtk-global-callback-register (lambda () - (print :timeout-add-global) - (with-gdk-threads - (funcall function))))) + ;;(print :timeout-add-global) + (let ((r (with-gdk-threads + (funcall function)))) + (trc nil "timeout func returning" r) + r)))) (c-id (fgn-alloc :int 1))) (setf (elti c-id 0) id) + (trc nil "timeout-add > passing cb data, *data" c-id (elti c-id 0)) (g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id))) (def-object widget () @@ -362,7 +379,8 @@ (assert-bin self) (dolist (kid new-value) (when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget event-box () ((visible-window :accessor visible-window :initarg :visible-window :initform nil)) @@ -376,7 +394,7 @@ (def-c-output .kids ((self event-box)) (assert-bin self) (when new-value - (gtk-container-add (id self) (id (first new-value))))) - + (gtk-container-add (id self) (id (first new-value)))) + #+clisp (call-next-method)) (eval-when (compile load eval) (export '(callback callback-if timeout-add focus)))

1 0