cffi-abcl.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[email protected]> | |
6 ;;; Copyright (C) 2012, Mark Evenson <[email protected]> | |
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-symb… | |
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"… | |
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/NativeLibrar… | |
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-ty… | |
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… | |
127 (let ((get-declared-fields-jmethod (jmethod "java.lang.Class" "getDeclar… | |
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" "getDecla… | |
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" "boolea… | |
149 method +true+) | |
150 method))) | |
151 | |
152 (let ((get-declared-constructors-jmethod (jmethod "java.lang.Class" | |
153 "getDeclaredConstructo… | |
154 (set-accessible-jmethod (jmethod "java.lang.reflect.Constructor" "… | |
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-par… | |
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 (jcla… | |
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" "getDeclaredField… | |
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.la… | |
197 (lambda (instance) | |
198 (jcall get-jmethod field instance))))) | |
199 | |
200 (let ((accessor (make-private-jfield-accessor "com.sun.jna.Pointer" "pee… | |
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 :c… | |
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 tim… | |
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-point… | |
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 … | |
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) val… | |
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.NativeLi… | |
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 w… | |
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.ht… | |
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… | |
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.… | |
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 conventi… | |
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" "… | |
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"… | |
465 ((:char :unsigned-char) (jconstructor "java.lang.Byte" "b… | |
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.la… | |
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- … | |
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-o… | |
544 (lispify-value ,gensym-arg ,typ… | |
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… | |
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… | |
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 dynamical… | |
563 | |
564 (defun ensure-callback-interface (returns args) | |
565 "Ensure that the jvm interface for the callback exists in the current … | |
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-ret… | |
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 j… | |
577 (simple-interface-name (callback-interface-classname jvm… | |
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 wi… | |
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)) |