From 23674cf7676717666ceafa97566eeb4824e20025 Mon Sep 17 00:00:00 2001 From: easye Date: Mon, 29 Oct 2012 15:58:27 +0100 Subject: [PATCH 1/3] Fix Solaris compilation options. The "-fPIC" flag will always be necessary when using GCC-derived compilers as I understand it. Additionally, Solaris compilation options now unconditionally tries a 64bit build. Contemporary Solaris (since Solaris 10), are hybrid 32/64 bit environments where "uname -m" reports "i86pc". Whether one wants the 32 or 64 bit version of the libraries depends on the type of the Lisp implementation doing the loading, which is currently not available in the environment in which make(1) is executing. --- tests/GNUmakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/GNUmakefile b/tests/GNUmakefile index e3aeac109498..0776a1924413 100644 --- a/tests/GNUmakefile +++ b/tests/GNUmakefile @@ -43,7 +43,7 @@ CFLAGS_64 := -m64 endif else ifeq ($(OSTYPE), SunOS) -CFLAGS := -c -Wall -std=c99 -pedantic +CFLAGS := -m64 -fPIC -c -Wall -std=c99 -pedantic else # Let's assume this is win32 SHLIB_EXT := .dll From c630aaf3b41501d3d2ac60b94461f96627fce627 Mon Sep 17 00:00:00 2001 From: easye Date: Mon, 29 Oct 2012 16:03:43 +0100 Subject: [PATCH 2/3] cffi-abcl-20121028a: changes to cffi_0.10.7.1 Quicklisp 2012-10-13 for ABCL. The interactive restart when reloading callbacks is no longer needed. A callable function pointer is now returned by CALLBACK and GET-CALLBACK, which wasn't the case previously. Now down to 25 failing tests! Callbacks "automacro-ly" now get a translation layer to convert back from native types to ones which ABCL expects. This translation is currently a work in progress, as not all cases are covered correctly. (Stas Boukarev) MAKE-FUNCTION-POINTER typo. Refactored to remove compile warnings about MAKE-IMMEDIATE-OBJECT. CFFI-SYS::%LOAD-FOREIGN-LIBRARY tries harder to figure out which library to load. Docstrings added. --- src/cffi-abcl.lisp | 162 +++++++++++++++++++++++++++++++-------------- 1 file changed, 112 insertions(+), 50 deletions(-) diff --git a/src/cffi-abcl.lisp b/src/cffi-abcl.lisp index 145ac3e320f4..046f9d794cd3 100644 --- a/src/cffi-abcl.lisp +++ b/src/cffi-abcl.lisp @@ -30,14 +30,14 @@ ;;; ;;; ;;; JNA may be automatically loaded into the current JVM process from -;;; abcl-1.1.0-dev via -;;; -;;; (require 'abcl-contrib) -;;; (require 'jna) +;;; abcl-1.1.0-dev via the contrib mechanism. (require 'abcl-contrib) (require 'jna) +(eval-when (:compile-toplevel :execute) + (require :jss)) + ;;; 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. Shareable Vectors are not @@ -85,7 +85,7 @@ :key #'jfield-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean") - field (make-immediate-object t :boolean)) + field +true+) (jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object") field instance))) @@ -97,7 +97,7 @@ :key #'jmethod-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean") - method (make-immediate-object t :boolean)) + method +true+) method)) (defun private-jconstructor (class-name &rest params) @@ -112,7 +112,7 @@ "getDeclaredConstructors") (jclass class-name))))) (jcall (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean") - cons (make-immediate-object t :boolean)) + cons +true+) cons)) ;;;# Symbol Case @@ -191,11 +191,11 @@ supplied, it will be bound to SIZE during BODY." (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes can passed to WITH-POINTER-TO-VECTOR-DATA." - (error "unimplemented")) + (error "Unimplemented.")) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." - (warn "unimplemented")) + (warn "Unimplemented.")) ;;;# Dereferencing @@ -205,11 +205,11 @@ WITH-POINTER-TO-VECTOR-DATA." ((:int :unsigned-int) "java.lang.Integer") ((:long :unsigned-long) "com.sun.jna.NativeLong") ((:long-long :unsigned-long-long) "java.lang.Long") - (:pointer "com.sun.jna.Pointer") + (:pointer "com.sun.jna.Pointer") ;; void * is pointer? (:float "java.lang.Float") (:double "java.lang.Double") ((:char :unsigned-char) "java.lang.Byte") - ((:short :unsigned-short) "java.lang.Short")))) + ((:short :unsigned-short) "java.lang.Short")))) (defun %foreign-type-size (type) "Return the size in bytes of a foreign type." @@ -242,7 +242,7 @@ WITH-POINTER-TO-VECTOR-DATA." ((:short :unsigned-short) "getShort"))) (defun lispify-value (value type) - (when (and (eq type :pointer) (null value)) + (when (and (eq type :pointer) (or (null value) (eq +null+ value))) (return-from lispify-value (null-pointer))) (when (or (eq type :long) (eq type :unsigned-long)) (setq value (jcall (jmethod "com.sun.jna.NativeLong" "longValue") value))) @@ -312,7 +312,7 @@ WITH-POINTER-TO-VECTOR-DATA." (:stdcall "ALT_CONVENTION") (:cdecl "C_CONVENTION"))) -(defun make-function-pointer (pointer cconv) +(defun make-function-pointer (pointer convention) (jnew (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int") pointer @@ -393,48 +393,90 @@ WITH-POINTER-TO-VECTOR-DATA." :byte) ((:short :unsigned-short) :short) + (:wchar_t + :char) (:void :void))) (defvar *callbacks* (make-hash-table)) +(defmacro convert-args-to-lisp-values (arg-names &rest body) + (let ((gensym-args (loop :for name :in arg-names :collecting (gensym)))) + `(lambda (,@gensym-args) + (let ,(loop + :for arg :in arg-names + :for gensym-arg :in gensym-args + :collecting `(,arg (if (typep ,gensym-arg 'java:java-object) + (java:jobject-lisp-value ,gensym-arg) + ,gensym-arg))) + ,body)))) + (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))))) + (declare (ignore convention)) ;; I'm always up for ignoring convention, but this is probably wrong. + `(setf (gethash ',name *callbacks*) + (jinterface-implementation + (ensure-callback-interface ',return-type ',arg-types) + "callback" + `,(convert-args-to-lisp-values ,arg-names ,@body)))) +;; (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) +(defconstant + +dynamic-callback-package+ + "org/armedbear/jna/dynamic/callbacks" + "The slash-delimited Java package in which we create classes dynamically to specify callback interfaces.") + +(defun ensure-callback-interface (returns args) + "Ensure that the jvm interface for the callback exists in the current JVM. + +Returns the fully dot qualified name of the interface." + (let* ((jvm-returns (foreign-to-callback-type returns)) + (jvm-args (mapcar #'foreign-to-callback-type args)) + (interface-name (qualified-callback-interface-classname jvm-returns jvm-args))) + (handler-case + (jss:find-java-class interface-name) + (java-exception (e) + (when (jinstance-of-p (java:java-exception-cause e) + "java.lang.ClassNotFoundException") + (let ((interface-class-bytes (%define-jna-callback-interface jvm-returns jvm-args)) + (simple-interface-name (callback-interface-classname jvm-returns jvm-args))) + (load-class interface-name interface-class-bytes))))) interface-name)) +(defun qualified-callback-interface-classname (returns args) + (format nil "~A.~A" + (substitute #\. #\/ +dynamic-callback-package+) + (callback-interface-classname returns args))) + +(defun callback-interface-classname (returns args) + (flet ((stringify (thing) + (typecase thing + (jvm::jvm-class-name + (substitute #\_ #\/ + (jvm::class-name-internal thing))) + (t (string thing))))) + (format nil "~A__~{~A~^__~}" + (stringify returns) + (mapcar #'stringify args)))) + (defun %define-jna-callback-interface (returns args) - "Returns the Java byte[] array of a class representing a Java interface. + "Returns the Java byte[] array of a class representing a Java + interface descending form +CALLBACK-OBJECT+ which contains the + single function 'callback' which takes ARGS returning RETURNS. The fully qualified dotted name of the generated class is returned as the second value." - (let ((name (symbol-name (gensym)))) + (let ((name (callback-interface-classname returns args))) (values (define-java-interface name +dynamic-callback-package+ `(("callback" ,returns ,args)) `(,+callback-object+)) - (format nil "~A.~A" - (substitute #\. #\/ +dynamic-callback-package+) name)))) + (qualified-callback-interface-classname returns args)))) (defun define-java-interface (name package methods &optional (superinterfaces nil)) -"Define a class for a Java interface called NAME in PACKAGE with METHODS. +"Returns the bytes of the Java class 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 @@ -466,12 +508,9 @@ interface extends specified as fully qualifed dotted Java names." (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))) +(defun load-class (name bytes) + "Load the byte[] array BYTES as a Java class called NAME." + (#"loadClassFromByteArray" java::*classloader* name bytes)) ;;; Test function: unused in CFFI (defun write-class (class-bytes pathname) @@ -483,7 +522,8 @@ interface extends specified as fully qualifed dotted Java names." (write-byte (jarray-ref class-bytes i) stream)))) (defun %callback (name) - (or (gethash name *callbacks*) + (or (#"getFunctionPointer" 'com.sun.jna.CallbackReference + (gethash name *callbacks*)) (error "Undefined callback: ~S" name))) ;;;# Loading and Closing Foreign Libraries @@ -492,13 +532,35 @@ interface extends specified as fully qualifed dotted Java names." (defun %load-foreign-library (name path) "Load a foreign library, signals a simple error on failure." - (handler-case - (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path))) - (setf (gethash name *loaded-libraries*) lib) - lib) - (java-exception (e) - (error (jcall (jmethod "java.lang.Exception" "getMessage") - (java-exception-cause e)))))) + (flet ((load-and-register (name path) + (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path))) + (setf (gethash name *loaded-libraries*) lib) + lib)) + (foreign-library-type-p (type) + (find type '("so" "dll" "dylib") :test #'string=)) + (java-error (e) + (error (jcall (jmethod "java.lang.Exception" "getMessage") + (java-exception-cause e))))) + (handler-case + (load-and-register name path) + (java-exception (e) + ;; From JNA http://jna.java.net/javadoc/com/sun/jna/NativeLibrary.html + ;; ``[The name] can be short form (e.g. "c"), an explicit + ;; version (e.g. "libc.so.6"), or the full path to the library + ;; (e.g. "/lib/libc.so.6")'' + ;; + ;; Try to deal with the occurance "libXXX" and "libXXX.so" as + ;; "libXXX.so.6" and "XXX" should have succesfully loaded. + (let ((p (pathname path))) + (if (and (not (pathname-directory p)) + (= (search "lib" (pathname-name p)) 0)) + (let ((short-name (if (foreign-library-type-p (pathname-type p)) + (subseq (pathname-name p) 3) + (pathname-name p)))) + (handler-case + (load-and-register name short-name) + (java-exception (e) (java-error e)))) + (java-error e))))))) ;;; FIXME. Should remove libraries from the hash table. (defun %close-foreign-library (handle) @@ -515,9 +577,9 @@ interface extends specified as fully qualifed dotted Java names." "Returns a pointer to a foreign symbol NAME." (flet ((find-it (name library) (let ((p (ignore-errors - (jcall (private-jmethod "com.sun.jna.NativeLibrary" - "getSymbolAddress") - library name)))) + (jcall + (private-jmethod "com.sun.jna.NativeLibrary" "getSymbolAddress") + library name)))) (unless (null p) (make-pointer p))))) (if (eq library :default) From 48d72e8c0ba7ec9699ce449039e3fe6a251e7dc1 Mon Sep 17 00:00:00 2001 From: easye Date: Mon, 29 Oct 2012 16:14:29 +0100 Subject: [PATCH 3/3] Arguments to CONCATENATE need to be sequences. --- grovel/invoke.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/grovel/invoke.lisp b/grovel/invoke.lisp index e086ff9afa2e..1b28878df182 100644 --- a/grovel/invoke.lisp +++ b/grovel/invoke.lisp @@ -39,7 +39,7 @@ #+abcl (defun %invoke (command arglist) (let ((cmdline (reduce (lambda (str1 str2) - (concatenate 'string str1 #\Space str2)) + (concatenate 'string str1 " " str2)) arglist :initial-value command)) (stream (make-string-output-stream))) (values (ext:run-shell-command cmdline :output stream)