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

Modified Files: gtk-utilities.lisp Log Message: CFFI : removed lots of ifdef'ed stuff. Date: Tue Jan 3 20:10:45 2006 Author: pdenno

Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.15 root/gtk-ffi/gtk-utilities.lisp:1.16 --- root/gtk-ffi/gtk-utilities.lisp:1.15 Sat Oct 8 16:50:26 2005 +++ root/gtk-ffi/gtk-utilities.lisp Tue Jan 3 20:10:45 2006 @@ -25,7 +25,7 @@ (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) - (with-cstrings ((c-detailed-signal detailed-signal)) + (uffi:with-cstrings ((c-detailed-signal detailed-signal)) (let ((p4 (or data c-null))) (g_signal_connect_data self @@ -38,7 +38,7 @@ (uffi:def-function ("g_signal_connect_data" g_signal_connect_data) ((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) + :returning :unsigned-long)

(defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. (or func-address 0)) @@ -84,7 +84,6 @@

(ffx:ff-defun-callable :cdecl :int button-press-event-handler ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) - (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) (when (or (eql (event-type event) :button_press) (eql (event-type event) :button_release)) @@ -193,23 +192,9 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - #-(or lispworks cmu sbcl allegro) (cast item (as-gtk-type-name cell-type)) - #+allegro (case cell-type (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) - (t (cast item (as-gtk-type-name cell-type)))) - #+lispworks - (case cell-type - (:string (fli:convert-from-foreign-string (deref-pointer item))) - (t (deref-pointer item))) - #+cmu - (case cell-type - (:string (alien:cast (alien:deref item) c-call:c-string)) - (t (alien:deref item))) - #+sbcl - (case cell-type - (:string (sb-alien:cast (sb-alien:deref item) sb-c-call:c-string)) - (t (sb-alien:deref item))))) + (t (cast item (as-gtk-type-name cell-type))))))

(defun parse-cell-attrib (attribs) (loop for (attrib val) on attribs by #'cddr collect @@ -220,32 +205,6 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val)))))

-#+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))) - -#+sbcl -(sb-alien:def-alien-type all-types - (sb-alien:struct c-struct - (:string (* t)) - (:icon (* t)) - (:boolean boolean) - (:int integer) - (:long sb-c-call:long) - (:date single-float) - (:float single-float) - (:double double-float))) - - -#-cmu (progn (defun alloc-col-type-buffer (col-type) (ecase col-type @@ -269,37 +228,6 @@ (: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) @@ -313,11 +241,9 @@ (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 (cond - (ret$ #-lispworks (convert-from-cstring ret$) - #+lispworks (convert-from-foreign-string ret$ - :null-terminated-p t)) + returned-value)) + (item-value (cond + (ret$ (convert-from-cstring ret$)) ((eq col-type :boolean) (not (zerop returned-value))) (t returned-value)))) @@ -345,111 +271,6 @@ (uffi:free-foreign-object ret$)) (ffx:fgn-free return-buffer))) 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)))))) - -#+sbcl -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter data) - (sb-alien:with-alien ((struct all-types)) - (gtk-tree-model-get model iter col - (sb-alien:addr (sb-alien:slot struct col-type)) - -1) - (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) - (get-gtk-string (sb-alien:slot struct col-type)) - (sb-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 (sb-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)))