cells-gtk-cvs December 2004

cells-gtk-cvs@common-lisp.net

1 participants
35 discussions

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

24 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv29363/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Fri Dec 24 16:35:11 2004 Author: ktilton Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.6 root/gtk-ffi/gtk-utilities.lisp:1.7 --- root/gtk-ffi/gtk-utilities.lisp:1.6 Thu Dec 23 17:34:51 2004 +++ root/gtk-ffi/gtk-utilities.lisp Fri Dec 24 16:35:10 2004 @@ -74,7 +74,7 @@ (gdk-threads-leave))) (ffx:ff-defun-callable :cdecl :int button-press-event-handler - ((widget (* :void)) (signal (* gdk-event-button)) (data (* :void))) + ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) (when (eql (event-type event) :button_press)

1 0

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

24 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv19976/gtk-ffi Modified Files: gtk-core.lisp Log Message: (Andras's) fix for with-g-value to pump up CMU handling of tree-view demo Date: Fri Dec 24 03:04:03 2004 Author: ktilton Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.2 root/gtk-ffi/gtk-core.lisp:1.3 --- root/gtk-ffi/gtk-core.lisp:1.2 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-core.lisp Fri Dec 24 03:04:00 2004 @@ -67,18 +67,24 @@ (defmacro with-g-value ((var) &body body) `(call-with-g-value (lambda (,var) ,@body))) +#+cmu +(ffx:def-type g-value-type + (* (alien:struct gtk-ffi::g-value + (gtk-ffi::g-type (array (alien:signed 32) 16))))) + (defun call-with-g-value (fn) + (declare (optimize (speed 3) (safety 0) (space 0))) (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) + #+cmu (declare (type g-value-type gva)) (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)))) + (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value))

1 0

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

24 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv19976/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: (Andras's) fix for with-g-value to pump up CMU handling of tree-view demo Date: Fri Dec 24 03:03:58 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.6 root/cells-gtk/test-gtk/test-gtk.lisp:1.7 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.6 Thu Dec 16 05:51:14 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Fri Dec 24 03:03:57 2004 @@ -18,10 +18,10 @@ "Menus" "Textview" "Dialogs" "Addon" "Entry" - "Tree-view" + #-cmu "Tree-view" ))) (list (mk-notebook - :tab-labels nil #+not '("Buttons") + :tab-labels tabs :kids (loop for test-name in tabs collect (make-instance (intern (string-upcase

1 0

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

23 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv22788/gtk-ffi Modified Files: gtk-ffi.lisp gtk-utilities.lisp Log Message: Merge brave but incomplete attempt at adding OS/X. Date: Thu Dec 23 17:34:52 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.7 root/gtk-ffi/gtk-ffi.lisp:1.8 --- root/gtk-ffi/gtk-ffi.lisp:1.7 Wed Dec 22 17:23:53 2004 +++ root/gtk-ffi/gtk-ffi.lisp Thu Dec 23 17:34:51 2004 @@ -60,15 +60,29 @@ (:gthread "libgthread-2.0-0.dll") (:gdk "libgdk-win32-2.0-0.dll") (:gtk "libgtk-win32-2.0-0.dll"))) - #-(or win32 mswindows) + #+macosx (concatenate 'string - "/usr/lib" + "/sw/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")))) + (:gobject "libgobject-2.0.0.dylib") + (:glib "libglib-2.0.0.dylib") + (:gthread "libgthread-2.0.0.dylib") + (:gdk "libgdk-x11-2.0.0.dylib") + (:gtk "libgtk-x11-2.0.0.dylib"))) + #-(or macosx 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"))) + #+cmu + (loop for lib in '(:gthread :glib :gobject :gdk :gtk) + do (assert (uffi:load-foreign-library ;;simon + (hic:find-foreign-library (gtk-ffi::libname lib) "/usr/lib/") + :force-load #+lispworks t #-lispworks nil + :module (string lib))) + ) (defun ffi-to-uffi-type (clisp-type) #+clisp clisp-type Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.5 root/gtk-ffi/gtk-utilities.lisp:1.6 --- root/gtk-ffi/gtk-utilities.lisp:1.5 Wed Dec 22 17:23:53 2004 +++ root/gtk-ffi/gtk-utilities.lisp Thu Dec 23 17:34:51 2004 @@ -35,8 +35,8 @@ (if after 1 0))))) (uffi:def-function ("g_signal_connect_data" g_signal_connect_data) - ((instance (* :void)) (detailed-signal :cstring) - (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) + ((instance :pointer-void) (detailed-signal :cstring) + (c-handler :pointer-void) (data :pointer-void)(destroy-data :pointer-void) (after :int)) :returning :unsigned-long :call-direct nil) (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think.

1 0

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

23 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv22788/cells-gtk Modified Files: gtk-app.lisp tree-view.lisp widgets.lisp Log Message: Merge brave but incomplete attempt at adding OS/X. Date: Thu Dec 23 17:34:45 2004 Author: ktilton Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.5 root/cells-gtk/gtk-app.lisp:1.6 --- root/cells-gtk/gtk-app.lisp:1.5 Wed Dec 22 17:23:50 2004 +++ root/cells-gtk/gtk-app.lisp Thu Dec 23 17:34:42 2004 @@ -112,13 +112,6 @@ :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 start-app gtk-global-callback-register gtk-global-callback-funcall))) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.6 root/cells-gtk/tree-view.lisp:1.7 --- root/cells-gtk/tree-view.lisp:1.6 Wed Dec 22 17:23:50 2004 +++ root/cells-gtk/tree-view.lisp Thu Dec 23 17:34:42 2004 @@ -101,7 +101,7 @@ (:multiple 3)))))) (ff-defun-callable :cdecl :int tree-view-select-handler - ((column-widget (* :void)) (event (* :void)) (data (* :void))) + ((column-widget :pointer-void) (event :pointer-void) (data :pointer-void)) (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) @@ -173,8 +173,8 @@ (items-factory self))))) (ff-defun-callable :cdecl :int tree-view-render-cell-callback - ((tree-column (* :void)) (cell-renderer (* :void)) - (tree-model (* :void)) (iter (* :void)) (data (* :void))) + ((tree-column :pointer-void) (cell-renderer :pointer-void) + (tree-model :pointer-void) (iter :pointer-void) (data :pointer-void)) (bif (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb () "No :render-cell callback for ~a" self) @@ -225,4 +225,4 @@ `(list ,type ',inits ,renderer)))) (eval-when (compile load eval) - (export '(mk-listbox mk-treebox def-columns))) \ No newline at end of file + (export '(mk-listbox mk-treebox def-columns))) Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.5 root/cells-gtk/widgets.lisp:1.6 --- root/cells-gtk/widgets.lisp:1.5 Thu Dec 16 05:51:11 2004 +++ root/cells-gtk/widgets.lisp Thu Dec 23 17:34:42 2004 @@ -118,7 +118,7 @@ (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))) + ((widget :pointer-void) (event :pointer-void) (data :pointer-void)) ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) (bif (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) @@ -238,6 +238,7 @@ 1)))) +#-cmu (ff-defun-callable :cdecl :boolean timeout-handler-callback ((data (* :int))) ;;(print (list :timeout-handler-callback data))

1 0

[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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cells-gtk-cvs December 2004