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

[Kenny Tilton]

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) , at 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))