cffi-abcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
cffi-abcl.lisp (26057B)
---
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))