[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-utilities.lisp
Kenny Tilton
ktilton at common-lisp.net
Mon Jan 3 22:33:30 UTC 2005
Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory common-lisp.net:/tmp/cvs-serv10915/gtk-ffi
Modified Files:
gtk-ffi.lpr gtk-utilities.lisp
Log Message:
us pointer void in button-press-event-handler arglist
Date: Mon Jan 3 23:33:25 2005
Author: ktilton
Index: root/gtk-ffi/gtk-ffi.lpr
diff -u root/gtk-ffi/gtk-ffi.lpr:1.3 root/gtk-ffi/gtk-ffi.lpr:1.4
--- root/gtk-ffi/gtk-ffi.lpr:1.3 Tue Dec 14 05:02:05 2004
+++ root/gtk-ffi/gtk-ffi.lpr Mon Jan 3 23:33:24 2005
@@ -1,11 +1,10 @@
-;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*-
+;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*-
-(in-package :common-graphics-user)
+(in-package :cg-user)
-(defpackage :gtk-ffi (:export))
+(defpackage :GTK-FFI)
(define-project :name :gtk-ffi
- :application-type (intern "Standard EXE" (find-package :keyword))
:modules (list (make-instance 'module :name "gtk-ffi.lisp")
(make-instance 'module :name "gtk-core.lisp")
(make-instance 'module :name "gtk-button.lisp")
@@ -18,21 +17,12 @@
"c:\\cell-cultures\\hello-c\\hello-c"))
:libraries nil
:distributed-files nil
+ :internally-loaded-files nil
:project-package-name :gtk-ffi
:main-form nil
:compilation-unit t
:verbose nil
- :runtime-modules '(:cg :drag-and-drop :lisp-widget
- :multi-picture-button :common-control
- :edit-in-place :outline :grid :group-box
- :header-control :progress-indicator-control
- :common-status-bar :tab-control :trackbar-control
- :up-down-control :dde :mci :carets :hotspots
- :menu-selection :choose-list :directory-list
- :color-dialog :find-dialog :font-dialog
- :string-dialog :yes-no-list-dialog
- :list-view-control :rich-edit :drawable :ole :www
- :aclwin302)
+ :runtime-modules nil
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
:include-flags '(:compiler :top-level :local-name-info)
@@ -40,6 +30,7 @@
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
:default-command-line-arguments "+cx +t \"Initializing\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
Index: root/gtk-ffi/gtk-utilities.lisp
diff -u root/gtk-ffi/gtk-utilities.lisp:1.7 root/gtk-ffi/gtk-utilities.lisp:1.8
--- root/gtk-ffi/gtk-utilities.lisp:1.7 Fri Dec 24 16:35:10 2004
+++ root/gtk-ffi/gtk-utilities.lisp Mon Jan 3 23:33:24 2005
@@ -58,8 +58,16 @@
(g-value-unset value)))
(defun get-gtk-string (pointer)
- (with-foreign-object (bytes-written :int)
- (g-locale-from-utf8 pointer -1 nil bytes-written nil)))
+ (typecase pointer
+ (string pointer)
+ (otherwise
+ (ukt:trc nil "get-gtk-string sees" pointer (type-of pointer))
+ #+allegro (convert-from-cstring pointer)
+ #+lispworks (convert-from-foreign-string pointer
+ :null-terminated-p t)
+ #-(or allegro lispworks)
+ (with-foreign-object (bytes-written :int)
+ (g-locale-from-utf8 pointer -1 nil bytes-written nil)))))
(defun to-gtk-string (str)
"!!!! remember to free returned str pointer"
@@ -102,7 +110,7 @@
(defun gvi (&optional (key :anon))
key
-;;; (ukt:trc "gvi> " keY)
+;;; (ukt:trc nil "gvi> " keY)
;;; (let ((tv (ffx:fgn-alloc :int 32)))
;;; (dotimes (n 32) (setf (ffx:elti tv n) 0))
;;; (loop for type in '(:string :icon :int :string)
@@ -187,33 +195,80 @@
(:size (list "size-points" 'double-float (coerce val 'double-float)))
(:strikethrough (list "strikethrough" 'boolean val)))))
-(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))
+#+cmu
+(alien:def-alien-type all-types
+ (alien:struct c-struct
+ (:string (* t))
+ (:icon (* t))
+ (:boolean boolean)
+ (:int integer)
+ (:long c-call:long)
+ (:date single-float)
+ (:float single-float)
+ (:double double-float)))
+
+#-cmu
+(progn
+ (defun alloc-col-type-buffer (col-type)
+ (ecase col-type
+ ((:string :icon) (allocate-foreign-object '(:array :cstring) 1))
+ (:boolean (allocate-foreign-object '(:array :unsigned-byte) 1)) ;;guess
+ (:date (allocate-foreign-object '(:array :float) 1))
+ (:int (allocate-foreign-object '(:array :int) 1))
+ (:long (allocate-foreign-object '(:array :long) 1))
+ (:float (allocate-foreign-object '(:array :float) 1))
+ (:double (allocate-foreign-object '(:array :double) 1))))
+
+ (defun deref-col-type-buffer (col-type buffer)
+ (ecase col-type
+ ((:string :icon)
+ (get-gtk-string
+ (make-pointer (deref-array buffer '(:array :cstring) 0) :cstring)))
+ (:boolean (not (zerop (deref-array buffer '(:array :unsigned-byte) 0)))) ;;guess
+ (:date (deref-array buffer '(:array :float) 0))
+ (:int (deref-array buffer '(:array :int) 0))
+ (:long (deref-array buffer '(:array :long) 0))
+ (:float (deref-array buffer '(:array :float) 0))
+ (:double (deref-array buffer '(:array :double) 0)))))
+
+
+#+worksforallegroclbutnotlispworks
+(defun gtk-tree-view-render-cell (col col-type cell-attrib-f)
+ (lambda (tree-column cell-renderer model iter data)
+ (DECLARE (ignorable tree-column data))
+ (let ((wvar (alloc-col-type-buffer col-type)))
+ (gtk-tree-model-get model iter col wvar -1)
+ (let ((item-value (deref-col-type-buffer col-type wvar)))
+ (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)))
+ #-(or allegro lispworks)
+ (when (find col-type '(:icon :string))
+ (free-foreign-object item-value)))
+ (free-foreign-object wvar))))
+#-cmu
(defun gtk-tree-view-render-cell (col col-type cell-attrib-f)
+ (ukt:trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f)
(lambda (tree-column cell-renderer model iter data)
(DECLARE (ignorable tree-column data))
- (ukt:trc nil "entering render cell callback" tree-column model)
+ (ukt:trc nil "gtv-render-cell (callback)> entry"
+ tree-column cell-renderer model iter data)
(let ((return-buffer (ffx:fgn-alloc :int 16)))
(gtk-tree-model-get model iter col
return-buffer -1)
@@ -222,39 +277,111 @@
(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$)
+ (item-value (cond
+ (ret$ #-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)
+ ((eq col-type :boolean)
+ (not (zerop returned-value)))
+ (t returned-value))))
+ (ukt:trc nil "gtv-render-cell (callback)>> rendering value"
+ col col-type 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))))))
+ (t (list "text" 'c-string
+ (case 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)))
+ (:string (get-gtk-string item-value))
+ (otherwise (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))
+
+#+cmu
+(defun gtk-tree-view-render-cell (col col-type cell-attrib-f)
+ #'(lambda (tree-column cell-renderer model iter data)
+ (alien:with-alien ((struct all-types))
+ (gtk-tree-model-get model iter col
+ (alien:addr (alien:slot struct col-type))
+ -1)
+ (let ((item-value (if (or (eql col-type :string) (eql col-type :icon))
+ (get-gtk-string (alien:slot struct col-type))
+ (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 (alien:slot struct :string))))))
+
+
+#+clisp
+
+(defun gtk-tree-view-render-cell (col col-type cell-attrib-f)
+ #'(lambda (tree-column cell-renderer model iter data)
+ (declare (ignore data))
+ (with-c-var
+ (struct '(c-struct list
+ (:string c-pointer)
+ (:icon c-pointer)
+ (:boolean boolean)
+ (:int int)
+ (:long long)
+ (:date single-float)
+ (:float single-float)
+ (:double double-float))
+ (list nil nil nil 0 0 (coerce 0 'single-float) (coerce 0 'single-float) (coerce 0 'double-float)))
+ (gtk-tree-model-get model iter col
+ (c-var-address (slot struct col-type))
+ -1)
+ (let ((item-value (if (or (eql col-type :string) (eql col-type :icon))
+ (get-gtk-string (slot struct col-type))
+ (slot struct col-type))))
+ (ukt:trc nil "tv-render-cell: "
+ :col-type col-type
+ :item item-value)
+ (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)))
+ (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 (slot struct :string))))))
(defun gtk-file-chooser-get-filenames-strs (file-chooser)
(let ((glist (gtk-file-chooser-get-filenames file-chooser)))
More information about the Cells-gtk-cvs
mailing list