[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp
Peter Denno
pdenno at common-lisp.net
Tue Jan 3 19:10:45 UTC 2006
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)))
More information about the Cells-gtk-cvs
mailing list