Hi,
I had some time to work on the port of CFFI to ECL and I have attached
most of the fixes. They include
+ Fixed the port to architectures without dynamical FFI. (In these
ports CFFI foreign function calls only work when lisp code is
compiled)
+ ECL supplies its own version of RT hence this need not appear in the
ASDF cffi-test.
+ Tests with too large number of arguments (> 34) are marked as
expected to fail, since ECL's FFI does not support such function
calls.
I had to play a few tricks because CFFI does not allow us to include
headers function declarations and ECL cannot rely on the arguments to
FOREIGN-FUNCALL which are most of the time bogus. For instance,
:string is an alias to :pointer and when you call (foreign-funcall
"strlen" :string .. ) we cannot produce a proper C declaration to
strlen that does not collide with the one provided by the header
<string.h>.
So in the end I end up always using the routine dlsym() to discover
the functions and coerce them to a function pointer created with the
information given by CFFI. The outcome is therefore much less
efficient than what ECL can potentially do.
Regards
Juanjo
diff -rN -u old-cffi.copy/cffi-tests.asd new-cffi.copy/cffi-tests.asd
--- old-cffi.copy/cffi-tests.asd 2006-10-11 22:13:16.000000000 +0200
+++ new-cffi.copy/cffi-tests.asd 2006-10-11 22:13:16.000000000 +0200
@@ -49,9 +49,12 @@
:directory *tests-dir*))))
(error 'operation-error :component c :operation o)))
+#+ecl
+(require 'rt)
+
(defsystem cffi-tests
:description "Unit tests for CFFI."
- :depends-on (cffi rt)
+ :depends-on (cffi #-ecl rt)
:components
((:module "tests"
:serial t
diff -rN -u old-cffi.copy/src/cffi-ecl.lisp new-cffi.copy/src/cffi-ecl.lisp
--- old-cffi.copy/src/cffi-ecl.lisp 2006-10-11 22:13:16.000000000 +0200
+++ new-cffi.copy/src/cffi-ecl.lisp 2006-10-11 22:13:16.000000000 +0200
@@ -44,6 +44,7 @@
#:%mem-ref
#:%mem-set
#:%foreign-funcall
+ #:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
@@ -137,14 +138,14 @@
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
- (let* ((type (convert-foreign-type type))
+ (let* ((type (cffi-type->ecl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-data-ref-elt
(si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
- (let* ((type (convert-foreign-type type))
+ (let* ((type (cffi-type->ecl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-data-set-elt
(si:foreign-data-recast ptr (+ offset type-size) :void)
@@ -152,75 +153,85 @@
;;;# Type Operations
-(defun convert-foreign-type (type-keyword)
+(defconstant +translation-table+
+ '((:char :byte "char")
+ (:unsigned-char :unsigned-byte "unsigned char")
+ (:short :short "short")
+ (:unsigned-short :unsigned-short "unsigned short")
+ (:int :int "int")
+ (:unsigned-int :unsigned-int "unsigned int")
+ (:long :long "long")
+ (:unsigned-long :unsigned-long "unsigned long")
+ (:float :float "float")
+ (:double :double "double")
+ (:pointer :pointer-void "void*")
+ (:void :void "void")))
+
+(defun cffi-type->ecl-type (type-keyword)
"Convert a CFFI type keyword to an ECL type keyword."
- (ecase type-keyword
- (:char :byte)
- (:unsigned-char :unsigned-byte)
- (:short :short)
- (:unsigned-short :unsigned-short)
- (:int :int)
- (:unsigned-int :unsigned-int)
- (:long :long)
- (:unsigned-long :unsigned-long)
- (:float :float)
- (:double :double)
- (:pointer :pointer-void)
- (:void :void)))
+ (or (second (find type-keyword +translation-table+ :key #'first))
+ (error "~S is not a valid CFFI type" type-keyword)))
+
+(defun ecl-type->c-type (type-keyword)
+ "Convert a CFFI type keyword to an valid C type keyword."
+ (or (third (find type-keyword +translation-table+ :key #'second))
+ (error "~S is not a valid CFFI type" type-keyword)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(nth-value 0 (ffi:size-of-foreign-type
- (convert-foreign-type type-keyword))))
+ (cffi-type->ecl-type type-keyword))))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(nth-value 1 (ffi:size-of-foreign-type
- (convert-foreign-type type-keyword))))
+ (cffi-type->ecl-type type-keyword))))
;;;# Calling Foreign Functions
-(defun produce-function-call (c-name nargs)
- (format nil "~a(~a)" c-name
- (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z"
- 0 (max 0 (1- (* nargs 3))))))
-
-#-dffi
-(defun foreign-function-inline-form (name arg-types arg-values return-type)
- "Generate a C-INLINE form for a foreign function call."
- `(ffi:c-inline
- ,arg-values ,arg-types ,return-type
- ,(produce-function-call name (length arg-values))
- :one-liner t :side-effects t))
-
-#+dffi
-(defun foreign-function-dynamic-form (name arg-types arg-values return-type)
- "Generate a dynamic FFI form for a foreign function call."
- `(si:call-cfun (si:find-foreign-symbol ,name :default :pointer-void 0)
- ,return-type (list ,@arg-types) (list ,@arg-values)))
+(defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
+
+(defun produce-function-pointer-call (pointer types values return-type)
+ #-dffi
+ (if (stringp pointer)
+;; `(ffi:c-inline ,values ,types ,return-type
+;; ,(format nil "~A(~A)" pointer
+;; (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3)))))
+;; :one-liner t :side-effects t)
+ (produce-function-pointer-call `(foreign-symbol-pointer ,pointer) types values return-type)
+ `(ffi:c-inline ,(list* pointer values) ,(list* :pointer-void types) ,return-type
+ ,(with-output-to-string (s)
+ (let ((types (mapcar #'ecl-type->c-type types)))
+ ;; On AMD64, the following code only works with the extra argument ",..."
+ ;; If this is not present, functions like sprintf do not work
+ (format s "((~A (*)([EMAIL PROTECTED],~}...~]))(#0))(~A)"
+ (ecl-type->c-type return-type) types
+ (subseq +ecl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3)))))))
+ :one-liner t :side-effects t))
+ #+dffi
+ `(si:call-cfun ,pointer ,return-type (list ,@arg-types) (list ,@arg-values)))
+
(defun foreign-funcall-parse-args (args)
"Return three values, lists of arg types, values, and result type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
- if arg collect (convert-foreign-type type) into types
+ if arg collect (cffi-type->ecl-type type) into types
and collect arg into values
- else do (setf return-type (convert-foreign-type type))
+ else do (setf return-type (cffi-type->ecl-type type))
finally (return (values types values return-type)))))
(defmacro %foreign-funcall (name &rest args)
"Call a foreign function."
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
- #-dffi (foreign-function-inline-form name types values return-type)
- #+dffi (foreign-function-dynamic-form name types values return-type)))
+ (produce-function-pointer-call name types values return-type)))
-#+dffi
(defmacro %foreign-funcall-pointer (ptr &rest args)
"Funcall a pointer to a foreign function."
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
- `(si:call-cfun ,ptr ,return-type (list ,@arg-types) (list ,@arg-values))))
+ (produce-function-pointer-call ptr types values return-type)))
;;;# Foreign Libraries
@@ -252,9 +263,9 @@
(let ((cb-name (intern-callback name)))
`(progn
(ffi:defcallback (,cb-name :cdecl)
- ,(convert-foreign-type rettype)
+ ,(cffi-type->ecl-type rettype)
,(mapcar #'list arg-names
- (mapcar #'convert-foreign-type arg-types))
+ (mapcar #'cffi-type->ecl-type arg-types))
,@body)
(setf (gethash ',name *callbacks*) ',cb-name))))
diff -rN -u old-cffi.copy/tests/bindings.lisp new-cffi.copy/tests/bindings.lisp
--- old-cffi.copy/tests/bindings.lisp 2006-10-11 22:13:16.000000000 +0200
+++ new-cffi.copy/tests/bindings.lisp 2006-10-11 22:13:16.000000000 +0200
@@ -48,7 +48,7 @@
#+(:and :ecl (:not :dffi))
(ffi:load-foreign-library
- #.(make-pathname :name "libtest" :type "o"
+ #.(make-pathname :name "libtest" :type "so"
:defaults (or *compile-file-truename* *load-truename*)))
;;; check libtest version
@@ -73,7 +73,7 @@
(defparameter *repeat* 1)
(defun run-cffi-tests (&key (compiled nil))
- (let ((rtest::*compile-tests* compiled)
+ (let ((rt::*compile-tests* compiled)
(*package* (find-package '#:cffi-tests)))
(format t "~2&How many times shall we run the tests (~Acompiled)? [~D]: "
(if compiled "" "un") *repeat*)
diff -rN -u old-cffi.copy/tests/callbacks.lisp new-cffi.copy/tests/callbacks.lisp
--- old-cffi.copy/tests/callbacks.lisp 2006-10-11 22:13:16.000000000 +0200
+++ new-cffi.copy/tests/callbacks.lisp 2006-10-11 22:13:16.000000000 +0200
@@ -260,8 +260,8 @@
(defcfun "call_sum_127_no_ll" :long (cb :pointer))
-;;; CMUCL chokes on this one.
-#-(:or :cmu #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
+;;; CMUCL and ECL choke on this one.
+#-(:or :ecl :cmu #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(defcallback sum-127-no-ll :long
((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double)
(a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned-int)
@@ -317,7 +317,7 @@
(format t "a~A: ~A~%" i arg))
(reduce #'+ args)))
-#+(or openmcl cmu (and cffi-features:darwin (or allegro lispworks)))
+#+(or openmcl cmu ecl (and cffi-features:darwin (or allegro lispworks)))
(push 'callbacks.bff.1 regression-test::*expected-failures*)
#+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or))
@@ -332,8 +332,8 @@
(progn
(defcfun "call_sum_127" :long-long (cb :pointer))
- ;;; CMUCL chokes on this one.
- #-cmu
+ ;;; CMUCL and ECL choke on this one.
+ #-(or cmu ecl)
(defcallback sum-127 :long-long
((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :double)
(a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
@@ -384,7 +384,7 @@
(values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127))
- #+(or openmcl cmu)
+ #+(or openmcl cmu ecl)
(push 'callbacks.bff.2 rt::*expected-failures*)
(deftest callbacks.bff.2
diff -rN -u old-cffi.copy/tests/defcfun.lisp new-cffi.copy/tests/defcfun.lisp
--- old-cffi.copy/tests/defcfun.lisp 2006-10-11 22:13:16.000000000 +0200
+++ new-cffi.copy/tests/defcfun.lisp 2006-10-11 22:13:16.000000000 +0200
@@ -193,7 +193,7 @@
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
-#+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or))
+#+(:and (:not :ecl) #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)))
(progn
(defcfun "sum_127_no_ll" :long
(a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
@@ -253,7 +253,7 @@
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
-#-(:or cffi-features:no-long-long
+#-(:or :ecl cffi-features:no-long-long
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(progn
(defcfun "sum_127" :long-long
_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
