Permalink
Browse files

Merge branch 'master' into libffi

Conflicts:
	tests/GNUmakefile
  • Loading branch information...
2 parents 50dec67 + ab10be4 commit 973ebad1bc00e49347ed73fd130f08bbccf44df1 @liamh liamh committed Mar 16, 2012
View
@@ -5,6 +5,7 @@
*.bundle
*.so
*.fasl
+*.xfasl
.DS_Store
doc/*.aux
doc/manual/
View
@@ -28,7 +28,7 @@
(in-package :asdf)
-#-(or openmcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp abcl)
+#-(or openmcl mcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp abcl)
(error "Sorry, this Lisp is not yet supported. Patches welcome!")
(defsystem :cffi
@@ -42,6 +42,7 @@
:serial t
:components
(#+openmcl (:file "cffi-openmcl")
+ #+mcl (:file "cffi-mcl")
#+sbcl (:file "cffi-sbcl")
#+cmu (:file "cffi-cmucl")
#+scl (:file "cffi-scl")
@@ -2355,7 +2355,7 @@ documentation.
@lisp
CFFI-USER> (convert-to-foreign "a boat" :string)
@result{} #<FOREIGN-ADDRESS #x097ACDC0>
-@result{} (T)
+@result{} T
CFFI-USER> (convert-from-foreign * :string)
@result{} "a boat"
@end lisp
@@ -2413,10 +2413,10 @@ documentation.
@lisp
CFFI-USER> (convert-to-foreign t :boolean)
@result{} 1
-@result{} (NIL)
+@result{} NIL
CFFI-USER> (convert-to-foreign "hello, world" :string)
@result{} #<FOREIGN-ADDRESS #x097C5F80>
-@result{} (T)
+@result{} T
CFFI-USER> (code-char (mem-aref * :char 5))
@result{} #\,
@end lisp
@@ -3475,8 +3475,8 @@ documentation.
@lisp
CFFI-USER> (convert-to-foreign "a boat" :string)
@result{} #<FOREIGN-ADDRESS #x097ACDC0>
-@result{} (T)
-CFFI-USER> (free-converted-object * :string '(t))
+@result{} T
+CFFI-USER> (free-converted-object * :string t)
@result{} NIL
@end lisp
View
@@ -249,7 +249,7 @@ int main(int argc, char**argv) {
;;; FIXME: is there a better way to detect whether these flags
;;; are necessary?
(defparameter *cpu-word-size-flags*
- (ecase (cffi:foreign-type-size :long)
+ (ecase (cffi:foreign-type-size :pointer)
(4 (list "-m32"))
(8 (list "-m64"))))
@@ -526,8 +526,9 @@ int main(int argc, char**argv) {
(setf (readtable-case *readtable*) :preserve)
(read-from-string str))))
(typecase c-parse
- (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name) ,type
- :read-only ,read-only))
+ (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name
+ :read-only ,read-only)
+ ,type))
(list (unless (and (= (length c-parse) 2)
(null (second c-parse))
(symbolp (first c-parse))
View
@@ -3,6 +3,7 @@
;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA.
;;;
;;; Copyright (C) 2009, Luis Oliveira <loliveira@common-lisp.net>
+;;; Copyright (C) 2012, Mark Evenson <evenson.not.org@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -27,11 +28,20 @@
;;; This implementation requires the Java Native Access (JNA) library.
;;; <http://jna.dev.java.net/>
+;;;
+;;; JNA may be automatically loaded into the current JVM process from
+;;; abcl-1.1.0-dev via
+;;;
+;;; (require 'abcl-contrib)
+;;; (require 'jna)
+
+(require 'abcl-contrib)
+(require 'jna)
;;; This is a preliminary version that will have to be cleaned up,
;;; optimized, etc. Nevertheless, it passes all of the relevant CFFI
-;;; tests except MAKE-POINTER.HIGH. Callbacks and Shareable Vectors
-;;; are not implemented yet.
+;;; tests except MAKE-POINTER.HIGH. Shareable Vectors are not
+;;; implemented yet.
;;;# Administrivia
@@ -297,14 +307,17 @@ WITH-POINTER-TO-VECTOR-DATA."
when fn do (return fn))
(find-it name (gethash library *loaded-libraries*)))))
+(defun convert-calling-convention (convention)
+ (ecase convention
+ (:stdcall "ALT_CONVENTION")
+ (:cdecl "C_CONVENTION")))
+
(defun make-function-pointer (pointer cconv)
(jnew (private-jconstructor "com.sun.jna.Function"
"com.sun.jna.Pointer" "int")
pointer
(jfield "com.sun.jna.Function"
- (ecase cconv
- (:cdecl "C_CONVENTION")
- (:stdcall "ALT_CONVENTION")))))
+ (convert-calling-convention convention))))
(defun lisp-value-to-java (value foreign-type)
(if (eq foreign-type :pointer)
@@ -347,32 +360,133 @@ WITH-POINTER-TO-VECTOR-DATA."
else do (setf return-type type)
finally (return (values types fargs return-type)))))
-(defmacro %foreign-funcall (name args &key library calling-convention)
+(defmacro %foreign-funcall (name args &key library convention)
+ (declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall (find-foreign-function ',name ',library)
(list ,@fargs) ',types ',rettype)))
-(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+(defmacro %foreign-funcall-pointer (ptr args &key convention)
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
- `(%%foreign-funcall (make-function-pointer ,ptr ',calling-convention)
+ `(%%foreign-funcall (make-function-pointer ,ptr ',convention)
(list ,@fargs) ',types ',rettype)))
;;;# Callbacks
-;;; TODO. IIUC, implementing this functionality would require being
-;;; able to create new interface definitions at runtime, which is
-;;; apparently no supported by ABCL as of June 2009.
-
-(defmacro %defcallback (name rettype arg-names arg-types body
- &key calling-convention)
- (warn "callback support unimplemented"))
+(defun foreign-to-callback-type (type)
+ (ecase type
+ ((:int :unsigned-int)
+ :int)
+ ((:long :unsigned-long)
+ (jvm::make-jvm-class-name "com.sun.jna.NativeLong"))
+ ((:long-long :unsigned-long-long)
+ (jvm::make-jvm-class-name "java.lang.Long"))
+ (:pointer
+ (jvm::make-jvm-class-name "com.sun.jna.Pointer"))
+ (:float
+ :float)
+ (:double
+ :double)
+ ((:char :unsigned-char)
+ :byte)
+ ((:short :unsigned-short)
+ :short)
+ (:void
+ :void)))
+
+(defvar *callbacks* (make-hash-table))
+
+(defmacro %defcallback (name return-type arg-names arg-types body
+ &key convention)
+ (declare (ignore convention))
+ `(let ((interface-name ,(define-jna-callback-interface return-type arg-types)))
+ (setf (gethash ',name *callbacks*)
+ (jinterface-implementation interface-name "callback"
+ (lambda (,@arg-names)
+ ,body)))))
+
+(jvm::define-class-name +callback-object+ "com.sun.jna.Callback")
+(defconstant +dynamic-callback-package+
+ "org/armedbear/jna/dynamic/callbacks")
+
+(defun define-jna-callback-interface (returns args)
+ (multiple-value-bind (interface interface-name)
+ (%define-jna-callback-interface
+ (foreign-to-callback-type returns)
+ (mapcar (lambda (type) (foreign-to-callback-type type)) args))
+ (load-class interface)
+ interface-name))
+
+(defun %define-jna-callback-interface (returns args)
+ "Returns the Java byte[] array of a class representing a Java interface.
+
+The fully qualified dotted name of the generated class is returned as
+the second value."
+ (let ((name (symbol-name (gensym))))
+ (values
+ (define-java-interface name +dynamic-callback-package+
+ `(("callback" ,returns ,args))
+ `(,+callback-object+))
+ (format nil "~A.~A"
+ (substitute #\. #\/ +dynamic-callback-package+) name))))
+
+(defun define-java-interface (name package methods
+ &optional (superinterfaces nil))
+"Define a class for a Java interface called NAME in PACKAGE with METHODS.
+
+METHODS is a list of (NAME RETURN-TYPE (ARG-TYPES)) entries. NAME is
+a string. The values of RETURN-TYPE and the list of ARG-TYPES for the
+defined method follow the are either references to Java objects as
+created by JVM::MAKE-JVM-CLASS-NAME, or keywords representing Java
+primtive types as contained in JVM::MAP-PRIMITIVE-TYPE.
+
+SUPERINTERFACES optionally contains a list of interfaces that this
+interface extends specified as fully qualifed dotted Java names."
+ (let* ((class-name-string (format nil "~A/~A" package name))
+ (class-name (jvm::make-jvm-class-name class-name-string))
+ (class (jvm::make-class-interface-file class-name)))
+ (dolist (superinterface superinterfaces)
+ (jvm::class-add-superinterface
+ class
+ (if (typep superinterface 'jvm::jvm-class-name)
+ superinterface
+ (jvm::make-jvm-class-name superinterface))))
+ (dolist (method methods)
+ (let ((name (first method))
+ (returns (second method))
+ (args (third method)))
+ (jvm::class-add-method
+ class
+ (jvm::make-jvm-method name returns args
+ :flags '(:public :abstract)))))
+ (jvm::finalize-class-file class)
+ (let ((s (sys::%make-byte-array-output-stream)))
+ (jvm::write-class-file class s)
+ (sys::%get-output-stream-bytes s))))
+
+(defun load-class (class-bytes)
+ "Load the Java byte[] array CLASS-BYTES as a Java class."
+ (let ((load-class-method
+ (jmethod "org.armedbear.lisp.JavaClassLoader"
+ "loadClassFromByteArray" "[B")))
+ (jcall load-class-method java::*classloader* class-bytes)))
+
+;;; Test function: unused in CFFI
+(defun write-class (class-bytes pathname)
+ "Write the Java byte[] array CLASS-BYTES to PATHNAME."
+ (with-open-file (stream pathname
+ :direction :output
+ :element-type '(signed-byte 8))
+ (dotimes (i (jarray-length class-bytes))
+ (write-byte (jarray-ref class-bytes i) stream))))
(defun %callback (name)
- (error "callback support unimplemented"))
+ (or (gethash name *callbacks*)
+ (error "Undefined callback: ~S" name)))
-;;;# Loading and Closign Foreign Libraries
+;;;# Loading and Closing Foreign Libraries
(defparameter *loaded-libraries* (make-hash-table))
View
@@ -184,8 +184,12 @@ WITH-POINTER-TO-VECTOR-DATA."
(:unsigned-int :unsigned-int)
(:long :long)
(:unsigned-long :unsigned-long)
- #+64bit (:long-long :nat)
- #+64bit (:unsigned-long-long :unsigned-nat)
+ (:long-long
+ #+64bit :nat
+ #-64bit (error "this platform does not support :long-long."))
+ (:unsigned-long-long
+ #+64bit :unsigned-nat
+ #-64bit (error "this platform does not support :unsigned-long-long"))
(:float :float)
(:double :double)
(:pointer :unsigned-nat)
@@ -252,7 +256,7 @@ WITH-POINTER-TO-VECTOR-DATA."
(defun convert-to-lisp-type (type)
(ecase type
- ((:char :short :int :long)
+ ((:char :short :int :long :nat)
`(signed-byte ,(* 8 (ff:sizeof-fobject type))))
((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-nat)
`(unsigned-byte ,(* 8 (ff:sizeof-fobject type))))
Oops, something went wrong. Retry.

0 comments on commit 973ebad

Please sign in to comment.