[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp
Peter Denno
pdenno at common-lisp.net
Tue Jan 3 19:07:40 UTC 2006
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))
- , at 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 , at 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 , at 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)))
More information about the Cells-gtk-cvs
mailing list