[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp
Kenny Tilton
ktilton at common-lisp.net
Thu Dec 16 04:51:43 UTC 2004
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))
- , at body)
- (ffx:fgn-free ,var))))
+ `(call-with-g-value (lambda (,var) , at 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)
+ , at 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)
+ , at 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
More information about the Cells-gtk-cvs
mailing list