February 2006 - cells-gtk-cvs@common-lisp.net

[cells-gtk-cvs] CVS root/cells-gtk/test-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp:/tmp/cvs-serv16208/root/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: don't use package :ukt, use package :pod --- /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp 2006/02/16 18:20:53 1.12 +++ /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp 2006/02/19 20:19:13 1.13 @@ -1,5 +1,5 @@ (defpackage :test-gtk - (:use :common-lisp :utils-kt :pod :cells :gtk-ffi :cells-gtk)) + (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk)) (in-package :test-gtk)

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp:/tmp/cvs-serv16186/root/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: uffi --> cffi --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp 2006/02/16 18:07:50 1.18 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp 2006/02/19 20:18:27 1.19 @@ -35,10 +35,10 @@ (or destroy-data +c-null+) (if after 1 0))))) -(uffi:def-function ("g_signal_connect_data" g_signal_connect_data) - ((instance :pointer-void) (detailed-signal :cstring) - (c-handler :pointer-void) (data :pointer-void)(destroy-data :pointer-void) (after :int)) - :returning :unsigned-long) +(cffi:defcfun ("g_signal_connect_data" g_signal_connect_data) + :unsigned-long + (instance :pointer) (detailed-signal :pointer) (c-handler :pointer) + (data :pointer) (destroy-data :pointer) (after :int)) (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. (or func-address 0)) @@ -62,17 +62,17 @@ (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 + (pod:trc nil "get-gtk-string sees" pointer (type-of pointer)) + #+allegro (uffi:convert-from-cstring pointer) + #+lispworks (uffi:convert-from-foreign-string pointer :null-terminated-p t) #-(or allegro lispworks) - (with-foreign-object (bytes-written :int) + (uffi:with-foreign-object (bytes-written :int) (g-locale-from-utf8 pointer -1 +c-null+ bytes-written +c-null+))))) (defun to-gtk-string (str) "!!!! remember to free returned str pointer" - (with-foreign-object (bytes-written :int) + (uffi:with-foreign-object (bytes-written :int) (g-locale-to-utf8 str -1 +c-null+ bytes-written +c-null+))) (defmacro with-gdk-threads (&rest body) @@ -134,7 +134,7 @@ (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) (gtk-list-store-set-value lstore iter col value) (g-value-unset value) - (when str-ptr (free-cstring str-ptr))))) + (when str-ptr (uffi:free-cstring str-ptr))))) (defun gtk-list-store-set-items (store types-lst data-lst) (with-tree-iter (iter) @@ -180,7 +180,7 @@ "Returns the item at column-no if column-no [0,<num-columns-1>] or a a string like '(0 1 0)', which navigates to the selected item, if column-no = num-columns. (See gtk-tree-store-set-kids)." - (with-foreign-object (item :pointer-void) + (uffi:with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) (case cell-type (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) @@ -198,31 +198,31 @@ (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)))) + ((:string :icon) (uffi:allocate-foreign-object '(:array :cstring) 1)) + (:boolean (uffi:allocate-foreign-object '(:array :unsigned-byte) 1)) ;;guess + (:date (uffi:allocate-foreign-object '(:array :float) 1)) + (:int (uffi:allocate-foreign-object '(:array :int) 1)) + (:long (uffi:allocate-foreign-object '(:array :long) 1)) + (:float (uffi:allocate-foreign-object '(:array :float) 1)) + (:double (uffi: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))))) + (cffi:make-pointer (cffi:mem-aref buffer :pointer 0) :cstring))) + (:boolean (not (zerop (cffi:mem-aref buffer :unsigned-char 0)))) + (:date (cffi:mem-aref buffer :FLOAT 0)) + (:int (cffi:mem-aref buffer :int 0)) + (:long (cffi:mem-aref buffer :long 0)) + (:float (cffi:mem-aref buffer :float 0)) + (:double (cffi:mem-aref buffer :double 0))))) (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) + (pod: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 "gtv-render-cell (callback)> entry" + (pod:trc nil "gtv-render-cell (callback)> entry" tree-column cell-renderer model iter data) (let ((return-buffer (cffi:foreign-alloc :int :count 16))) (gtk-tree-model-get model iter col @@ -233,11 +233,11 @@ (ret$ (when (find col-type '(:string :icon)) returned-value)) (item-value (cond - (ret$ (convert-from-cstring ret$)) + (ret$ (uffi:convert-from-cstring ret$)) ((eq col-type :boolean) (not (zerop returned-value))) (t returned-value)))) - (ukt:trc nil "gtv-render-cell (callback)>> rendering value" + (pod:trc nil "gtv-render-cell (callback)>> rendering value" col col-type ret$ item-value) (apply #'gtk-object-set-property cell-renderer @@ -263,9 +263,9 @@ (defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser))) - (loop for lst-address = glist then (get-slot-value lst-address 'gslist 'next) + (loop for lst-address = glist then (cffi:foreign-slot-value lst-address 'gslist 'next) while (and lst-address (not (zerop lst-address))) - collect (get-slot-value lst-address 'gslist 'data) + collect (cffi:foreign-slot-value lst-address 'gslist 'data) finally (g-slist-free glist)))) (eval-when (compile load eval)

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp:/tmp/cvs-serv16159/root/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: uffi --> cffi --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/02/16 21:55:32 1.18 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/02/19 20:17:41 1.19 @@ -16,11 +16,12 @@ |# -(defpackage :gtk-ffi (:use :common-lisp :pod :uffi)) ; pod remove uffi +(defpackage :gtk-ffi (:use :common-lisp :pod)) (in-package :gtk-ffi) -;;; POD throw-away utility +;;; POD throw-away utility to convert hello-c/uffi to cffi +#+nil (defun gtk-lib2cffi (body) "Convert hello-c to uffi to cffi types. Swap order of arguments." (flet ((convert-type (type) @@ -49,7 +50,6 @@ (defconstant +c-null+ (cffi:null-pointer)) (defvar *gtk-debug* nil) -(defvar *zippy* "diagnostics") ;;; ============== Define CFFI types, and their translations.... (cffi:defctype :gtk-string :pointer :documentation "string type for cffi type translation") @@ -73,15 +73,11 @@ (defun int-slot-indexed (obj obj-type slot index) (declare (ignorable obj-type)) - (deref-array - (get-slot-pointer obj obj-type slot) - '(:array :int) index)) + (cffi:mem-aref (cffi:foreign-slot-value obj obj-type slot) :int index)) (defun (setf int-slot-indexed) (new-value obj obj-type slot index) (declare (ignorable obj-type)) - (setf (deref-array - (get-slot-pointer obj obj-type slot) - '(:array :int) index) + (setf (cffi:mem-aref (cffi:foreign-slot-value obj obj-type slot) :int index) new-value)) (cffi:define-foreign-library 'gobject @@ -224,10 +220,10 @@ `(defun ,(intern (string-upcase (format nil "make-~a" struct-name))) (&key ,@(loop for (name supplied nil) in slot-defs collecting (list name nil supplied))) - (let ((,obj (allocate-foreign-object ',struct-name))) + (let ((,obj (uffi:allocate-foreign-object ',struct-name))) ,@(loop for (name supplied nil) in slot-defs collecting `(when ,supplied - (setf (get-slot-value ,obj ',struct-name ',name) ,name))) + (setf (cffi:foreign-slot-value ,obj ',struct-name ',name) ,name))) ,obj))) ;; --- accessors --- @@ -236,9 +232,9 @@ (accessor (intern (format nil "~a-~a" struct-name slot-name)))) `(progn (defun ,accessor (self) - (get-slot-value self ',struct-name ',slot-name)) + (cffi:foreign-slot-value self ',struct-name ',slot-name)) (defun (setf ,accessor) (new-value self) - (setf (get-slot-value self ',struct-name ',slot-name) + (setf (cffi:foreign-slot-value self ',struct-name ',slot-name) new-value)))) slot-defs)))) @@ -380,10 +376,10 @@ (defmacro with-tree-iter ((iter-var) &body body) `(uffi: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+) + (setf (cffi:foreign-slot-value ,iter-var 'gtk-tree-iter 'stamp) 0) + (setf (cffi:foreign-slot-value ,iter-var 'gtk-tree-iter 'user-data) +c-null+) + (setf (cffi:foreign-slot-value ,iter-var 'gtk-tree-iter 'user-data2) +c-null+) + (setf (cffi:foreign-slot-value ,iter-var 'gtk-tree-iter 'user-data3) +c-null+) ,@body)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -421,14 +417,14 @@ (defmacro deref-pointer-runtime-typed (ptr type) "Returns a object pointed" (declare (ignorable type)) - `(deref-pointer ,ptr ,type)) + `(uffi:deref-pointer ,ptr ,type)) (defun cast (ptr type) (deref-pointer-runtime-typed ptr (ffi-to-uffi-type type))) (eval-when (compile load eval) (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))) + ulong int long single-float double-float otherwise *gtk-debug* load-gtk-libs + col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter +c-null+)))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp:/tmp/cvs-serv16135/root/gtk-ffi Modified Files: gtk-ffi.asd Log Message: Don't use utils.lisp (never was in CVS repository) don't use package :uffi --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd 2006/02/16 18:02:59 1.12 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd 2006/02/19 20:16:57 1.13 @@ -11,10 +11,9 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :cffi :cffi-uffi-compat) + :depends-on (:cells :pod-utils :cffi :cffi-uffi-compat) :components - ((:file "utils") - (:file "gtk-ffi" :depends-on ("utils")) + ((:file "gtk-ffi") (:file "gtk-core" :depends-on ("gtk-ffi")) (:file "gtk-other" :depends-on ("gtk-ffi")) (:file "gtk-button" :depends-on ("gtk-ffi"))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp:/tmp/cvs-serv15199/root/gtk-ffi Modified Files: gtk-core.lisp Log Message: Use uffi package prefix --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp 2006/02/16 18:02:17 1.7 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp 2006/02/19 20:15:07 1.8 @@ -47,7 +47,7 @@ (gdk-threads-leave :void ()) (gdk-flush :void ())) -(def-union g-value-data +(uffi:def-union g-value-data (v-int :int) (v-uint :unsigned-int) (v-long :long) @@ -60,7 +60,7 @@ (v-double :double) (v-pointer :pointer-void)) -(def-struct g-value +(uffi:def-struct g-value (g-type (:array :int 16))) (defmacro with-g-value ((var) &body body) @@ -72,7 +72,7 @@ (unwind-protect (dotimes (n 16) (let* ((gv (cffi:mem-aref gva 'g-value 0)) - (ns (get-slot-pointer gv 'g-value 'g-type))) + (ns (cffi:foreign-slot-value gv 'g-value 'g-type))) (setf (cffi:mem-aref ns ':int n) 0)))) (funcall fn gva) (cffi:foreign-free gva)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14819/root/cells-gtk Modified Files: widgets.lisp Log Message: uffi --> cffi --- /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/02/16 18:18:56 1.17 +++ /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/02/19 20:14:26 1.18 @@ -52,7 +52,7 @@ (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100))) -(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id))) +(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) (let ((known (gethash hash-id *gtk-objects*))) @@ -68,10 +68,10 @@ (defun gtk-object-forget (gtk-id gtk-object) (when gtk-id (assert *gtk-objects*) - (remhash (pointer-address gtk-id) *gtk-objects*) + (remhash (cffi:pointer-address gtk-id) *gtk-objects*) (mapc #'(lambda (k) (gtk-object-forget (id k) k)) (kids gtk-object)))) -(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) +(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* (let ((clos-widget (gethash hash-id *gtk-objects*))) (when (and must-find-p (not clos-widget)) @@ -115,7 +115,7 @@ (defmacro def-gtk-event-handler (event) `(cffi:defcallback ,(intern (format nil "~a-HANDLER" event)) :int ((widget :pointer) (event :pointer) (data :pointer)) - (bif (self (gtk-object-find widget)) + (if-bind (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (string event) :keyword)))) (funcall cb self widget event data)) (trc nil "Unknown widget from prior run. Clean up on errors" widget))))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14780/root/cells-gtk Modified Files: tree-view.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/02/16 18:18:02 1.14 +++ /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/02/19 20:13:51 1.15 @@ -113,7 +113,7 @@ (cffi:defcallback tree-view-select-handler :void ((column-widget :pointer) (event :pointer) (data :pointer)) - (bif (tree-view (gtk-object-find column-widget)) + (if-bind (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) (trc "Clean up old widgets after runs" column-widget)) @@ -211,7 +211,7 @@ (cffi:defcallback tree-view-render-cell-callback :int ((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer) (iter :pointer) (data :pointer)) - (bif (self (gtk-object-find tree-column)) + (if-bind (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb nil "no :render-cell callback for ~a" self) (funcall cb tree-column cell-renderer tree-model iter data))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14761/root/cells-gtk Modified Files: textview.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/02/16 18:17:22 1.8 +++ /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/02/19 20:13:26 1.9 @@ -72,8 +72,8 @@ (cffi:defcallback text-view-populate-popup-handler :void ((widget :pointer) (signal :pointer) (data :pointer)) (let ((popup-menu (gtk-adds-text-view-popup-menu widget))) - (bwhen (text-view (gtk-object-find widget)) - (bwhen (cb (callback-recover text-view :populate-popup)) + (when-bind (text-view (gtk-object-find widget)) + (when-bind (cb (callback-recover text-view :populate-popup)) (funcall cb popup-menu)))) 1) @@ -93,7 +93,7 @@ item))) #'(lambda (popup-menu) (loop for old in (old-popups text-view) do - (bwhen (sub (submenu old)) + (when-bind (sub (submenu old)) (gtk-object-forget (id sub) sub)) (gtk-object-forget (id old) old)) (let ((tops (mapcar #'do-padds p-adds)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14740/root/cells-gtk Modified Files: packages.lisp Log Message: package does not use :ukt or :uffi --- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/02/16 18:16:55 1.4 +++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/02/19 20:12:58 1.5 @@ -18,7 +18,7 @@ (defpackage :cells-gtk (:nicknames :cgtk) - (:use :common-lisp :utils-kt :pod :cells :gtk-ffi :uffi )) + (:use :common-lisp :pod :cells :gtk-ffi))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14720/root/cells-gtk Modified Files: menus.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/02/16 18:16:28 1.12 +++ /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/02/19 20:12:16 1.13 @@ -78,12 +78,12 @@ '(:string :string) pfunc (children-fn self))) ;; Spec says iter must correspond to a path of depth one. But then there would be no point ;; in set-active-iter. Well, the spec seems to be wrong (or poorly worded). - (bwhen (path (init self)) + (when-bind (path (init self)) (cgtk-set-active-item-by-path self path))))) (defmethod cgtk-set-active-item-by-path ((self combo-box) path) "Sets the value of the tree-model type combo-box to the item at the path. Path is a list of integers." - (bwhen (tree (tree-model self)) + (when-bind (tree (tree-model self)) (with-tree-iters (it) (when (gtk-tree-model-get-iter-from-string (id tree) it (format nil "~{~A~^:~}" path)) (gtk-combo-box-set-active-iter (id self) it) @@ -97,7 +97,7 @@ (when new-value (dolist (item (items self)) (gtk-combo-box-append-text (id self) (funcall (print-fn self) item))) - (bif (index (position (init self) (items self))) + (if-bind (index (position (init self) (items self))) (progn (gtk-combo-box-set-active (id self) index) (setf (md-value self) (init self))) (progn (gtk-combo-box-set-active (id self) 0)

1 0