Recently Written · git

clic

MIRROR ONLY Gopher client with pretty colours in Common Lisp

git clone https://github.com/equwal/clic

Log | Files | Refs

3rdparties/software/cffi_0.21.0/src/cffi-abcl.lisp (26057 bytes)

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))