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
