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

Modified Files: gtk-core.lisp gtk-ffi.lisp gtk-utilities.lisp Log Message: Both AllegroCL and Lispworks now run Cells-gtk on win32. Pretty much. All of Vasilis's examples work, with one known fault in Lispworks and bigger problems in AllegroCL in a couple of examples. This means a huge amount works, because vasilis did an extraordinary coverage of Gtk2 in his examples. I be moving on to see if I can score OS/X. Date: Thu Dec 16 05:51:18 2004 Author: ktilton

Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.1 root/gtk-ffi/gtk-core.lisp:1.2 --- root/gtk-ffi/gtk-core.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-core.lisp Thu Dec 16 05:51:17 2004 @@ -65,22 +65,33 @@ (g-type (:array :int 16)))

(defmacro with-g-value ((var) &body body) - `(let ((,var (ffx:fgn-alloc 'g-value 1 :with-g-value ',var))) - (unwind-protect - (progn - (dotimes (n 16) - (setf (int-slot-indexed ,var 'g-value 'g-type n) 0)) - ,@body) - (ffx:fgn-free ,var)))) + `(call-with-g-value (lambda (,var) ,@body))) + +(defun call-with-g-value (fn) + (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) + (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))))

(eval-when (compile load eval) (export 'with-g-value))

-(progn - (def-function ("g_value_init" g_value_init) ((value :pointer-void) (type :unsigned-long)) - :module :glib :call-direct t :returning :pointer-void) - (defun g-value-init (value type) - (g_value_init (or value c-null) type)) - (eval-when (compile load eval) (export 'g-value-init))) + +#+test +(def-gtk-lib-functions :gobject + (g-value-set-string ((value c-pointer) + (str c-string)))) + +#+test +(def-gtk-function :gobject g-value-set-string + :arguments ((value c-pointer) (str c-string)) + :return-type nil :call-direct t)

(def-gtk-lib-functions :gobject ;; callbacks @@ -110,12 +121,12 @@ (g-object-set-property ((object c-pointer) (property-name c-string) (value c-pointer))) - #+above (g-value-init ((value c-pointer) + (g-value-init ((value c-pointer) (type ulong)) c-pointer) (g-value-unset ((value c-pointer))) (g-value-set-string ((value c-pointer) - (str c-pointer))) + (str c-string))) (g-value-set-int ((value c-pointer) (int int))) (g-value-set-long ((value c-pointer)

Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.5 root/gtk-ffi/gtk-ffi.lisp:1.6 --- root/gtk-ffi/gtk-ffi.lisp:1.5 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.lisp Thu Dec 16 05:51:17 2004 @@ -316,6 +316,14 @@ (user-data2 c-pointer) (user-data3 c-pointer))

+(defmacro with-tree-iter ((iter-var) &body body) + `(with-foreign-object (,iter-var 'gtk-tree-iter) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'stamp) 0) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data2) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data3) c-null) + ,@body)) +

(eval-when (:compile-toplevel :load-toplevel :execute) (defun as-gtk-type-name (type) @@ -342,7 +350,7 @@

(defun col-type-to-ffi-type (col-type) - (cdr (assoc col-type '((:string . c-pointer) + (cdr (assoc col-type '((:string . c-string) ;;2004:12:15-00:17 was c-pointer (:icon . c-pointer) (:boolean . boolean) (:int . int) @@ -369,3 +377,5 @@ (export '(uint c-pointer c-ptr-null c-array-ptr c-ptr c-string sint32 uint32 uint8 boolean ulong int long single-float double-float otherwise *gtk-debug* col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter))) + +

Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.3 root/gtk-ffi/gtk-utilities.lisp:1.4 --- root/gtk-ffi/gtk-utilities.lisp:1.3 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-utilities.lisp Thu Dec 16 05:51:17 2004 @@ -39,13 +39,9 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil)

-(defun wrap-func (func-address) - (or func-address 0) - ;;(assert (or (null func-address) (numberp func-address))) - #+nahh - (if func-address - (uffi:make-pointer func-address '(* :void)) - c-null)) +(defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. + (or func-address 0)) +

(defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) (g-signal-connect-closure widget signal @@ -53,16 +49,13 @@

(defun gtk-object-set-property (obj property val-type val) (with-g-value (value) - (let ((str-ptr (and (eql val-type 'c-string) (to-gtk-string val)))) (g-value-init value (value-type-as-int val-type)) (funcall (value-set-function val-type) - value - (or str-ptr val)) + value val)

(g-object-set-property obj property value)

- (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value)))

(defun get-gtk-string (pointer) (with-foreign-object (bytes-written :int) @@ -144,16 +137,13 @@ (when str-ptr (free-cstring str-ptr)))))

(defun gtk-list-store-set-items (store types-lst data-lst) - (with-foreign-object (iter 'gtk-tree-iter) - (setf (get-slot-value iter 'gtk-tree-iter 'stamp) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data2) 0) - (setf (get-slot-value iter 'gtk-tree-iter 'user-data3) 0) + (with-tree-iter (iter) (dolist (item data-lst) (gvi :pre-append) (gtk-list-store-append store iter) (gvi :pre-set) - (gtk-list-store-set store iter types-lst item)))) + (gtk-list-store-set store iter types-lst item) + (gvi :post-set))))

(defun gtk-tree-store-new (col-types) (let ((gtk-types (ffx:fgn-alloc :int (length col-types)))) @@ -167,8 +157,6 @@ (loop for col from 0 for data in data-lst for type in types-lst - for str-ptr = (when (find type '(:string :icon)) - (to-gtk-string data)) do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type @@ -177,10 +165,11 @@ (t type))) :gtk-ffi) value - (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) + (if (eql type :date) + (coerce data 'single-float) + data)) (gtk-tree-store-set-value tstore iter col value) - (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value))))

(defun gtk-tree-model-get-cell (model iter column-no cell-type) (with-foreign-object (item :pointer-void) @@ -198,41 +187,95 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val)))))

+(defun make-address-pointer (addr type) + #+(or allegro mcl) (declare (ignore type)) + (assert (or (null addr) (numberp addr))) + (if addr + (progn + #+(or cmu scl) + (alien:sap-alien (system:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+sbcl + (sb-alien:sap-alien (sb-sys:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+lispworks + (fli:make-pointer + :address addr + :type (convert-from-uffi-type type :type)) + #+allegro addr + #+mcl + (ccl:%int-to-ptr addr) + ) + c-null)) + +(uffi:def-struct all-types + (:string :cstring) + (:icon :cstring) + (:boolean :unsigned-int) + (:int :int) + (:long :long) + (:date :float) + (:float :float) + (:double :double)) + +(defmacro with-all-types ((var) &body body) + `(uffi:with-foreign-object (,var 'all-types) + (setf (get-slot-value ,var 'all-types :string) c-null + (get-slot-value ,var 'all-types :icon) c-null + (get-slot-value ,var 'all-types :boolean) 0 + (get-slot-value ,var 'all-types :int) 0 + (get-slot-value ,var 'all-types :long) 0 + (get-slot-value ,var 'all-types :date) 0f0 + (get-slot-value ,var 'all-types :float) 0f0 + (get-slot-value ,var 'all-types :double) 0d0) + ,@body)) +

(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - (declare (ignore col)) - #'(lambda (tree-column cell-renderer model iter data) - (DECLARE (ignore data)) - - (let ((return-buffer (ffx:fgn-alloc :int 16))) - (gtk-tree-model-get model iter tree-column - return-buffer -1) - (let* ((returned-value (deref-pointer-runtime-typed return-buffer - (ffi-to-uffi-type - (col-type-to-ffi-type col-type)))) - (item-value (case col-type - ((:string :icon) (convert-from-cstring returned-value)) - (:boolean (not (zerop returned-value))) - (otherwise returned-value)))) - (with-cstring (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 (and (eql col-type :string) - (not (zerop returned-value))) - (uffi:free-foreign-object returned-value)) - (ffx:fgn-free return-buffer))))) + (lambda (tree-column cell-renderer model iter data) + (DECLARE (ignorable tree-column data)) + (ukt:trc nil "entering render cell callback" tree-column model) + (let ((return-buffer (ffx:fgn-alloc :int 16))) + (gtk-tree-model-get model iter col + return-buffer -1) + (let* ((returned-value (deref-pointer-runtime-typed return-buffer + (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 (case col-type + ((:string :icon) + #-lispworks (convert-from-cstring ret$) + #+lispworks (convert-from-foreign-string ret$ + :null-terminated-p t)) + (:boolean (not (zerop returned-value))) + (otherwise returned-value)))) + (ukt:trc nil "tv-render-cell: types, ret-value, item-value" + (List col-type (col-type-to-ffi-type col-type) (ffi-to-uffi-type + (col-type-to-ffi-type col-type))) + returned-value ret$ 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-string (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)) + (format nil "~a" item-value)))))) + (when cell-attrib-f + (ukt:trc nil "got cell-attrib-f" cell-attrib-f item-value) + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) + do (apply #'gtk-object-set-property cell-renderer property))) + (when ret$ + (ukt:trc nil "frreeing ret$" ret$) + (uffi:free-foreign-object ret$)) + (ukt:trc nil "frreeing return-buffer" return-buffer) + (ffx:fgn-free return-buffer))) + (ukt:trc nil "exiting render cell callback" tree-column model) + 1))

(defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser))) @@ -244,7 +287,7 @@ (eval-when (compile load eval) (export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property with-gtk-string get-gtk-string to-gtk-string - with-gdk-threads make-gtk-tree-iter + with-gdk-threads make-gtk-tree-iter with-tree-iter gtk-widget-set-popup gvi gtk-list-store-new gtk-list-store-set gtk-list-store-set-items gtk-tree-store-new gtk-tree-store-set gtk-tree-store-set-kids