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)))