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