# HG changeset patch # Parent 3e0e88debb451ed06a43ef6029b4ef9e70729305 Changes to cffi_0.10.7.1 Quicklisp 2012-10-13 for ABCL Fixed compilation options for Solaris (TODO Add -m64 conditionally on x64). tests/strings.lisp Comment out failing test involving BABEL with the name '\uxxx'. src/cffi-abcl.lisp ------------------ (stas) MAKE-FUNCTION-POINTER typo. Refactor to remove compile warnings. CFFI-SYS::%LOAD-FOREIGN-LIBRARY tries harder to figure out which library to load. Add docstrings for my own sanity. diff --git a/src/cffi-abcl.lisp b/src/cffi-abcl.lisp --- a/src/cffi-abcl.lisp +++ b/src/cffi-abcl.lisp @@ -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 @@ (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 @@ ((: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 @@ ((: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 @@ (: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 @@ -408,10 +408,18 @@ ,body))))) (jvm::define-class-name +callback-object+ "com.sun.jna.Callback") -(defconstant +dynamic-callback-package+ - "org/armedbear/jna/dynamic/callbacks") +(defconstant + +dynamic-callback-package+ + "org/armedbear/jna/dynamic/callbacks" + "The slash-delimited Java package in which we create classes dynamically.") (defun define-jna-callback-interface (returns args) + "Return the name of the java virtual machine interface which + specifies the contracts for a class which contains each method in + METHODS that matches the corresponding parameter signature in ARGS. + +As a side effect, this interface is dynamically created and injected +into the current virtual machine process." (multiple-value-bind (interface interface-name) (%define-jna-callback-interface (foreign-to-callback-type returns) @@ -468,10 +476,9 @@ (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))) + (jcall + (jmethod "org.armedbear.lisp.JavaClassLoader" "loadClassFromByteArray" "[B") + java::*classloader* class-bytes)) ;;; Test function: unused in CFFI (defun write-class (class-bytes pathname) @@ -492,13 +499,35 @@ (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 +544,9 @@ "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) diff --git a/tests/GNUmakefile b/tests/GNUmakefile --- a/tests/GNUmakefile +++ b/tests/GNUmakefile @@ -43,7 +43,7 @@ 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 diff --git a/tests/strings.lisp b/tests/strings.lisp --- a/tests/strings.lisp +++ b/tests/strings.lisp @@ -116,7 +116,7 @@ (mem-ref buf :unsigned-char 5))) 0 70) -#-babel::8-bit-chars +#-(or abcl babel::8-bit-chars) ;; XXX check on non-ABCL (deftest string.encoding.utf-8.basic (with-foreign-pointer (buf 7 size) (let ((string (concatenate 'babel:unicode-string