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

Modified Files: gtk-ffi.lisp Log Message: Now native CFFI, use CFFI type translation. Reworked macros def-gtk-lib-function, def-gtk-function

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/02/11 03:45:55 1.16 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/02/16 18:04:29 1.17 @@ -16,16 +16,56 @@

|#

- -(defpackage :gtk-ffi (:use :common-lisp :uffi)) +(defpackage :gtk-ffi (:use :common-lisp :pod :uffi)) ; pod remove uffi

(in-package :gtk-ffi)

-(defconstant c-null (make-null-pointer '(* :void))) -(defconstant c-null-int (make-null-pointer :int)) +;;; POD throw-away utility +(defun gtk-lib2cffi (body) + "Convert hello-c to uffi to cffi types. Swap order of arguments." + (flet ((convert-type (type) + (case type + (c-string :gtk-string) + (boolean :gtk-boolean) + (t (cffi-uffi-compat::convert-uffi-type (ffi-to-uffi-type type)))))) + (dbind (ignore module &rest funcs) body + (pprint `(,ignore + ,module + ,@(mapcar + #'(lambda (f) + (dbind (name args &optional return-type) f + ` (,name + ,(if return-type + (convert-type return-type) + :void) + ,(mapcar #'(lambda (a) + (list + (car a) + (convert-type (cadr a)))) + args)))) + funcs)) + *standard-output*)))) +

+(defconstant +c-null+ (cffi:null-pointer)) (defvar *gtk-debug* nil)

+;;; ============== Define CFFI types, and their translations.... +(cffi:defctype :gtk-string :pointer :documentation "string type for cffi type translation") +(cffi:defctype :gtk-boolean :pointer :documentation "boolean type for cffi type translation") + +(defmethod cffi:translate-to-foreign (value (type (eql :gtk-boolean))) + (cffi:make-pointer (if value 1 0))) + +(defmethod cffi:translate-from-foreign (value (type (eql :gtk-boolean))) + (not (zerop (cffi::pointer-address value)))) ; pod strange! + +(defmethod cffi:translate-to-foreign (value (type (eql :gtk-string))) + (when (null value) (setf value "")) ; pod ??? + (cffi:foreign-string-alloc value)) + +(defmethod cffi:translate-from-foreign (value (type (eql :gtk-string))) + (cffi:foreign-string-to-lisp value))

(defun int-slot-indexed (obj obj-type slot index) (declare (ignorable obj-type)) @@ -40,53 +80,69 @@ '(:array :int) index) new-value))

+(cffi:define-foreign-library 'gobject + (:linux "libgobject-2.0.so") + (:win32 "libgobject-2.0-0.dll") + (:macosx "libgobject-2.0-0.dylib")) + +(cffi:define-foreign-library :glib + (:linux "libglib-2.0.so") + (:win32 "libglib-2.0-0.dll") + (:macosx "libglib-2.0-0.dylib")) + +(cffi:define-foreign-library :gthread + (:linux "libgthread-2.0.so") + (:win32 "libgthread-2.0-0.dll") + (:macosx "libgthread-2.0-0.dylib")) + +(cffi:define-foreign-library :gdk + (:linux "libgdk-x11-2.0.so") + (:win32 "libgdk-win32-2.0-0.dll") + (:macosx "libgdk-win32-2.0-0.dylib")) ; pod ??? + +(cffi:define-foreign-library :gtk + (:linux "libgtk-x11-2.0.so") + (:win32 "libgtk-win32-2.0-0.dll") + (:macosx "libgtk-win32-2.0-0.dylib")) ; pod ??? + +#+libcellsgtk +(cffi:define-foreign-library :cgtk + (:linux "libcellsgtk.so") + (:win32 "libcellsgtk.dll") + (:macosx "libcellsgtk.dylib")) + +;;; After doing this, should be able to do (g-thread-init c-null) +;;; The above define-foreigh-library appears to be useless (doesn't +;;; work through the symbols) use the names. +(defun load-gtk-libs () + (handler-bind ((style-warning #'muffle-warning)) + (cffi:load-foreign-library #+linux "libgobject-2.0.so" + #+win32 "libgobject-2.0-0.dll" + #+macosx "libgobject-2.0-0.dylib") + (cffi:load-foreign-library #+linux "libglib-2.0.so" + #+win32 "libglib-2.0-0.dll" + #+macosx "libglib-2.0-0.dylib") + (cffi:load-foreign-library #+linux "libgthread-2.0.so" + #+win32 "libgthread-2.0-0.dll" + #+macosx "libgthread-2.0-0.dylib") + (cffi:load-foreign-library #+linux "libgdk-x11-2.0.so" + #+win32 "libgdk-win32-2.0-0.dll" + #+macosx "libgdk-win32-2.0-0.dylib") + (cffi:load-foreign-library #+linux "libgtk-x11-2.0.so" + #+win32 "libgtk-win32-2.0-0.dll" + #+macosx "libgtk-win32-2.0-0.dylib") + #+libcellsgtk + (cffi:load-foreign-library #+linux "libcellsgtk.so" + #+win32 "libcellsgtk.dll" + #+macosx "libcellsgtk.dylib")))

(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(c-null c-null-int int-slot-indexed load-gtk-libs)) + (export '(+c-null+ 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) - `(handler-bind ((style-warning #'muffle-warning)) - (uffi:load-foreign-library - (concatenate 'string cl-user::*gtk-lib-path* ,libname) - :force-load #+lispworks t #-lispworks nil - :module ,(string module))))) - #+(or win32 mswindows) - (progn - (loadit "libgobject-2.0-0.dll" :gobject) - (loadit "libglib-2.0-0.dll" :glib) - (loadit "libgthread-2.0-0.dll" :gthread) - (loadit "libgdk-win32-2.0-0.dll" :gdk) - (loadit "libgtk-win32-2.0-0.dll" :gtk) - #+libcellsgtk(loadit "libcellsgtk.dll" :cgtk)) - #+macosx - (progn - (loadit "libgobject-2.0-0.dynlib" :gobject) - (loadit "libglib-2.0-0.dynlib" :glib) - (loadit "libgthread-2.0-0.dynlib" :gthread) - (loadit "libgdk-win32-2.0-0.dynlib" :gdk) - (loadit "libgtk-win32-2.0-0.dynlib" :gtk) - #+libcellsgtk(loadit "libcellsgtk.dynlib" :cgtk)) - #-(or macosx win32 mswindows) - (progn - (loadit "libgobject-2.0.so" :gobject) - (loadit "libglib-2.0.so" :glib) - (loadit "libgthread-2.0.so" :gthread) - (loadit "libgdk-x11-2.0.so" :gdk) - (loadit "libgtk-x11-2.0.so" :gtk) - #+libcellsgtk(loadit "libcellsgtk.so" :cgtk)))) - #+cmu(load-gtk-libs) - #+clisp(load-gtk-libs) + + #+(or cmu clisp)(load-gtk-libs) + (defun ffi-to-uffi-type (clisp-type)

(if (consp clisp-type) @@ -110,85 +166,41 @@ (single-float :float) (double-float :double) (otherwise clisp-type)))) +) ;eval

- (defun ffi-to-native-type (ffi-type) - (uffi::convert-from-uffi-type - (ffi-to-uffi-type ffi-type) :type))) ;; END eval-when - -(defmacro def-gtk-function (library name &key arguments return-type - (return-type-allocation :none) - (call-direct t)) - (declare (ignore return-type-allocation call-direct)) - +(defmacro def-gtk-function (library name return-type arguments) + (declare (ignore library)) (let* ((gtk-name$ (gtk-function-name (string-downcase (symbol-name name)))) (gtk-name (intern (string-upcase gtk-name$)))) - (let ((arg-info - (loop for arg in arguments - for gsym = (gensym) - if (eql 'c-string (cadr arg)) - collect (car arg) into arg$s - and collect gsym into gsyms - and collect gsym into pass-args - else if (eql 'boolean (cadr arg)) - collect `(if ,(car arg) 1 0) into pass-args - else if (eql 'c-pointer (cadr arg)) - collect `(or ,(car arg) c-null) into pass-args - else collect (car arg) into pass-args - finally (return (list (mapcar 'list gsyms arg$s) - pass-args))))) - `(progn - (uffi:def-function (,gtk-name$ ,gtk-name) - ,(mapcar (lambda (name-type) - (destructuring-bind (name type) name-type - (list name (ffi-to-uffi-type type)))) - arguments) - :module ,(string library) - :returning ,(ffi-to-uffi-type return-type)) - (defun ,name ,(mapcar 'car arguments) - (when *gtk-debug* - ,(unless (or (string= (symbol-name name) "GTK-EVENTS-PENDING") - (string= (symbol-name name) "GTK-MAIN-ITERATION-DO")) - `(print (list ,(symbol-name name) :before ,@(mapcar 'car arguments))))) - (prog1 - ,(let ((bodyform `(with-cstrings - ,(car arg-info) - (,gtk-name ,@(cadr arg-info))))) - (if (eql return-type 'boolean) - `(not (zerop ,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")) - `(print (list ,(symbol-name name) :after ,@(mapcar 'car arguments))))))) - (eval-when (compile load eval) - (export ',name)))))) + `(progn + (cffi:defcfun (,gtk-name$ ,gtk-name) ,return-type ,@arguments) + (defun ,name ,(mapcar 'car arguments) + (when *gtk-debug* + ,(unless (or (string= (symbol-name name) "GTK-EVENTS-PENDING") + (string= (symbol-name name) "GTK-MAIN-ITERATION-DO")) + `(format *trace-output* "~%before (~A ~{~A~^ ~})" + ,(string-downcase (string name)) (list ,@(mapcar 'car arguments))))) + (prog1 + (,gtk-name ,@(mapcar #'car arguments)) + (when *gtk-debug* + ,(unless (or (string= (symbol-name name) "GTK-EVENTS-PENDING") + (string= (symbol-name name) "GTK-MAIN-ITERATION-DO")) + `(format *trace-output* "~%after (~A ~{~A~^ ~})" + ,(string-downcase (string name)) (list ,@(mapcar 'car arguments))))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name)))))

(defmacro def-gtk-lib-functions (library &rest functions) `(progn ,@(loop for function in functions collect - (destructuring-bind (name (&rest args) - &optional return-type - return-type-allocation - (call-direct t)) function - `(def-gtk-function ,library ,name - ,@(when args `(:arguments ,args)) - :return-type ,return-type - ,@(when return-type-allocation - `(:return-type-allocation ,return-type-allocation)) - :call-direct ,call-direct))))) - + (destructuring-bind (name return-type (&rest args)) function + `(def-gtk-function ,library ,name ,return-type ,args)))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro callback-function ((&rest arguments) &optional return-type) (declare (ignore arguments return-type)) `'c-pointer))

- - (defmacro def-c-struct (struct-name &rest fields) (let ((slot-defs (loop for field in fields collecting (destructuring-bind (name type) field @@ -313,7 +325,6 @@ (32 :window_state) (33 :setting)))

- (uffi:def-struct list-boolean (value :unsigned-int) (end :pointer-void)) @@ -363,12 +374,11 @@ (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 (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) (ecase type