[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp

[Peter Denno]

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

Modified Files:
	gtk-utilities.lisp 
Log Message:
SBCL porting.
Date: Sat Oct  8 16:50:26 2005
Author: pdenno

Index: root/gtk-ffi/gtk-utilities.lisp
diff -u root/gtk-ffi/gtk-utilities.lisp:1.14 root/gtk-ffi/gtk-utilities.lisp:1.15
--- root/gtk-ffi/gtk-utilities.lisp:1.14	Sun May 29 23:24:10 2005
+++ root/gtk-ffi/gtk-utilities.lisp	Sat Oct  8 16:50:26 2005
@@ -193,7 +193,7 @@
    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 allegro) (cast item (as-gtk-type-name cell-type))
+  #-(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)))
@@ -205,7 +205,11 @@
    #+cmu
    (case cell-type
      (:string (alien:cast (alien:deref item) c-call:c-string))
-     (t (alien:deref item)))))
+     (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)))))
 
 (defun parse-cell-attrib (attribs)
   (loop for (attrib val) on attribs by #'cddr collect
@@ -228,6 +232,19 @@
     (: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)
@@ -358,6 +375,37 @@
          (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