Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv10915/gtk-ffi

Modified Files: gtk-ffi.lpr gtk-utilities.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Mon Jan 3 23:33:25 2005 Author: ktilton

Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.3 root/gtk-ffi/gtk-ffi.lpr:1.4 --- root/gtk-ffi/gtk-ffi.lpr:1.3 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.lpr Mon Jan 3 23:33:24 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*-

-(in-package :common-graphics-user) +(in-package :cg-user)

-(defpackage :gtk-ffi (:export)) +(defpackage :GTK-FFI)

(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-core.lisp") (make-instance 'module :name "gtk-button.lisp") @@ -18,21 +17,12 @@ "c:\cell-cultures\hello-c\hello-c")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :gtk-ffi :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:compiler :top-level :local-name-info) @@ -40,6 +30,7 @@ :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t "Initializing"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard

Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.7 root/gtk-ffi/gtk-utilities.lisp:1.8 --- root/gtk-ffi/gtk-utilities.lisp:1.7 Fri Dec 24 16:35:10 2004 +++ root/gtk-ffi/gtk-utilities.lisp Mon Jan 3 23:33:24 2005 @@ -58,8 +58,16 @@ (g-value-unset value)))

(defun get-gtk-string (pointer) - (with-foreign-object (bytes-written :int) - (g-locale-from-utf8 pointer -1 nil bytes-written nil))) + (typecase pointer + (string pointer) + (otherwise + (ukt:trc nil "get-gtk-string sees" pointer (type-of pointer)) + #+allegro (convert-from-cstring pointer) + #+lispworks (convert-from-foreign-string pointer + :null-terminated-p t) + #-(or allegro lispworks) + (with-foreign-object (bytes-written :int) + (g-locale-from-utf8 pointer -1 nil bytes-written nil)))))

(defun to-gtk-string (str) "!!!! remember to free returned str pointer" @@ -102,7 +110,7 @@

(defun gvi (&optional (key :anon)) key -;;; (ukt:trc "gvi> " keY) +;;; (ukt:trc nil "gvi> " keY) ;;; (let ((tv (ffx:fgn-alloc :int 32))) ;;; (dotimes (n 32) (setf (ffx:elti tv n) 0)) ;;; (loop for type in '(:string :icon :int :string) @@ -187,33 +195,80 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val)))))

-(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))

+#+cmu +(alien:def-alien-type all-types + (alien:struct c-struct + (:string (* t)) + (:icon (* t)) + (:boolean boolean) + (:int integer) + (:long c-call:long) + (:date single-float) + (:float single-float) + (:double double-float))) + +#-cmu +(progn + (defun alloc-col-type-buffer (col-type) + (ecase col-type + ((:string :icon) (allocate-foreign-object '(:array :cstring) 1)) + (:boolean (allocate-foreign-object '(:array :unsigned-byte) 1)) ;;guess + (:date (allocate-foreign-object '(:array :float) 1)) + (:int (allocate-foreign-object '(:array :int) 1)) + (:long (allocate-foreign-object '(:array :long) 1)) + (:float (allocate-foreign-object '(:array :float) 1)) + (:double (allocate-foreign-object '(:array :double) 1)))) + + (defun deref-col-type-buffer (col-type buffer) + (ecase col-type + ((:string :icon) + (get-gtk-string + (make-pointer (deref-array buffer '(:array :cstring) 0) :cstring))) + (:boolean (not (zerop (deref-array buffer '(:array :unsigned-byte) 0)))) ;;guess + (:date (deref-array buffer '(:array :float) 0)) + (:int (deref-array buffer '(:array :int) 0)) + (:long (deref-array buffer '(:array :long) 0)) + (:float (deref-array buffer '(:array :float) 0)) + (:double (deref-array buffer '(:array :double) 0))))) + + +#+worksforallegroclbutnotlispworks +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + (lambda (tree-column cell-renderer model iter data) + (DECLARE (ignorable tree-column data)) + (let ((wvar (alloc-col-type-buffer col-type))) + (gtk-tree-model-get model iter col wvar -1) + (let ((item-value (deref-col-type-buffer col-type wvar))) + (with-gtk-string (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))) + (ukt:trc nil "gtv-render-cell (callback11)> rendering value" + col col-type 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))) + #-(or allegro lispworks) + (when (find col-type '(:icon :string)) + (free-foreign-object item-value))) + (free-foreign-object wvar))))

+#-cmu (defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + (ukt:trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f) (lambda (tree-column cell-renderer model iter data) (DECLARE (ignorable tree-column data)) - (ukt:trc nil "entering render cell callback" tree-column model) + (ukt:trc nil "gtv-render-cell (callback)> entry" + tree-column cell-renderer model iter data) (let ((return-buffer (ffx:fgn-alloc :int 16))) (gtk-tree-model-get model iter col return-buffer -1) @@ -222,39 +277,111 @@ (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$) + (item-value (cond + (ret$ #-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) + ((eq col-type :boolean) + (not (zerop returned-value))) + (t returned-value)))) + (ukt:trc nil "gtv-render-cell (callback)>> rendering value" + col col-type 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)))))) + (t (list "text" 'c-string + (case 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))) + (:string (get-gtk-string item-value)) + (otherwise (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)) + +#+cmu +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + #'(lambda (tree-column cell-renderer model iter data) + (alien:with-alien ((struct all-types)) + (gtk-tree-model-get model iter col + (alien:addr (alien:slot struct col-type)) + -1) + (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) + (get-gtk-string (alien:slot struct col-type)) + (alien:slot struct col-type)))) + (with-gtk-string (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))) + (ukt:trc nil "gtv-render-cell (callback11)> rendering value" + col col-type 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 (eql col-type :string) + (g-free (alien:slot struct :string)))))) + + +#+clisp + +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + #'(lambda (tree-column cell-renderer model iter data) + (declare (ignore data)) + (with-c-var + (struct '(c-struct list + (:string c-pointer) + (:icon c-pointer) + (:boolean boolean) + (:int int) + (:long long) + (:date single-float) + (:float single-float) + (:double double-float)) + (list nil nil nil 0 0 (coerce 0 'single-float) (coerce 0 'single-float) (coerce 0 'double-float))) + (gtk-tree-model-get model iter col + (c-var-address (slot struct col-type)) + -1) + (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) + (get-gtk-string (slot struct col-type)) + (slot struct col-type)))) + (ukt:trc nil "tv-render-cell: " + :col-type col-type + :item item-value) + (with-gtk-string (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 (eql col-type :string) + (g-free (slot struct :string))))))

(defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser)))