src/cffi-abcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA.
   4 ;;;
   5 ;;; Copyright (C) 2009, Luis Oliveira  <loliveira@common-lisp.net>
   6 ;;; Copyright (C) 2012, Mark Evenson  <evenson.not.org@gmail.com>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 ;;; This implementation requires the Java Native Access (JNA) library.
  30 ;;; <http://jna.dev.java.net/>
  31 ;;;
  32 ;;; JNA may be automatically loaded into the current JVM process from
  33 ;;; abcl-1.1.0-dev via the contrib mechanism.
  34
  35 (eval-when (:compile-toplevel :load-toplevel :execute)
  36   (require :abcl-contrib)
  37   (require :jna)
  38   (require :jss))
  39
  40 ;;; This is a preliminary version that will have to be cleaned up,
  41 ;;; optimized, etc. Nevertheless, it passes all of the relevant CFFI
  42 ;;; tests except MAKE-POINTER.HIGH. Shareable Vectors are not
  43 ;;; implemented yet.
  44
  45 ;;;# Administrivia
  46
  47 (defpackage #:cffi-sys
  48   (:use #:cl #:java)
  49   (:import-from #:alexandria #:hash-table-values #:length= #:format-symbol)
  50   (:export
  51    #:canonicalize-symbol-name-case
  52    #:foreign-pointer
  53    #:pointerp
  54    #:pointer-eq
  55    #:null-pointer
  56    #:null-pointer-p
  57    #:inc-pointer
  58    #:make-pointer
  59    #:pointer-address
  60    #:%foreign-alloc
  61    #:foreign-free
  62    #:with-foreign-pointer
  63    #:%foreign-funcall
  64    #:%foreign-funcall-pointer
  65    #:%foreign-type-alignment
  66    #:%foreign-type-size
  67    #:%load-foreign-library
  68    #:%close-foreign-library
  69    #:native-namestring
  70    #:%mem-ref
  71    #:%mem-set
  72    ;; #:make-shareable-byte-vector
  73    ;; #:with-pointer-to-vector-data
  74    #:%foreign-symbol-pointer
  75    #:%defcallback
  76    #:%callback
  77    #:with-pointer-to-vector-data
  78    #:make-shareable-byte-vector))
  79
  80 (in-package #:cffi-sys)
  81
  82 ;;;# Loading and Closing Foreign Libraries
  83
  84 (defparameter *loaded-libraries* (make-hash-table))
  85
  86 (defun %load-foreign-library (name path)
  87   "Load a foreign library, signals a simple error on failure."
  88   (flet ((load-and-register (name path)
  89            (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path)))
  90              (setf (gethash name *loaded-libraries*) lib)
  91              lib))
  92          (foreign-library-type-p (type)
  93            (find type '("so" "dll" "dylib") :test #'string=))
  94          (java-error (e)
  95            (error (jcall (jmethod "java.lang.Exception" "getMessage")
  96                          (java-exception-cause e)))))
  97     (handler-case
  98         (load-and-register name path)
  99       (java-exception (e)
 100         ;; From JNA http://jna.java.net/javadoc/com/sun/jna/NativeLibrary.html
 101         ;; ``[The name] can be short form (e.g. "c"), an explicit
 102         ;; version (e.g. "libc.so.6"), or the full path to the library
 103         ;; (e.g. "/lib/libc.so.6")''
 104         ;;
 105         ;; Try to deal with the occurance "libXXX" and "libXXX.so" as
 106         ;; "libXXX.so.6" and "XXX" should have succesfully loaded.
 107         (let ((p (pathname path)))
 108           (if (and (not (pathname-directory p))
 109                    (= (search "lib" (pathname-name p)) 0))
 110               (let ((short-name (if (foreign-library-type-p (pathname-type p))
 111                                     (subseq (pathname-name p) 3)
 112                                     (pathname-name p))))
 113                 (handler-case
 114                     (load-and-register name short-name)
 115                   (java-exception (e) (java-error e))))
 116               (java-error e)))))))
 117
 118 ;;; FIXME. Should remove libraries from the hash table.
 119 (defun %close-foreign-library (handle)
 120   "Closes a foreign library."
 121   #+#:ignore (setf *loaded-libraries* (remove handle *loaded-libraries*))
 122   (jcall-raw (jmethod "com.sun.jna.NativeLibrary" "dispose") handle))
 123
 124 ;;;
 125
 126 ;;; FIXME! We should probably define a private-jfield-accessor that does the hard work once!
 127 (let ((get-declared-fields-jmethod (jmethod "java.lang.Class" "getDeclaredFields")))
 128   (defun private-jfield (class-name field-name instance)
 129     (let ((field (find field-name
 130                        (jcall get-declared-fields-jmethod
 131                               (jclass class-name))
 132                        :key #'jfield-name
 133                        :test #'string=)))
 134       (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")
 135              field +true+)
 136       (jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object")
 137              field instance))))
 138
 139 ;;; XXX: doesn't match jmethod-arguments.
 140
 141 (let ((get-declared-methods-jmethod (jmethod "java.lang.Class" "getDeclaredMethods")))
 142   (defun private-jmethod (class-name method-name)
 143     (let ((method (find method-name
 144                         (jcall get-declared-methods-jmethod
 145                                (jclass class-name))
 146                         :key #'jmethod-name
 147                         :test #'string=)))
 148       (jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean")
 149              method +true+)
 150       method)))
 151
 152 (let ((get-declared-constructors-jmethod (jmethod "java.lang.Class"
 153                                                   "getDeclaredConstructors"))
 154       (set-accessible-jmethod (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean")))
 155   (defun private-jconstructor (class-name &rest params)
 156     (let* ((param-classes (mapcar #'jclass params))
 157            (cons (find-if (lambda (x &aux (cons-params (jconstructor-params x)))
 158                             (and (length= param-classes cons-params)
 159                                  (loop for param in param-classes
 160                                     and param-x across cons-params
 161                                     always (string= (jclass-name param)
 162                                                     (jclass-name param-x)))))
 163                           (jcall get-declared-constructors-jmethod (jclass class-name)))))
 164       (jcall set-accessible-jmethod cons +true+)
 165       cons)))
 166
 167 ;;;# Symbol Case
 168
 169 (defun canonicalize-symbol-name-case (name)
 170   (string-upcase name))
 171
 172 ;;;# Pointers
 173
 174 (deftype foreign-pointer ()
 175   '(satisfies pointerp))
 176
 177 (defun pointerp (ptr)
 178   "Return true if PTR is a foreign pointer."
 179   (let ((jclass (jclass-of ptr)))
 180     (when jclass
 181       (jclass-superclass-p (jclass "com.sun.jna.Pointer") jclass))))
 182
 183 (let ((jconstructor (private-jconstructor "com.sun.jna.Pointer" "long")))
 184   (defun make-pointer (address)
 185     "Return a pointer pointing to ADDRESS."
 186     (jnew jconstructor address)))
 187
 188 (defun make-private-jfield-accessor (class-name field-name)
 189   (let ((field (find field-name
 190                      (jcall (jmethod "java.lang.Class" "getDeclaredFields")
 191                             (jclass class-name))
 192                      :key #'jfield-name
 193                      :test #'string=)))
 194     (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")
 195            field +true+)
 196     (let ((get-jmethod (jmethod "java.lang.reflect.Field" "get" "java.lang.Object")))
 197       (lambda (instance)
 198         (jcall get-jmethod field instance)))))
 199
 200 (let ((accessor (make-private-jfield-accessor "com.sun.jna.Pointer" "peer")))
 201   (defun %pointer-address (pointer)
 202     (funcall accessor pointer)))
 203
 204 (defun pointer-address (pointer)
 205   "Return the address pointed to by PTR."
 206   (let ((peer (%pointer-address pointer)))
 207     (if (< peer 0)
 208         (+ #.(ash 1 64) peer)
 209         peer)))
 210
 211 (defun pointer-eq (ptr1 ptr2)
 212   "Return true if PTR1 and PTR2 point to the same address."
 213   (= (%pointer-address ptr1) (%pointer-address ptr2)))
 214
 215 (defun null-pointer ()
 216   "Construct and return a null pointer."
 217   (make-pointer 0))
 218
 219 (defun null-pointer-p (ptr)
 220   "Return true if PTR is a null pointer."
 221   (zerop (%pointer-address ptr)))
 222
 223 (defun inc-pointer (ptr offset)
 224   "Return a fresh pointer pointing OFFSET bytes past PTR."
 225   (make-pointer (+ (%pointer-address ptr) offset)))
 226
 227 ;;;# Allocation
 228
 229 (let ((malloc-jmethod (private-jmethod "com.sun.jna.Memory" "malloc")))
 230   (defun %foreign-alloc (size)
 231     "Allocate SIZE bytes on the heap and return a pointer."
 232     (make-pointer
 233      (jstatic-raw malloc-jmethod nil size))))
 234
 235 (let ((free-jmethod (private-jmethod "com.sun.jna.Memory" "free")))
 236   (defun foreign-free (ptr)
 237     "Free a PTR allocated by FOREIGN-ALLOC."
 238     (jstatic-raw free-jmethod nil (%pointer-address ptr))
 239     nil))
 240
 241 ;;; TODO: stack allocation.
 242 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 243   "Bind VAR to SIZE bytes of foreign memory during BODY.  The pointer
 244 in VAR is invalid beyond the dynamic extent of BODY, and may be
 245 stack-allocated if supported by the implementation.  If SIZE-VAR is
 246 supplied, it will be bound to SIZE during BODY."
 247   (unless size-var
 248     (setf size-var (gensym "SIZE")))
 249   `(let* ((,size-var ,size)
 250           (,var (%foreign-alloc ,size-var)))
 251      (unwind-protect
 252           (progn ,@body)
 253        (foreign-free ,var))))
 254
 255 ;;;# Shareable Vectors
 256 ;;;
 257 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 258 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 259 ;;; implementation can't do this.
 260
 261 (defun jna-setter (type)
 262   (ecase type
 263     ((:char :unsigned-char) "setByte")
 264     (:double "setDouble")
 265     (:float "setFloat")
 266     ((:int :unsigned-int) "setInt")
 267     ((:long :unsigned-long) "setNativeLong")
 268     ((:long-long :unsigned-long-long) "setLong")
 269     (:pointer "setPointer")
 270     ((:short :unsigned-short) "setShort")))
 271
 272 (defun jna-setter-arg-type (type)
 273   (ecase type
 274     ((:char :unsigned-char) "byte")
 275     (:double "double")
 276     (:float "float")
 277     ((:int :unsigned-int) "int")
 278     ((:long :unsigned-long) "com.sun.jna.NativeLong")
 279     ((:long-long :unsigned-long-long) "long")
 280     (:pointer "com.sun.jna.Pointer")
 281     ((:short :unsigned-short) "short")))
 282
 283 (defun jna-getter (type)
 284   (ecase type
 285     ((:char :unsigned-char) "getByte")
 286     (:double "getDouble")
 287     (:float "getFloat")
 288     ((:int :unsigned-int) "getInt")
 289     ((:long :unsigned-long) "getNativeLong")
 290     ((:long-long :unsigned-long-long) "getLong")
 291     (:pointer "getPointer")
 292     ((:short :unsigned-short) "getShort")))
 293
 294 (defun make-shareable-byte-vector (size)
 295   "Create a Lisp vector of SIZE bytes can passed to
 296 WITH-POINTER-TO-VECTOR-DATA."
 297   (make-array size :element-type '(unsigned-byte 8)))
 298
 299 (let ((method (jmethod "com.sun.jna.Pointer"
 300                        (jna-setter :char) "long" (jna-setter-arg-type :char))))
 301   (defun copy-to-foreign-vector (vector foreign-pointer)
 302     (loop for i below (length vector)
 303        do
 304          (jcall-raw method
 305                     foreign-pointer i
 306                     (aref vector i)))))
 307
 308 ;; hand-roll the jna-getter method instead of calling %mem-ref every time through
 309 (let ((method (jmethod "com.sun.jna.Pointer" (jna-getter :char) "long")))
 310   (defun copy-from-foreign-vector (vector foreign-pointer)
 311     (loop for i below (length vector)
 312        do (setf (aref vector i)
 313                 (java:jobject-lisp-value (jcall-raw method foreign-pointer i))))))
 314
 315 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 316   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 317   (let ((vector-sym (gensym "VECTOR")))
 318     `(let ((,vector-sym ,vector))
 319        (with-foreign-pointer (,ptr-var (length ,vector-sym))
 320          (copy-to-foreign-vector ,vector-sym ,ptr-var)
 321          (unwind-protect
 322               (progn ,@body)
 323            (copy-from-foreign-vector ,vector-sym ,ptr-var))))))
 324
 325 ;;;# Dereferencing
 326
 327 (defun foreign-type-to-java-class (type)
 328   (jclass
 329    (ecase type
 330      ((:int :unsigned-int) "java.lang.Integer")
 331      ((:long :unsigned-long) "com.sun.jna.NativeLong")
 332      ((:long-long :unsigned-long-long) "java.lang.Long")
 333      (:pointer "com.sun.jna.Pointer") ;; void * is pointer?
 334      (:float "java.lang.Float")
 335      (:double "java.lang.Double")
 336      ((:char :unsigned-char) "java.lang.Byte")
 337      ((:short :unsigned-short) "java.lang.Short"))))
 338
 339 (defun %foreign-type-size (type)
 340   "Return the size in bytes of a foreign type."
 341   (jstatic "getNativeSize" "com.sun.jna.Native"
 342            (foreign-type-to-java-class type)))
 343
 344 ;;; FIXME.
 345 (defun %foreign-type-alignment (type)
 346   "Return the alignment in bytes of a foreign type."
 347   (%foreign-type-size type))
 348
 349 (defun unsigned-type-p (type)
 350   (case type
 351     ((:unsigned-char
 352       :unsigned-int
 353       :unsigned-short
 354       :unsigned-long
 355       :unsigned-long-long) t)
 356     (t nil)))
 357
 358 (defun lispify-value (value type)
 359   (when (and (eq type :pointer) (or (null (java:jobject-lisp-value value))
 360                                     (eq +null+ (java:jobject-lisp-value value))))
 361     (return-from lispify-value (null-pointer)))
 362   (when (or (eq type :long) (eq type :unsigned-long))
 363     (setq value (jcall-raw (jmethod "com.sun.jna.NativeLong" "longValue")
 364                            (java:jobject-lisp-value value))))
 365   (let ((bit-size (* 8 (%foreign-type-size type))))
 366     (let ((lisp-value (java:jobject-lisp-value value)))
 367       (if (and (unsigned-type-p type)
 368                (logbitp (1- bit-size) lisp-value))
 369           (lognot (logxor lisp-value (1- (expt 2 bit-size))))
 370           lisp-value))))
 371
 372 (defun %mem-ref (ptr type &optional (offset 0))
 373   (lispify-value
 374    (jcall-raw (jmethod "com.sun.jna.Pointer" (jna-getter type) "long")
 375               ptr offset)
 376    type))
 377
 378 (defun %mem-set (value ptr type &optional (offset 0))
 379   (let* ((bit-size (* 8 (%foreign-type-size type)))
 380          (val (if (and (unsigned-type-p type) (logbitp (1- bit-size) value))
 381                   (lognot (logxor value (1- (expt 2 bit-size))))
 382                   value)))
 383     (jcall-raw (jmethod "com.sun.jna.Pointer"
 384                     (jna-setter type) "long" (jna-setter-arg-type type))
 385            ptr
 386            offset
 387            (if (or (eq type :long) (eq type :unsigned-long))
 388                (jnew (jconstructor "com.sun.jna.NativeLong" "long") val)
 389                val)))
 390   value)
 391
 392 ;;;# Foreign Globals
 393 (let ((get-symbol-address-jmethod (private-jmethod "com.sun.jna.NativeLibrary" "getSymbolAddress")))
 394   (defun %foreign-symbol-pointer (name library)
 395     "Returns a pointer to a foreign symbol NAME."
 396     (flet ((find-it (library)
 397              (ignore-errors
 398                (make-pointer
 399                 (jcall-raw get-symbol-address-jmethod library name)))))
 400       (if (eq library :default)
 401           (or (find-it
 402                (jstatic "getProcess" "com.sun.jna.NativeLibrary"))
 403               ;; The above should find it, but I'm not exactly sure, so
 404               ;; let's still do it manually just in case.
 405               (loop for lib being the hash-values of *loaded-libraries*
 406                  thereis (find-it lib)))
 407           (find-it library)))))
 408
 409 ;;;# Calling Foreign Functions
 410
 411 (defun find-foreign-function (name library)
 412   (flet ((find-it (library)
 413            (ignore-errors
 414             (jcall-raw (jmethod "com.sun.jna.NativeLibrary" "getFunction"
 415                                 "java.lang.String")
 416                    library name))))
 417     (if (eq library :default)
 418         (or (find-it
 419              (jstatic "getProcess" "com.sun.jna.NativeLibrary"))
 420             ;; The above should find it, but I'm not exactly sure, so
 421             ;; let's still do it manually just in case.
 422             (loop for lib being the hash-values of *loaded-libraries*
 423                   thereis (find-it lib)))
 424         (find-it (gethash library *loaded-libraries*)))))
 425
 426 (defun convert-calling-convention (convention)
 427   (ecase convention
 428     (:stdcall "ALT_CONVENTION")
 429     (:cdecl "C_CONVENTION")))
 430
 431 (defparameter *jna-string-encoding* "UTF-8"
 432   "Encoding for conversion between Java and native strings that occurs within JNA.
 433
 434 Used with jna-4.0.0 or later.")
 435
 436 ;;; c.f. <http://twall.github.io/jna/4.0/javadoc/com/sun/jna/Function.html#Function%28com.sun.jna.Pointer,%20int,%20java.lang.String%29>
 437 (defvar *jna-4.0.0-or-later-p*
 438   (ignore-errors (private-jconstructor "com.sun.jna.Function"
 439                                        "com.sun.jna.Pointer" "int" "java.lang.String")))
 440
 441 (let ((jconstructor
 442        (if *jna-4.0.0-or-later-p*
 443            (private-jconstructor "com.sun.jna.Function"
 444                                  "com.sun.jna.Pointer" "int" "java.lang.String")
 445            (private-jconstructor "com.sun.jna.Function"
 446                                  "com.sun.jna.Pointer" "int"))))
 447   (defun make-function-pointer (pointer convention)
 448     (apply
 449      #'jnew jconstructor pointer
 450      (jfield "com.sun.jna.Function" (convert-calling-convention convention))
 451      (when *jna-4.0.0-or-later-p*
 452        (list *jna-string-encoding*)))))
 453
 454 (defun lisp-value-to-java (value foreign-type)
 455   (case foreign-type
 456     (:pointer value)
 457     (:void nil)
 458     (t (jnew (ecase foreign-type
 459                ((:int :unsigned-int) (jconstructor "java.lang.Integer" "int"))
 460                ((:long-long :unsigned-long-long)
 461                 (jconstructor "java.lang.Long" "long"))
 462                ((:long :unsigned-long)
 463                 (jconstructor "com.sun.jna.NativeLong" "long"))
 464                ((:short :unsigned-short) (jconstructor "java.lang.Short" "short"))
 465                ((:char :unsigned-char) (jconstructor "java.lang.Byte" "byte"))
 466                (:float (jconstructor "java.lang.Float" "float"))
 467                (:double (jconstructor "java.lang.Double" "double")))
 468              value))))
 469
 470 (defun %%foreign-funcall (function args arg-types return-type)
 471   (let ((jargs (jnew-array "java.lang.Object" (length args))))
 472     (loop for arg in args and type in arg-types and i from 0
 473           do (setf (jarray-ref jargs i)
 474                    (lisp-value-to-java arg type)))
 475     (if (eq return-type :void)
 476         (progn
 477           (jcall-raw (jmethod "com.sun.jna.Function" "invoke" "[Ljava.lang.Object;")
 478                      function jargs)
 479           (values))
 480         (lispify-value
 481          (jcall-raw (jmethod "com.sun.jna.Function" "invoke"
 482                              "java.lang.Class" "[Ljava.lang.Object;")
 483                 function
 484                 (foreign-type-to-java-class return-type)
 485                 jargs)
 486          return-type))))
 487
 488 (defun foreign-funcall-type-and-args (args)
 489   (let ((return-type :void))
 490     (loop for (type arg) on args by #'cddr
 491           if arg collect type into types
 492           and collect arg into fargs
 493           else do (setf return-type type)
 494           finally (return (values types fargs return-type)))))
 495
 496 (defmacro %foreign-funcall (name args &key (library :default) convention)
 497   (declare (ignore convention))
 498   (multiple-value-bind (types fargs rettype)
 499       (foreign-funcall-type-and-args args)
 500     `(%%foreign-funcall (find-foreign-function ',name ',library)
 501                         (list ,@fargs) ',types ',rettype)))
 502
 503 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 504   (multiple-value-bind (types fargs rettype)
 505       (foreign-funcall-type-and-args args)
 506     `(%%foreign-funcall (make-function-pointer ,ptr ',convention)
 507                         (list ,@fargs) ',types ',rettype)))
 508
 509 ;;;# Callbacks
 510
 511 (defun foreign-to-callback-type (type)
 512   (ecase type
 513     ((:int :unsigned-int)
 514      :int)
 515     ((:long :unsigned-long)
 516      (jvm::make-jvm-class-name "com.sun.jna.NativeLong"))
 517     ((:long-long :unsigned-long-long)
 518      (jvm::make-jvm-class-name "java.lang.Long"))
 519     (:pointer
 520      (jvm::make-jvm-class-name "com.sun.jna.Pointer"))
 521     (:float
 522      :float)
 523     (:double
 524      :double)
 525     ((:char :unsigned-char)
 526      :byte)
 527     ((:short :unsigned-short)
 528      :short)
 529     (:wchar_t
 530      :int)
 531     (:void
 532      :void)))
 533
 534 (defvar *callbacks* (make-hash-table))
 535
 536 (defmacro convert-args-to-lisp-values (arg-names arg-types &body body)
 537   (let ((gensym-args (loop for name in arg-names
 538                            collect (format-symbol t '#:callback-arg-~a- name))))
 539     `(lambda (,@gensym-args)
 540        (let ,(loop for arg in arg-names
 541                    for type in arg-types
 542                    for gensym-arg in gensym-args
 543                    collecting `(,arg (if (typep ,gensym-arg 'java:java-object)
 544                                          (lispify-value ,gensym-arg ,type)
 545                                          ,gensym-arg)))
 546          ,@body))))
 547
 548 (defmacro %defcallback (name return-type arg-names arg-types body
 549                         &key convention)
 550   (declare (ignore convention)) ;; I'm always up for ignoring convention, but this is probably wrong.
 551   `(setf (gethash ',name *callbacks*)
 552          (jinterface-implementation
 553           (ensure-callback-interface ',return-type ',arg-types)
 554           "callback"
 555           (convert-args-to-lisp-values ,arg-names ,arg-types (lisp-value-to-java ,body ',return-type)))))
 556 ;;          (lambda (,@arg-names) ,body))))
 557
 558 (jvm::define-class-name +callback-object+ "com.sun.jna.Callback")
 559 (defconstant
 560     +dynamic-callback-package+
 561   "org/armedbear/jna/dynamic/callbacks"
 562   "The slash-delimited Java package in which we create classes dynamically to specify callback interfaces.")
 563
 564 (defun ensure-callback-interface (returns args)
 565   "Ensure that the jvm interface for the callback exists in the current JVM.
 566
 567 Returns the fully dot qualified name of the interface."
 568   (let* ((jvm-returns (foreign-to-callback-type returns))
 569          (jvm-args  (mapcar #'foreign-to-callback-type args))
 570          (interface-name (qualified-callback-interface-classname jvm-returns jvm-args)))
 571     (handler-case
 572         (jss:find-java-class interface-name)
 573       (java-exception (e)
 574         (when (jinstance-of-p (java:java-exception-cause e)
 575                               "java.lang.ClassNotFoundException")
 576           (let ((interface-class-bytes (%define-jna-callback-interface jvm-returns jvm-args))
 577                 (simple-interface-name (callback-interface-classname jvm-returns jvm-args)))
 578             (load-class interface-name interface-class-bytes)))))
 579     interface-name))
 580
 581 (defun qualified-callback-interface-classname (returns args)
 582   (format nil "~A.~A"
 583           (substitute #\. #\/ +dynamic-callback-package+)
 584           (callback-interface-classname returns args)))
 585
 586 (defun callback-interface-classname (returns args)
 587   (flet ((stringify (thing)
 588            (typecase thing
 589              (jvm::jvm-class-name
 590               (substitute #\_ #\/
 591                          (jvm::class-name-internal thing)))
 592              (t (string thing)))))
 593     (format nil "~A__~{~A~^__~}"
 594             (stringify returns)
 595             (mapcar #'stringify args))))
 596
 597 (defun %define-jna-callback-interface (returns args)
 598   "Returns the Java byte[] array of a class representing a Java
 599   interface descending form +CALLBACK-OBJECT+ which contains the
 600   single function 'callback' which takes ARGS returning RETURNS.
 601
 602 The fully qualified dotted name of the generated class is returned as
 603 the second value."
 604   (let ((name (callback-interface-classname returns args)))
 605     (values
 606      (define-java-interface name +dynamic-callback-package+
 607        `(("callback" ,returns ,args))
 608        `(,+callback-object+))
 609      (qualified-callback-interface-classname returns args))))
 610
 611 (defun define-java-interface (name package methods
 612                               &optional (superinterfaces nil))
 613 "Returns the bytes of the Java class interface called NAME in PACKAGE with METHODS.
 614
 615 METHODS is a list of (NAME RETURN-TYPE (ARG-TYPES)) entries.  NAME is
 616 a string.  The values of RETURN-TYPE and the list of ARG-TYPES for the
 617 defined method follow the are either references to Java objects as
 618 created by JVM::MAKE-JVM-CLASS-NAME, or keywords representing Java
 619 primtive types as contained in JVM::MAP-PRIMITIVE-TYPE.
 620
 621 SUPERINTERFACES optionally contains a list of interfaces that this
 622 interface extends specified as fully qualifed dotted Java names."
 623   (let* ((class-name-string (format nil "~A/~A" package name))
 624          (class-name (jvm::make-jvm-class-name class-name-string))
 625          (class (jvm::make-class-interface-file class-name)))
 626     (dolist (superinterface superinterfaces)
 627       (jvm::class-add-superinterface
 628        class
 629        (if (typep superinterface 'jvm::jvm-class-name)
 630            superinterface
 631            (jvm::make-jvm-class-name superinterface))))
 632     (dolist (method methods)
 633       (let ((name (first method))
 634             (returns (second method))
 635             (args (third method)))
 636       (jvm::class-add-method
 637        class
 638        (jvm::make-jvm-method name returns args
 639                              :flags '(:public :abstract)))))
 640     (jvm::finalize-class-file class)
 641     (let ((s (sys::%make-byte-array-output-stream)))
 642       (jvm::write-class-file class s)
 643       (sys::%get-output-stream-bytes s))))
 644
 645 (defun load-class (name bytes)
 646   "Load the byte[] array BYTES as a Java class called NAME."
 647   (#"loadClassFromByteArray" java::*classloader* name bytes))
 648
 649 ;;; Test function: unused in CFFI
 650 (defun write-class (class-bytes pathname)
 651   "Write the Java byte[] array CLASS-BYTES to PATHNAME."
 652   (with-open-file (stream pathname
 653                           :direction :output
 654                           :element-type '(signed-byte 8))
 655     (dotimes (i (jarray-length class-bytes))
 656       (write-byte (jarray-ref class-bytes i) stream))))
 657
 658 (defun %callback (name)
 659   (or (#"getFunctionPointer" 'com.sun.jna.CallbackReference
 660                              (gethash name *callbacks*))
 661       (error "Undefined callback: ~S" name)))
 662
 663 (defun native-namestring (pathname)
 664   (namestring pathname))