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

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30569/root/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: CFFI : removed lots of ifdef'ed stuff. Date: Tue Jan 3 20:10:45 2006 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.15 root/gtk-ffi/gtk-utilities.lisp:1.16 --- root/gtk-ffi/gtk-utilities.lisp:1.15 Sat Oct 8 16:50:26 2005 +++ root/gtk-ffi/gtk-utilities.lisp Tue Jan 3 20:10:45 2006 @@ -25,7 +25,7 @@ (g-signal-connect-data widget signal fun data destroy-data after)) (defun g-signal-connect-data (self detailed-signal c-handler data destroy-data after) - (with-cstrings ((c-detailed-signal detailed-signal)) + (uffi:with-cstrings ((c-detailed-signal detailed-signal)) (let ((p4 (or data c-null))) (g_signal_connect_data self @@ -38,7 +38,7 @@ (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 :call-direct nil) + :returning :unsigned-long) (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. (or func-address 0)) @@ -84,7 +84,6 @@ (ffx:ff-defun-callable :cdecl :int button-press-event-handler ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) - (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) (when (or (eql (event-type event) :button_press) (eql (event-type event) :button_release)) @@ -193,23 +192,9 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - #-(or lispworks cmu sbcl allegro) (cast item (as-gtk-type-name cell-type)) - #+allegro (case cell-type (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) - (t (cast item (as-gtk-type-name cell-type)))) - #+lispworks - (case cell-type - (:string (fli:convert-from-foreign-string (deref-pointer item))) - (t (deref-pointer item))) - #+cmu - (case cell-type - (:string (alien:cast (alien:deref item) c-call:c-string)) - (t (alien:deref item))) - #+sbcl - (case cell-type - (:string (sb-alien:cast (sb-alien:deref item) sb-c-call:c-string)) - (t (sb-alien:deref item))))) + (t (cast item (as-gtk-type-name cell-type)))))) (defun parse-cell-attrib (attribs) (loop for (attrib val) on attribs by #'cddr collect @@ -220,32 +205,6 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) -#+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))) - -#+sbcl -(sb-alien:def-alien-type all-types - (sb-alien:struct c-struct - (:string (* t)) - (:icon (* t)) - (:boolean boolean) - (:int integer) - (:long sb-c-call:long) - (:date single-float) - (:float single-float) - (:double double-float))) - - -#-cmu (progn (defun alloc-col-type-buffer (col-type) (ecase col-type @@ -269,37 +228,6 @@ (: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) @@ -313,11 +241,9 @@ (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 (cond - (ret$ #-lispworks (convert-from-cstring ret$) - #+lispworks (convert-from-foreign-string ret$ - :null-terminated-p t)) + returned-value)) + (item-value (cond + (ret$ (convert-from-cstring ret$)) ((eq col-type :boolean) (not (zerop returned-value))) (t returned-value)))) @@ -345,111 +271,6 @@ (uffi:free-foreign-object ret$)) (ffx:fgn-free return-buffer))) 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)))))) - -#+sbcl -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter data) - (sb-alien:with-alien ((struct all-types)) - (gtk-tree-model-get model iter col - (sb-alien:addr (sb-alien:slot struct col-type)) - -1) - (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) - (get-gtk-string (sb-alien:slot struct col-type)) - (sb-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 (sb-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)))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-other.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30538/root/gtk-ffi Modified Files: gtk-other.lisp Log Message: Added gtk-main-level. Date: Tue Jan 3 20:09:41 2006 Author: pdenno Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.10 root/gtk-ffi/gtk-other.lisp:1.11 --- root/gtk-ffi/gtk-other.lisp:1.10 Fri Nov 18 05:35:32 2005 +++ root/gtk-ffi/gtk-other.lisp Tue Jan 3 20:09:41 2006 @@ -34,6 +34,7 @@ boolean nil nil) (gtk-main ()) (gtk-main-quit ()) + (gtk-main-level () int) (gtk-get-current-event-time () uint32)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-list-tree.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30518/root/gtk-ffi Modified Files: gtk-list-tree.lisp Log Message: CFFI : tree-store use c-pointer not array pointer Date: Tue Jan 3 20:08:51 2006 Author: pdenno Index: root/gtk-ffi/gtk-list-tree.lisp diff -u root/gtk-ffi/gtk-list-tree.lisp:1.3 root/gtk-ffi/gtk-list-tree.lisp:1.4 --- root/gtk-ffi/gtk-list-tree.lisp:1.3 Sun May 29 23:21:00 2005 +++ root/gtk-ffi/gtk-list-tree.lisp Tue Jan 3 20:08:51 2006 @@ -36,7 +36,7 @@ ;;tree-store (gtk-tree-store-newv ((n-columns int) - (col-types (c-array-ptr int))) + (col-types c-pointer)) c-pointer) (gtk-tree-store-set-valist ((store c-pointer) (iter c-pointer)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30493/root/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: CFFI : removed lots of ifdefs. Date: Tue Jan 3 20:07:40 2006 Author: pdenno Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.13 root/gtk-ffi/gtk-ffi.lisp:1.14 --- root/gtk-ffi/gtk-ffi.lisp:1.13 Sat Oct 8 16:48:03 2005 +++ root/gtk-ffi/gtk-ffi.lisp Tue Jan 3 20:07:39 2006 @@ -17,19 +17,16 @@ |# -(defpackage :gtk-ffi (:use #-sbcl :lisp #+sbcl :cl :utils-kt #-clisp :ffx #+clisp :ffi #-clisp :uffi)) +(defpackage :gtk-ffi (:use :lisp :ffx + :uffi)) (in-package :gtk-ffi) -(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* :void))) -(defconstant c-null-int #+clisp nil #-clisp (make-null-pointer :int)) +(defconstant c-null (make-null-pointer '(* :void))) +(defconstant c-null-int (make-null-pointer :int)) (defvar *gtk-debug* nil) -#+clisp -(defmacro with-cstring ((var str) &body body) - `(let ((,var ,str)) - ,@body)) (defun int-slot-indexed (obj obj-type slot index) (declare (ignorable obj-type)) @@ -49,6 +46,15 @@ (export '(c-null c-null-int int-slot-indexed load-gtk-libs)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) + (defun libname (lib) + (ecase lib + (:gobject #+win32 "libgobject-2.0-0.dll" + #-win32 "libgobject-2.0.so") + (:glib #+win32 "libglib-2.0-0.dll") + (:gthread #+win32 "libgthread-2.0-0.dll") + (:gdk #+win32 "libgdk-win32-2.0-0.dll") + (:gtk #+win32 "libgtk-win32-2.0-0.dll") + #+libcellsgtk (:cgtk "libcellsgtk.dll"))) (defun load-gtk-libs () (macrolet ((loadit (libname module) `(uffi:load-foreign-library @@ -79,10 +85,11 @@ (loadit "libgdk-x11-2.0.so" :gdk) (loadit "libgtk-x11-2.0.so" :gtk) #+libcellsgtk(loadit "libcellsgtk.so" :cgtk)))) - #+(or cmu sbcl)(load-gtk-libs) + #+cmu(load-gtk-libs) + #+clisp(load-gtk-libs) (defun ffi-to-uffi-type (clisp-type) - #+clisp clisp-type - #-clisp (if (consp clisp-type) + + (if (consp clisp-type) (mapcar 'ffi-to-uffi-type clisp-type) (case clisp-type ((nil) :void) @@ -103,7 +110,7 @@ (single-float :float) (double-float :double) (otherwise clisp-type)))) - #-clisp + (defun ffi-to-native-type (ffi-type) (uffi::convert-from-uffi-type (ffi-to-uffi-type ffi-type) :type))) ;; END eval-when @@ -111,22 +118,10 @@ (defmacro def-gtk-function (library name &key arguments return-type (return-type-allocation :none) (call-direct t)) - (declare (ignore #+clisp call-direct #-clisp return-type-allocation)) + (declare (ignore return-type-allocation call-direct)) (let* ((gtk-name$ (gtk-function-name (string-downcase (symbol-name name)))) (gtk-name (intern (string-upcase gtk-name$)))) - #+clisp - `(progn - (def-call-out ,name - (:name ,gtk-name$) - (:library ,(libname library)) - ,@(when arguments `((:arguments ,@arguments))) - (:return-type ,return-type ,return-type-allocation) - (:language :stdc)) - (eval-when (compile load eval) - (print `(exporting ,name)) - (export ',name))) - #-clisp (let ((arg-info (loop for arg in arguments for gsym = (gensym) @@ -148,7 +143,6 @@ (list name (ffi-to-uffi-type type)))) arguments) :module ,(string library) - :call-direct ,call-direct :returning ,(ffi-to-uffi-type return-type)) (defun ,name ,(mapcar 'car arguments) (when *gtk-debug* @@ -161,7 +155,11 @@ (,gtk-name ,@(cadr arg-info))))) (if (eql return-type 'boolean) `(not (zerop ,bodyform)) - bodyform)) + (if (eql return-type 'c-string) + `(convert-from-cstring ,bodyform) + bodyform) + )) + (when *gtk-debug* ,(unless (or (string= (symbol-name name) "GTK-EVENTS-PENDING") (string= (symbol-name name) "GTK-MAIN-ITERATION-DO")) @@ -186,15 +184,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro callback-function ((&rest arguments) &optional return-type) - (declare (ignore #-clisp arguments #-clisp return-type)) - #+clisp `'(c-function - ,@(when arguments `((:arguments ,@arguments))) - (:return-type ,(ffi-to-uffi-type return-type)) - (:language :stdc)) - #-clisp `'c-pointer)) + (declare (ignore arguments return-type)) + `'c-pointer)) + -#-clisp (defmacro def-c-struct (struct-name &rest fields) (let ((slot-defs (loop for field in fields collecting (destructuring-bind (name type) field @@ -319,7 +313,7 @@ (32 :window_state) (33 :setting))) -#-clisp + (uffi:def-struct list-boolean (value :unsigned-int) (end :pointer-void)) @@ -367,7 +361,7 @@ (user-data3 c-pointer)) (defmacro with-tree-iter ((iter-var) &body body) - `(with-foreign-object (,iter-var 'gtk-tree-iter) + `(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) @@ -397,8 +391,6 @@ (:double (* 15 4)) (:boolean (* 5 4))))) - - (defun col-type-to-ffi-type (col-type) (cdr (assoc col-type '((:string . c-string) ;;2004:12:15-00:17 was c-pointer (:icon . c-pointer) @@ -412,14 +404,7 @@ (defmacro deref-pointer-runtime-typed (ptr type) "Returns a object pointed" (declare (ignorable type)) - #+(or cmu sbcl lispworks scl) (declare (ignore type)) - #+scl `(alien:deref ,ptr) - #+cmu `(alien:deref ,ptr) - #+sbcl `(sb-alien:deref ,ptr) - #+lispworks `(fli:dereference ,ptr) - #+allegro `(ff:fslot-value-typed (uffi::convert-from-uffi-type ,type :deref) :c ,ptr) - #+mcl `(ccl:pref ,ptr (uffi::convert-from-uffi-type ,type :deref)) - ) + `(deref-pointer ,ptr ,type)) (defun cast (ptr type) (deref-pointer-runtime-typed ptr (ffi-to-uffi-type type)))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.asd
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30470/root/gtk-ffi Modified Files: gtk-ffi.asd Log Message: CFFI: load cffi not hello-c, use *gtk-lib-path* on cmucl (STILL unresolved!). Date: Tue Jan 3 20:06:22 2006 Author: pdenno Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.9 root/gtk-ffi/gtk-ffi.asd:1.10 --- root/gtk-ffi/gtk-ffi.asd:1.9 Thu Nov 3 23:39:59 2005 +++ root/gtk-ffi/gtk-ffi.asd Tue Jan 3 20:06:22 2006 @@ -9,30 +9,25 @@ ;;; Step 1 -- If you are not using Linux nor BSD and the GTK libs are not ;;; in the places specified below, adjust these. -#+macosx (setf *gtk-lib-path* "/sw/lib/") -#+(or win32 mswindows) (setf *gtk-lib-path* "C:/Program Files/Common Files/GTK/2.0/bin/") +;;; Specify for Lispworks (definitely), other maybe. +#+macosx(setf *gtk-lib-path* "/sw/lib/") +#+(or win32 mswindows)(setf *gtk-lib-path* "E:/GTK/bin/") +;#-(or macosx win32 mswindows)(setf *gtk-lib-path* "/usr/lib/") +#-(or macosx win32 mswindows)(setf *gtk-lib-path* "/opt/gnome/lib/") ; For my SuSE machine -;;; This need not be specified for cmucl (leave as a null string). -#+cmu(setf *gtk-lib-path* "/usr/lib/") -;#+(OR cmu sbcl)(setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine - -;;; Specify for Lispworks. -#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/usr/lib/") -;#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine - -;;; Step 2 -- If you built libcellsgtk.so, uncomment the next line. -;(pushnew :libcellsgtk *features*) +;;; Step 2 -- If you built or downloaded the libcellsgtk library, uncomment the next line. +(pushnew :libcellsgtk *features*) (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :hello-c) + :depends-on (:cells :cffi :cffi-uffi-compat) :components - ((:file "gtk-ffi") + ((:file "ffx") ; Novikov Leonid's compatibility stuff from hello-c + (:file "gtk-ffi" :depends-on ("ffx")) (:file "gtk-core" :depends-on ("gtk-ffi")) (:file "gtk-other" :depends-on ("gtk-ffi")) - (:file "gdk-other" :depends-on ("gtk-ffi")) (:file "gtk-button" :depends-on ("gtk-ffi")) (:file "gtk-tool" :depends-on ("gtk-ffi")) (:file "gtk-menu" :depends-on ("gtk-ffi")) (:file "gtk-list-tree" :depends-on ("gtk-ffi")) - (:file "gtk-utilities" :depends-on ("gtk-core" "gtk-other")))) \ No newline at end of file + (:file "gtk-utilities" :depends-on ("gtk-core" "gtk-other"))))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30441/root/gtk-ffi Modified Files: gtk-core.lisp Log Message: CFFI : removed various ifdefs. Date: Tue Jan 3 20:05:18 2006 Author: pdenno Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.4 root/gtk-ffi/gtk-core.lisp:1.5 --- root/gtk-ffi/gtk-core.lisp:1.4 Sat Oct 8 16:44:40 2005 +++ root/gtk-ffi/gtk-core.lisp Tue Jan 3 20:05:17 2006 @@ -67,33 +67,18 @@ (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))))) - -#+sbcl -(ffx:def-type g-value-type - (* (sb-alien:struct gtk-ffi::g-value - (gtk-ffi::g-type (array (sb-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))) - #+(or cmu sbcl) (declare (type g-value-type gva)) (unwind-protect - (progn - (dotimes (n 16) - (let ((gv (ff-elt gva 'g-value 0))) + (dotimes (n 16) + (let ((gv (ffx: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)) + (setf (deref-array ns '(:array :int) n) 0)))) + (funcall fn gva) (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value)) - #+test (def-gtk-lib-functions :gobject

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/drawing.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30407/root/cells-gtk Modified Files: drawing.lisp Log Message: trivial Date: Tue Jan 3 20:03:33 2006 Author: pdenno Index: root/cells-gtk/drawing.lisp diff -u root/cells-gtk/drawing.lisp:1.2 root/cells-gtk/drawing.lisp:1.3 --- root/cells-gtk/drawing.lisp:1.2 Fri Nov 4 16:02:05 2005 +++ root/cells-gtk/drawing.lisp Tue Jan 3 20:03:33 2006 @@ -56,7 +56,6 @@ (gdk-draw-drawable cgtk::*window* cgtk::*gcontext* drawable 0 0 dx dy -1 -1))))) 0) -;;; data is not used, AFAIK. (defun gtk-drawing-set-handlers (widget data) (gtk-signal-connect-swap widget "button-press-event" (ffx:ff-register-callable 'drawing-button-events-handler) @@ -70,7 +69,6 @@ (gtk-signal-connect-swap widget "expose-event" (ffx:ff-register-callable 'drawing-expose-event-handler) :data data)) - (export '(gtk-drawing-set-handlers)) ;;;============================================================================

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30390/root/cells-gtk Modified Files: widgets.lisp Log Message: CFFI : removed #+clisp stuff Date: Tue Jan 3 20:03:02 2006 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.14 root/cells-gtk/widgets.lisp:1.15 --- root/cells-gtk/widgets.lisp:1.14 Sat Oct 8 16:33:19 2005 +++ root/cells-gtk/widgets.lisp Tue Jan 3 20:03:02 2006 @@ -209,11 +209,6 @@ ,@signals-outputs))))) (defmacro callback ((widg event data) &body body) - #+clisp - `(c? (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - ,@body t))) - #-clisp `(lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) ;(print (list :anon-callback self ,widg ,event ,data)) @@ -225,10 +220,7 @@ (defmacro callback-if (condition (widg event data) &body body) `(c? (and ,condition - #+clisp (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - ,@body t)) - #-clisp (lambda (self ,widg ,event ,data) + (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) ;(print (list :anon-callback-if self ,widg ,event ,data)) ,@body @@ -298,7 +290,7 @@ (not-to-be old-value)) (when new-value (gtk-widget-set-popup (id self) (id (to-be new-value))))) - + (def-c-output visible ((self widget)) (if new-value (gtk-widget-show (id self)) @@ -393,6 +385,7 @@ (gtk-container-add (id self) (id (first new-value)))) #+clisp (call-next-method)) +(declaim (inline widget-id)) (defun widget-id (widget) (id widget))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/tree-view.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30370/root/cells-gtk Modified Files: tree-view.lisp Log Message: Misplaced declare ignore makes clisp and cmucl error. Date: Tue Jan 3 20:01:59 2006 Author: pdenno Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.11 root/cells-gtk/tree-view.lisp:1.12 --- root/cells-gtk/tree-view.lisp:1.11 Sun May 29 23:13:06 2005 +++ root/cells-gtk/tree-view.lisp Tue Jan 3 20:01:59 2006 @@ -84,7 +84,6 @@ ;;; Used by combo-box also, when it is using a tree model. (ff-defun-callable :cdecl :void tree-view-items-selector ((model :pointer-void) (path :pointer-void) (iter :pointer-void) (data :pointer-void)) - (declare (ignore path data)) (let ((tree (of-tree (gtk-object-find model)))) (push (item-from-path (children-fn tree)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/textview.lisp
by pdenno＠common-lisp.net 03 Jan '06

03 Jan '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30350/root/cells-gtk Modified Files: textview.lisp Log Message: Misplaced declare ignore makes clisp and cmucl error. Date: Tue Jan 3 20:01:20 2006 Author: pdenno Index: root/cells-gtk/textview.lisp diff -u root/cells-gtk/textview.lisp:1.5 root/cells-gtk/textview.lisp:1.6 --- root/cells-gtk/textview.lisp:1.5 Sat Oct 8 16:31:24 2005 +++ root/cells-gtk/textview.lisp Tue Jan 3 20:01:20 2006 @@ -71,7 +71,6 @@ (ff-defun-callable :cdecl :void text-view-populate-popup-handler ((widget :pointer-void) (signal :pointer-void) (data :pointer-void)) - (declare (ignorable signal data)) (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))

1 0