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