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