source: trunk/source/examples/jfli/jfli.lisp @ 11453

Last change on this file since 11453 was 11453, checked in by gb, 12 years ago

Don't use the CCL package.
Remove a stray ~.
File size: 56.8 KB
Line 
1;    Copyright (c) Rich Hickey. All rights reserved.
2;    The use and distribution terms for this software are covered by the
3;    Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
4;    which can be found in the file CPL.TXT at the root of this distribution.
5;    By using this software in any fashion, you are agreeing to be bound by
6;    the terms of this license.
7;    You must not remove this notice, or any other, from this software.
8
9#|
10
11jfli is a library that provides access to Java from Lisp
12It depends on the jni package (included)
13Callbacks from Java to Lisp also require jfli.jar (included)
14
15|#
16
17(defpackage :jfli
18  (:use :common-lisp :jni)
19  (:export
20
21   ;jvm creation
22   :*jni-lib-path*  ;exposed from jni
23   :create-jvm      ;exposed from jni, you must call this prior to calling any other jfli function
24   :enable-java-proxies
25
26   ;wrapper generation
27   :def-java-class
28   :get-jar-classnames
29   :dump-wrapper-defs-to-file
30
31   ;object creation etc
32   :find-java-class
33   :new
34   :make-new
35   :make-typed-ref
36   :jeq
37
38   ;array support
39   :make-new-array
40   :jlength
41   :jref
42   :jref-boolean
43   :jref-byte
44   :jref-char
45   :jref-double
46   :jref-float
47   :jref-int
48   :jref-short
49   :jref-long
50
51   ;proxy support
52   :new-proxy
53   :unregister-proxy
54
55   ;conversions
56   :box-boolean
57   :box-byte
58   :box-char
59   :box-double
60   :box-float
61   :box-integer
62   :box-long
63   :box-short
64   :box-string
65   :unbox-boolean
66   :unbox-byte
67   :unbox-char
68   :unbox-double
69   :unbox-float
70   :unbox-integer
71   :unbox-long
72   :unbox-short
73   :unbox-string
74
75;   :ensure-package
76;   :member-symbol
77;   :class-symbol
78;   :constructor-symbol
79   ))
80
81(in-package :jfli)
82
83#|
84bootstrap the implementation of reflection wrappers with
85a few (primitive, less safe and maybe faster) jni wrappers
86|#
87
88(eval-when (:compile-toplevel :load-toplevel :execute)
89  (def-jni-functions "java.lang.Object"
90                     ("getClass" () "Class")
91                     ("hashCode" () "int")
92                     ("toString" () "String")
93                     ("equals" ((obj "Object")) "boolean"))
94
95  (def-jni-functions "java.lang.Class"
96                   ;should be :overloaded t, but we only use this version
97                     ("forName" ((className "String")) "Class"  :static t)
98                     ("getConstructors" () "java.lang.reflect.Constructor<>")
99                     ("getFields" () "java.lang.reflect.Field<>")
100                     ("getMethods" () "java.lang.reflect.Method<>")
101
102                     ("getConstructor" ((parameter-types "Class<>")) "java.lang.reflect.Constructor")
103                     ("getField" ((name "String"))
104                                 "java.lang.reflect.Field")
105                     ("getMethod" ((name "String") (parameter-types "Class<>"))
106                                  "java.lang.reflect.Method")
107
108                     ("getSuperclass" () "Class")
109                     ("getInterfaces" () "Class<>")
110
111                     ("getName" () "String")
112                     ("isArray" () "boolean")
113                     ("isPrimitive" () "boolean"))
114
115  (def-jni-functions "java.lang.reflect.Field"
116                     ("getName" () "java.lang.String")
117                     ("getType" () "java.lang.Class")
118                     ("getModifiers" () "int")
119
120                     ("get" ((obj "java.lang.Object")) "java.lang.Object" :raw-return t)
121                     ("getBoolean" ((obj "java.lang.Object")) "boolean")
122                     ("getByte" ((obj "java.lang.Object")) "byte")
123                     ("getChar" ((obj "java.lang.Object")) "char")
124                     ("getDouble" ((obj "java.lang.Object")) "double")
125                     ("getFloat" ((obj "java.lang.Object")) "float")
126                     ("getInt" ((obj "java.lang.Object")) "int")
127                     ("getLong" ((obj "java.lang.Object")) "long")
128                     ("getShort" ((obj "java.lang.Object")) "short")
129
130                     ("set" ((obj "java.lang.Object") (value "java.lang.Object")) "void")
131                     ("setBoolean" ((obj "java.lang.Object") (b "boolean")) "void")
132                     ("setByte" ((obj "java.lang.Object") (b "byte")) "void")
133                     ("setChar" ((obj "java.lang.Object") (c "char")) "void")
134                     ("setDouble" ((obj "java.lang.Object") (d "double")) "void")
135                     ("setFloat" ((obj "java.lang.Object") (f "float")) "void")
136                     ("setInt" ((obj "java.lang.Object") ( i "int")) "void")
137                     ("setLong" ((obj "java.lang.Object") (l "long")) "void")
138                     ("setShort" ((obj "java.lang.Object") (s "short")) "void"))
139
140  (def-jni-functions "java.lang.reflect.Constructor"
141                     ("getParameterTypes" () "java.lang.Class<>")
142                     ("newInstance" ((initargs "java.lang.Object<>")) "java.lang.Object"))
143
144  (def-jni-functions "java.lang.reflect.Method"
145                     ("getName" () "java.lang.String")
146                     ("getParameterTypes" () "java.lang.Class<>")
147                     ("getReturnType" () "java.lang.Class")
148                     ("getModifiers" () "int")
149                     ("invoke" ((object "java.lang.Object")
150                                (args "java.lang.Object<>")) "java.lang.Object"
151                               :raw-return t))
152
153  (def-jni-functions "java.lang.reflect.Array"
154                     ("get" ((array "java.lang.Object") (index "int")) "java.lang.Object" :static t)
155                     ("getBoolean"
156                      ((array "java.lang.Object") (index "int")) "boolean" :static t)
157                     ("getByte"
158                      ((array "java.lang.Object") (index "int")) "byte" :static t)
159                     ("getChar"
160                      ((array "java.lang.Object") (index "int")) "char" :static t)
161                     ("getDouble"
162                      ((array "java.lang.Object") (index "int")) "double" :static t)
163                     ("getFloat"
164                      ((array "java.lang.Object") (index "int")) "float" :static t)
165                     ("getInt"
166                      ((array "java.lang.Object") (index "int")) "int" :static t)
167                     ("getShort"
168                      ((array "java.lang.Object") (index "int")) "short" :static t)
169                     ("getLong"
170                      ((array "java.lang.Object") (index "int")) "long" :static t)
171                     ("getLength" ((array "java.lang.Object")) "int" :static t)
172                     ("newInstance" ((componentType "java.lang.Class")
173                                     (length "int")) "java.lang.Object" :static t :overloaded t)
174                     ("newInstance" ((componentType "java.lang.Class")
175                                     (dimensions "int<>")) "java.lang.Object" :static t :overloaded t)
176                     ("set" ((array "java.lang.Object") (index "int") (value "java.lang.Object"))
177                            "void" :static t))
178
179
180  (def-jni-function "java.lang.reflect.Modifier"
181                    "isStatic" ((mod "int")) "boolean" :static t)
182
183  (def-jni-constructor "java.lang.Boolean" ((value "boolean")))
184  (def-jni-constructor "java.lang.Byte" ((value "byte")))
185  (def-jni-constructor "java.lang.Character" ((value "char")))
186  (def-jni-constructor "java.lang.Double" ((value "double")))
187  (def-jni-constructor "java.lang.Float" ((value "float")))
188  (def-jni-constructor "java.lang.Integer" ((value "int")))
189  (def-jni-constructor "java.lang.Short" ((value "short")))
190
191  (def-jni-function "java.lang.Boolean" "booleanValue" () "boolean")
192  (def-jni-function "java.lang.Byte" "byteValue" () "byte")
193  (def-jni-function "java.lang.Character" "charValue" () "char")
194  (def-jni-function "java.lang.Double" "doubleValue" () "double")
195  (def-jni-function "java.lang.Float" "floatValue" () "float")
196  (def-jni-function "java.lang.Integer" "intValue" () "int")
197  (def-jni-function "java.lang.Short" "shortValue" () "short")
198
199  (def-jni-constructor "java.util.jar.JarFile" ((filename "java.lang.String")))
200  (def-jni-function "java.util.jar.JarFile"
201                    "entries" () "java.util.Enumeration")
202  (def-jni-functions "java.util.Enumeration"
203                     ("hasMoreElements" () "boolean")
204                     ("nextElement" () "java.lang.Object"))
205  (def-jni-functions "java.util.zip.ZipEntry"
206                     ("isDirectory" () "boolean")
207                     ("getName" () "java.lang.String"))
208
209
210  (def-jni-functions "java.lang.Long"
211                     ("valueOf" ((s "String")) "java.lang.Long" :static t)
212                     ("intValue" () "int"))
213
214  (def-jni-field "java.lang.Boolean" "TYPE" "Class" :static t)
215  (def-jni-field "java.lang.Byte" "TYPE" "Class" :static t)
216  (def-jni-field "java.lang.Character" "TYPE" "Class" :static t)
217  (def-jni-field "java.lang.Float" "TYPE" "Class" :static t)
218  (def-jni-field "java.lang.Integer" "TYPE" "Class" :static t)
219  (def-jni-field "java.lang.Double" "TYPE" "Class" :static t)
220  (def-jni-field "java.lang.Short" "TYPE" "Class" :static t)
221  (def-jni-field "java.lang.Long" "TYPE" "Class" :static t)
222
223  (def-jni-constructor "com.richhickey.jfli.LispInvocationHandler" ())
224  (def-jni-function "java.lang.reflect.Proxy"
225                    "newProxyInstance" ((loader "java.lang.ClassLoader")
226                                        (interfaces "java.lang.Class<>")
227                                        (h "InvocationHandler")) "java.lang.Object" :static t)
228
229  (def-jni-function "java.lang.ClassLoader"
230                    "getSystemClassLoader" () "ClassLoader" :static t)
231
232  ) ;eval-when
233
234;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235
236(eval-when (:compile-toplevel :load-toplevel :execute)
237  (defun ensure-package (name)
238    "find the package or create it if it doesn't exist"
239    (or (find-package name)
240        (make-package name :use '())))
241  (intern "Object" (ensure-package "java.lang"))
242  (intern "String" (ensure-package "java.lang")))
243
244(defmacro do-jarray ((x array) &body body)
245  "jni-based, so not safe and not exported, but used by the implementation"
246  (let ((gcount (gensym))
247        (gi (gensym))
248        (garray (gensym)))
249    `(let* ((,garray ,array)
250            (,gcount (jni:get-array-length ,garray)))
251       (dotimes (,gi ,gcount)
252         (let ((,x (jaref ,garray ,gi)))
253           ,@body)))))
254
255
256(defmacro doenum ((e enum) &body body)
257  "jni-based, so not safe and not exported, but used by the implementation"
258  (let ((genum (gensym)))
259    `(let ((,genum ,enum))
260       (do ()
261           ((not (enumeration.hasmoreelements ,genum)))
262         (let ((,e (enumeration.nextelement ,genum)))
263           ,@body)))))
264
265;probably insufficiently general, works as used here
266(defmacro get-or-init (place init-form)
267  `(or ,place
268       (setf ,place ,init-form)))
269
270;from c.l.l.
271(defmacro case-equal (exp &body clauses)
272  (let ((temp (gensym)))
273    `(let ((,temp ,exp))
274       (cond ,@(mapcar #'(lambda (clause)
275                           (destructuring-bind (keys . clause-forms) clause
276                             (cond ((eq keys 'otherwise)
277                                    `(t ,@clause-forms))
278                                   (t
279                                    (if (atom keys) (setq keys (list keys)))
280                                    `((member ,temp ',keys :test #'equal)
281                                      ,@clause-forms)))))
282                       clauses)))))
283
284;create object. to bootstrap the hierarchy
285(defclass |java.lang|::object. ()
286  ((ref :reader ref :initarg :ref)
287   (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil))
288  (:documentation "the superclass of all Java typed reference classes"))
289
290(defun get-ref (x)
291  "any function taking an object can be passed a raw java-ref ptr or a typed reference instance.
292Will also convert strings for use as objects"
293  (etypecase x
294    (java-ref x)
295    (|java.lang|::object. (ref x))
296    (string (convert-to-java-string x))
297    (null nil)))
298
299(defun jeq (obj1 obj2)
300  "are these 2 java objects the same object? Note that is not the same as Object.equals()"
301  (is-same-object (get-ref obj1) (get-ref obj2)))
302
303
304;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;;
305#|
306The library does a lot with names and symbols, needing at various times to:
307 - find stuff in Java - full names w/case required
308 - create hopefully non-conflicting packages and member names
309
310When you (def-java-class "java.lang.String") you get a bunch of symbols/names:
311a package named '|java.lang|
312a class-symbol '|java.lang|:STRING. (note the dot and case),
313   which can usually be used where a typename is required
314   it also serves as the name of the Lisp typed reference class for string
315   its symbol-value is the canonic-class-symbol (see below)
316a canonic-class-symbol '|java.lang|::|String|
317   can be used to reconstitute the full class name
318
319I've started trying to flesh out the notion of a Java class designator, which can either be
320the full class name as a string, the class-symbol, or one of :boolean, :int etc
321|#
322
323(defun canonic-class-symbol (full-class-name)
324  "(\"java.lang.Object\") -> '|java.lang|:|Object|"
325  (multiple-value-bind (package class) (split-package-and-class full-class-name)
326    (intern class (ensure-package package))))
327
328(defun class-symbol (full-class-name)
329  "(\"java.lang.Object\") -> '|java.lang|:object."
330  (multiple-value-bind (package class) (split-package-and-class full-class-name)
331    (intern (string-upcase (jni::string-append class ".")) (ensure-package package))))
332
333(defun java-class-name (class-sym)
334  "inverse of class-symbol, only valid on class-syms created by def-java-class"
335  (let ((canonic-class-symbol (symbol-value class-sym)))
336    (jni::string-append (package-name (symbol-package canonic-class-symbol))
337                        "." 
338                        canonic-class-symbol)))
339
340(defun member-symbol (full-class-name member-name)
341  "members are defined case-insensitively in case-sensitive packages,
342prefixed by 'classname.' -
343 (member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.TOSTRING"
344  (multiple-value-bind (package class) (split-package-and-class full-class-name)
345    (intern (string-upcase (jni::string-append class "." member-name)) (ensure-package package))))
346
347(defun constructor-symbol (full-class-name)
348  (member-symbol full-class-name "new"))
349
350(defun get-java-class-ref (canonic-class-symbol)
351  "class-ref is cached on the plist of the canonic class symbol"
352  (get-or-init (get canonic-class-symbol :class-ref)
353               (let ((class-name (jni::string-append (package-name
354                                                 (symbol-package canonic-class-symbol))
355                                                "."
356                                                canonic-class-symbol)))
357                 (try-null (jni-find-class (nsubstitute #\/ #\. class-name))))))
358
359(defun find-java-class (class-sym-or-string)
360  "Given a Java class designator, returns the Java Class object."
361  (ctypecase class-sym-or-string
362    (symbol (case class-sym-or-string
363              (:int integer.type)
364              (:char character.type)
365              (:long long.type)
366              (:float float.type)
367              (:boolean boolean.type)
368              (:short short.type)
369              (:double double.type)
370              (:byte byte.type)
371              (otherwise (get-java-class-ref class-sym-or-string))))
372    (string (get-java-class-ref (canonic-class-symbol class-sym-or-string)))))
373
374;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;;
375#|
376The library maintains a hierarchy of typed reference classes that parallel the
377class hierarchy on the Java side
378new returns a typed reference, but other functions that return objects
379return raw references (for efficiency)
380make-typed-ref can create fully-typed wrappers when desired
381|#
382
383(defun get-superclass-names (full-class-name)
384  (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)))
385         (super (class.getsuperclass class))
386         (interfaces (class.getinterfaces class))
387         (supers ()))
388    (do-jarray (i interfaces)
389      (push i supers))
390    ;hmmm - where should the base class go in the precedence list?
391    ;is it more important than the interfaces? this says no
392    (if super
393        (push super supers)
394      (push (find-java-class "java.lang.Object") supers))
395    (setf supers (nreverse supers))
396    ;now we need to fix up order so more derived classes are first
397    ;but don't have a total ordering, so merge one at a time
398    (let (result)
399      (dolist (s supers)
400        (setf result (merge 'list result (list s)
401                            (lambda (x y)
402                              (is-assignable-from x y)))))
403      (mapcar #'class.getname result))))
404#||
405(defun get-superclass-names (full-class-name)
406  (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)))
407         (super (class.getsuperclass class))
408         (interfaces (class.getinterfaces class))
409         (supers ()))
410    (do-jarray (i interfaces)
411      (push (class.getname i) supers))
412    ;hmmm - where should the base class go in the precedence list?
413    ;is it more important than the interfaces? this says no
414    (if super
415        (push (class.getname super) supers)
416      (push "java.lang.Object" supers))
417    (nreverse supers)))
418||#
419
420(defun ensure-java-class (full-class-name)
421  "walks the superclass hierarchy and makes sure all the classes are fully defined
422 (they may be undefined or just forward-referenced-class)
423caches this has been done on the class-symbol's plist"
424  (let* ((class-sym (class-symbol full-class-name))
425         (class (find-class class-sym nil)))
426    (if (or (eql class-sym '|java.lang|::object.)
427            (get class-sym :ensured))
428        class
429      (let ((supers (get-superclass-names full-class-name)))
430        (dolist (super supers)
431          (ensure-java-class super))
432        (unless (and class (subtypep class 'standard-object))
433          (setf class
434                (ccl:ensure-class class-sym :direct-superclasses (mapcar #'class-symbol supers))))
435        (setf (get class-sym :ensured) t)
436        class))))
437
438(defun ensure-java-hierarchy (class-sym)
439  "Works off class-sym for efficient use in new
440This will only work on class-syms created by def-java-class,
441as it depends upon symbol-value being the canonic class symbol"
442  (unless (get class-sym :ensured)
443    (ensure-java-class (java-class-name class-sym))))
444
445(defun make-typed-ref (java-ref)
446  "Given a raw java-ref, determines the full type of the object
447and returns an instance of a typed reference wrapper"
448  (when java-ref
449    (let ((class (object.getclass (get-ref java-ref))))
450      (if (class.isarray class)
451          (error "typed refs not supported for arrays (yet)")
452        (make-instance (ensure-java-class (class.getname class)) :ref (get-ref java-ref) )))))
453
454
455;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
456#|
457In an effort to reduce the volume of stuff generated when wrapping entire libraries,
458the wrappers just generate minimal stubs, which, if and when invoked at runtime,
459complete the work of building thunking closures, so very little code is generated for
460things never called (Java libraries have huge numbers of symbols).
461Not sure if this approach matters, but that's how it works
462|#
463
464(defmacro def-java-class (full-class-name)
465  "Given the package-qualified, case-correct name of a java class, will generate
466wrapper functions for its constructors, fields and methods."
467  (multiple-value-bind (package class) (split-package-and-class full-class-name)
468    (declare (ignore class))
469    (let* ((class-sym (class-symbol full-class-name))
470           (defs
471            (list*
472             `(ensure-package ,package)
473          ;build a path from the simple class symbol to the canonic
474             `(defconstant ,class-sym ',(canonic-class-symbol full-class-name))
475             `(export ',class-sym (symbol-package ',class-sym))
476             `(def-java-constructors ,full-class-name)
477             `(def-java-methods ,full-class-name)
478             `(def-java-fields ,full-class-name)
479             (unless (string= full-class-name "java.lang.Object")
480               (let ((supers (mapcar #'class-symbol (get-superclass-names full-class-name))))
481                 (append (mapcar (lambda (p)
482                                   `(ensure-package ,(package-name p)))
483                                 (remove (symbol-package class-sym)
484                                         (remove-duplicates (mapcar #'symbol-package supers))))
485                         (list `(defclass ,(class-symbol full-class-name)
486                                          ,supers ()))))))))
487      `(locally ,@defs))))
488
489(defun get-jar-classnames (jar-file-name &rest packages)
490  "returns a list of strings, packages should be of the form \"java/lang\"
491  for recursive lookup and \"java/util/\" for non-recursive"
492  (let* ((jar (jarfile.new jar-file-name))
493         (entries (jarfile.entries jar))
494         (names ()))
495    (doenum (e entries)
496      (unless (zipentry.isdirectory e)
497        (let ((ename (zipentry.getname e)))
498          (flet ((matches (package)
499                   (and (eql 0 (search package ename))
500                        (or (not (eql #\/ (schar package (1- (length package))))) ;recursive
501                            (not (find #\/ ename :start (length package))))))) ;non-subdirectory
502            (when (and (eql (search ".class" ename)
503                            (- (length ename) 6)) ;classname
504                       ;don't grab anonymous inner classes
505                       (not (and (find #\$ ename)
506                                 (digit-char-p (schar ename (1+ (position #\$ ename))))))
507                       (some #'matches packages))
508              (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename) 6)))
509                    names))))))
510    names))
511
512(defun dump-wrapper-defs-to-file (filename classnames)
513  "given a list of classnames (say from get-jar-classnames), writes
514calls to def-java-class to a file"
515  (with-open-file (s filename :direction :output :if-exists :supersede)
516    (dolist (name (sort classnames #'string-lessp))
517      (format s "(def-java-class ~S)~%" name))))
518
519;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;;
520#|
521
522Every non-interface class with a public ctor will get;
523  a constructor, classname.new
524  a method defined on make-new, ultimately calling classname.new,
525   specialized on (the value of) it's class-symbol (e.g. canonic sym)
526
527Note that if the ctor is overloaded, there is just one function (taking a rest arg),
528which handles overload resolution
529
530The new macro expands into a call to make-new
531|#
532
533(defgeneric make-new (class-sym &rest args)
534  (:documentation "Allows for definition of before/after methods on ctors.
535The new macro expands into call to this"))
536
537(defun build-ctor-doc-string (name ctors)
538  (with-output-to-string (s)
539    (dolist (c ctors)
540      (format s "~A(~{~#[~;~A~:;~A,~]~})~%"
541              name
542              (mapcar #'class-name-for-doc (jarray-to-list (constructor.getparametertypes c)))))))
543
544(defmacro def-java-constructors (full-class-name)
545"creates and exports a ctor func classname.new, defines a method of
546make-new specialized on the class-symbol"
547  (let ((ctor-list (get-ctor-list full-class-name)))
548    (when ctor-list
549      (let ((ctor-sym (constructor-symbol full-class-name))
550            (class-sym (class-symbol full-class-name)))
551        `(locally
552           (defun ,ctor-sym (&rest args)
553             ,(build-ctor-doc-string full-class-name ctor-list)
554             (apply #'install-constructors-and-call ,full-class-name args))
555           (export ',ctor-sym (symbol-package ',ctor-sym))
556           (defmethod make-new ((class-sym (eql ,class-sym)) &rest args)
557             (apply (function ,ctor-sym) args)))))))
558
559(defun get-ctor-list (full-class-name)
560  (let* ((class-sym (canonic-class-symbol full-class-name))
561         (class (get-java-class-ref class-sym))
562         (ctor-array (class.getconstructors class))
563         (ctor-list (jarray-to-list ctor-array)))
564    ctor-list))
565
566(defun install-constructors-and-call (full-class-name &rest args)
567  "initially the constructor symbol for a class is bound to this function,
568when first called it will replace itself with the appropriate direct thunk,
569then call the requested ctor - subsequent calls will be direct"
570  (install-constructors full-class-name)
571  (apply (constructor-symbol full-class-name) args))
572
573(defun install-constructors (full-class-name)
574  (let* ((ctor-list (get-ctor-list full-class-name)))
575    (when ctor-list
576      (setf (fdefinition (constructor-symbol full-class-name))
577            (make-ctor-thunk ctor-list (class-symbol full-class-name))))))
578
579(defun make-ctor-thunk (ctors class-sym)
580  (if (rest ctors) ;overloaded
581      (make-overloaded-ctor-thunk ctors class-sym)
582    (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
583
584(defun make-non-overloaded-ctor-thunk (ctor class-sym)
585  (let ((arg-boxers (get-arg-boxers (constructor.getparametertypes ctor))))
586    (lambda (&rest args)
587      (let ((arg-array (build-arg-array args arg-boxers)))
588        (ensure-java-hierarchy class-sym)
589        (prog1
590            (make-instance class-sym
591                           :ref (constructor.newinstance ctor arg-array)
592                           :lisp-allocated t)
593            ;(constructor.newinstance ctor arg-array)
594          (when arg-array
595            (delete-local-ref arg-array)))))))
596
597(defun make-overloaded-ctor-thunk (ctors class-sym)
598  (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym)))
599    (lambda (&rest args)
600      (let ((fn (cdr (assoc (length args) thunks))))
601        (if fn
602            (apply fn
603                   args)
604          (error "invalid arity"))))))
605
606(defun make-ctor-thunks-by-args-length (ctors class-sym)
607  "returns an alist of thunks keyed by number of args"
608  (let ((ctors-by-args-length (make-hash-table))
609        (thunks-by-args-length nil))
610    (dolist (ctor ctors)
611      (let ((params-len (get-array-length (constructor.getparametertypes ctor))))
612        (push ctor (gethash params-len ctors-by-args-length))))
613    (maphash #'(lambda (args-len ctors)
614                 (push (cons args-len
615                             (if (rest ctors);truly overloaded
616                                 (make-type-overloaded-ctor-thunk ctors class-sym)
617                               ;only one ctor with this number of args
618                               (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
619                       thunks-by-args-length))
620             ctors-by-args-length)
621    thunks-by-args-length))
622
623(defun make-type-overloaded-ctor-thunk (ctors class-sym)
624  "these methods have the same number of args and must be distinguished by type"
625  (let ((thunks (mapcar #'(lambda (ctor)
626                            (list (make-non-overloaded-ctor-thunk ctor class-sym)
627                                  (jarray-to-list (constructor.getparametertypes ctor))))
628                        ctors)))
629    (lambda (&rest args)
630      (block fn
631        (let ((arg-types (get-types-of-args args)))
632          (dolist (thunk-info thunks)
633            (destructuring-bind (thunk param-types) thunk-info
634              (when (is-congruent-type-list param-types arg-types)
635                (return-from fn (apply thunk args)))))
636          (error "No matching constructor"))))))
637
638(defmacro new (class-spec &rest args)
639"new class-spec args
640class-spec -> class-name | (class-name this-name)
641class-name -> \"package.qualified.ClassName\" | classname.
642args -> [actual-arg]* [init-arg-spec]*
643init-arg-spec -> init-arg | (init-arg)
644init-arg -> :settable-field-or-method [params]* value ;note keyword
645            |
646            .method-name [args]*                      ;note dot
647
648Creates a new instance of class-name, using make-new generic function,
649then initializes it by setting fields or accessors and/or calling member functions
650If this-name is supplied it will be bound to the newly-allocated object and available
651to the init-args"
652  (labels ((mem-sym? (x)
653             (or (keywordp x)
654                 (and (symbolp x) (eql 0 (position #\. (symbol-name x))))))
655           (mem-form? (x)
656             (and (listp x) (mem-sym? (first x))))
657           (mem-init? (x)
658             (or (mem-sym? x) (mem-form? x)))
659           (init-forms (x)
660             (if x
661                 (if (mem-form? (first x))
662                     (cons (first x) (init-forms (rest x)))
663                   (let ((more (member-if #'mem-init? (rest x))))
664                     (cons (ldiff x more) (init-forms more)))))))
665    (let* ((inits (member-if #'mem-init? args))
666           (real-args (ldiff args inits))
667           (class-atom (if (atom class-spec)
668                           class-spec
669                         (first class-spec)))
670           (class-sym (if (symbolp class-atom)
671                          ;(find-symbol (jni::string-append (symbol-name class-atom) "."))
672                          class-atom
673                        (multiple-value-bind (package class) (jni::split-package-and-class class-atom)
674                          (find-symbol (jni::string-append (string-upcase class) ".") package))))
675           (class-name (subseq (symbol-name class-sym) 0 (1- (length (symbol-name class-sym)))))
676           (gthis (gensym)))
677      (flet ((expand-init (x)
678               (if (keywordp (first x)) ;setf field or property
679                   `(setf (,(find-symbol (jni::string-append class-name "." (symbol-name (first x))))
680                           ,gthis ,@(butlast (rest x)))
681                          ,@(last (rest x)))
682                 ;.memfunc
683                 `(,(find-symbol (jni::string-append class-name (symbol-name (first x))))
684                   ,gthis
685                   ,@(rest x)))))
686        `(let* ((,gthis (make-new ,class-sym ,@real-args))
687                ,@(when (listp class-spec)
688                    `((,(second class-spec) ,gthis))))
689           ,@(mapcar #'expand-init (init-forms inits))
690           ,gthis)))))
691
692;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
693
694#|
695all public fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname)
696instance fields take an first arg which is the instance
697static fields also get a symbol-macro *classname.fieldname*
698|#
699
700(defmacro def-java-fields (full-class-name)
701"fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname)
702instance fields take an first arg which is the instance
703static fields also get a symbol-macro *classname.fieldname*"
704  (let* ((class-sym (canonic-class-symbol full-class-name))
705         (class (get-java-class-ref class-sym))
706         (fields (jarray-to-list (class.getfields class)))
707         (defs nil))
708    (dolist (field fields)
709      (let* ((field-name (field.getname field))
710             (field-sym (member-symbol full-class-name field-name))
711             (is-static (modifier.isstatic (field.getmodifiers field))))
712        (if is-static
713            (let ((macsym (intern (jni::string-append "*" (symbol-name field-sym) "*")
714                                  (symbol-package field-sym))))
715              (push `(defun ,field-sym ()
716                       (install-static-field-and-get ,full-class-name ,field-name))
717                    defs)
718              (push `(defun (setf ,field-sym) (val)
719                       (install-static-field-and-set ,full-class-name ,field-name val))
720                    defs)
721              (push `(export ',field-sym (symbol-package ',field-sym)) defs)
722              (push `(define-symbol-macro ,macsym (,field-sym)) defs)
723              (push `(export ',macsym (symbol-package ',macsym)) defs))
724          (progn
725            (push `(defun ,field-sym (obj)
726                     (install-field-and-get ,full-class-name ,field-name obj))
727                  defs)
728            (push `(defun (setf ,field-sym) (val obj)
729                     (install-field-and-set ,full-class-name ,field-name val obj))
730                  defs)
731            (push `(export ',field-sym (symbol-package ',field-sym)) defs)))))
732    `(locally ,@(nreverse defs))))
733
734(defun install-field-and-get (full-class-name field-name obj)
735  (install-field full-class-name field-name)
736  (funcall (member-symbol full-class-name field-name) obj))
737
738(defun install-field-and-set (full-class-name field-name val obj)
739  (install-field full-class-name field-name)
740  (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val obj))
741
742(defun install-static-field-and-get (full-class-name field-name)
743  (install-field full-class-name field-name)
744  (funcall (member-symbol full-class-name field-name)))
745
746(defun install-static-field-and-set (full-class-name field-name val)
747  (install-field full-class-name field-name)
748  (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val))
749
750(defun install-field (full-class-name field-name)
751  (let* ((class-sym (canonic-class-symbol full-class-name))
752         (class (get-java-class-ref class-sym))
753         (field (class.getfield class field-name))
754         (field-sym (member-symbol full-class-name field-name))
755         (is-static (modifier.isstatic (field.getmodifiers field)))
756         (field-type-name (class.getname (field.gettype field)))
757         (boxer (get-boxer-fn field-type-name))
758         (unboxer (get-unboxer-fn field-type-name)))
759    (if is-static
760        (progn
761          (setf (fdefinition field-sym)
762                (lambda ()
763                  (funcall unboxer (field.get field nil) t)))
764          (setf (fdefinition `(setf ,field-sym))
765                (lambda (arg)
766                  (field.set field nil
767                             (get-ref (if (and boxer (not (boxed? arg)))
768                                          (funcall boxer arg)
769                                        arg)))
770                  arg)))
771      (progn
772        (setf (fdefinition field-sym)
773              (lambda (obj)
774                (funcall unboxer (field.get field (get-ref obj)) t)))
775        (setf (fdefinition `(setf ,field-sym))
776              (lambda (arg obj)
777                (field.set field (get-ref obj)
778                           (get-ref (if (and boxer (not (boxed? arg)))
779                                        (funcall boxer arg)
780                                      arg)))
781                arg))))))
782
783;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
784#|
785defines wrappers for all public methods of the class
786As with ctors, if a method is overloaded a single wrapper is created that handles
787overload resolution.
788The wrappers have the name classname.methodname
789If a method follows the JavaBeans property protocol (i.e. it is called getSomething or isSomething
790and there is a corresponding setSomething, then a (setf classname.methodname) will be defined
791that calls the latter
792|#
793
794(defun class-name-for-doc (class)
795  (let ((name (class.getname class)))
796    (if (class.isarray class)
797        (decode-array-name name)
798      name)))
799
800(defun build-method-doc-string (name methods)
801  (with-output-to-string (s)
802    (dolist (m methods)
803      (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%"
804              (if (modifier.isstatic (method.getmodifiers m))
805                  "static "
806                "")
807              (class.getname (method.getreturntype m))
808              name
809              (mapcar #'class-name-for-doc (jarray-to-list (method.getparametertypes m)))))))
810
811(defmacro def-java-methods (full-class-name)
812  (let ((methods-by-name (get-methods-by-name full-class-name))
813        (defs nil))
814    (maphash (lambda (name methods)
815               (let ((method-sym (member-symbol full-class-name name)))
816                 (push `(defun ,method-sym (&rest args)
817                          ,(build-method-doc-string name methods)
818                          (apply #'install-methods-and-call ,full-class-name ,name args))
819                       defs)
820                 (push `(export ',method-sym (symbol-package ',method-sym))
821                       defs)
822                 ;build setters when finding beans property protocol
823                 (flet ((add-setter-if (prefix)
824                          (when (eql 0 (search prefix name))
825                            (let ((setname (jni::string-append "set" (subseq name (length prefix)))))
826                              (when (gethash setname methods-by-name)
827                                (push `(defun (setf ,method-sym) (val &rest args)
828                                         (progn
829                                           (apply #',(member-symbol full-class-name setname)
830                                                  (append args (list val)))
831                                           val))
832                                      defs))))))
833                   (add-setter-if "get")
834                   (add-setter-if "is"))))
835             methods-by-name)
836    `(locally ,@(nreverse defs))))
837
838(defun install-methods-and-call (full-class-name method &rest args)
839  "initially all the member function symbols for a class are bound to this function,
840when first called it will replace them with the appropriate direct thunks,
841then call the requested method - subsequent calls via those symbols will be direct"
842  (install-methods full-class-name)
843  (apply (member-symbol full-class-name method) args))
844
845(defun decode-array-name (tn)
846  (let ((prim (assoc tn
847                     '(("Z" . "boolean")
848                       ("B" . "byte")
849                       ("C" . "char")
850                       ("S" . "short")
851                       ("I" . "int")
852                       ("J" . "long")
853                       ("F" . "float")
854                       ("D" . "double")
855                       ("V" . "void"))
856                     :test #'string-equal)))
857    (if prim
858        (rest prim)
859      (let ((array-depth (count #\[ tn)))
860        (if (= 0 array-depth)
861            (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ;
862          (with-output-to-string (s)
863            (write-string (decode-array-name (subseq tn array-depth)) s)
864            (dotimes (x array-depth)
865              (write-string "[]" s))))))))
866
867(defun jarray-to-list (array)
868  (let (ret)
869    (do-jarray (x array)
870      (push x ret))
871    (nreverse ret)))
872
873(defun get-methods-by-name (full-class-name)
874  "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name"
875  (let* ((class-sym (canonic-class-symbol full-class-name))
876         (class (get-java-class-ref class-sym))
877         (method-array (class.getmethods class))
878         (methods-by-name (make-hash-table :test #'equal)))
879    (do-jarray (method method-array)
880      (push method (gethash (method.getName method) methods-by-name)))
881    methods-by-name))
882
883(defun install-methods (full-class-name)
884  (let ((methods-by-name (get-methods-by-name full-class-name)))
885    (maphash
886     (lambda (name methods)
887       (setf (fdefinition (member-symbol full-class-name name))
888             (make-method-thunk methods)))
889     methods-by-name)))
890
891(defun make-method-thunk (methods)
892  (if (rest methods) ;overloaded
893      (make-overloaded-thunk methods)
894    (make-non-overloaded-thunk (first methods))))
895
896(defun make-non-overloaded-thunk (method)
897  (let ((unboxer-fn (get-unboxer-fn (class.getname (method.getreturntype method))))
898        (arg-boxers (get-arg-boxers (method.getparametertypes method)))
899        (is-static (modifier.isstatic (method.getmodifiers method))))
900    (lambda (&rest args)
901      (let ((arg-array (build-arg-array (if is-static args (rest args)) arg-boxers)))
902        (prog1
903            (funcall unboxer-fn
904                     (method.invoke method
905                                    (if is-static nil (get-ref (first args)))
906                                    arg-array) t)
907          (when arg-array
908            (delete-local-ref arg-array)))))))
909
910(defun make-overloaded-thunk (methods)
911  (let ((thunks (make-thunks-by-args-length methods)))
912    (lambda (&rest args)
913      (let ((fn (cdr (assoc (length args) thunks))))
914        (if fn
915            (apply fn
916                   args)
917          (error "invalid arity"))))))
918
919(defun make-thunks-by-args-length (methods)
920  "returns an alist of thunks keyed by number of args"
921  (let ((methods-by-args-length (make-hash-table))
922        (thunks-by-args-length nil))
923    (dolist (method methods)
924      (let ((is-static (modifier.isstatic (method.getmodifiers method)))
925            (params-len (get-array-length (method.getparametertypes method))))
926        (push method (gethash (if is-static params-len (1+ params-len))
927                              methods-by-args-length))))
928    (maphash #'(lambda (args-len methods)
929                 (push (cons args-len
930                             (if (rest methods);truly overloaded
931                                 (make-type-overloaded-thunk methods)
932                               ;only one method with this number of args
933                               (make-non-overloaded-thunk (first methods))))
934                       thunks-by-args-length))
935             methods-by-args-length)
936    thunks-by-args-length))
937
938(defun make-type-overloaded-thunk (methods)
939  "these methods have the same number of args and must be distinguished by type"
940  (let ((thunks (mapcar #'(lambda (method)
941                            (list (make-non-overloaded-thunk method)
942                                  (modifier.isstatic (method.getmodifiers method))
943                                  (jarray-to-list (method.getparametertypes method))))
944                        methods)))
945    (lambda (&rest args)
946      (block fn
947        (let ((arg-types (get-types-of-args args)))
948          (dolist (thunk-info thunks)
949            (destructuring-bind (thunk is-static param-types) thunk-info
950              (when (is-congruent-type-list param-types (if is-static arg-types (rest arg-types)))
951                (return-from fn (apply thunk args)))))
952          (error "No matching method"))))))
953
954
955;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
956
957(defun jref (array &rest subscripts)
958  "like aref, for Java arrays of non-primitive/reference types, settable"
959  (assert (every #'integerp subscripts))
960  (do*
961       ((sub subscripts (rest sub))
962        (a (get-ref array) (get-ref (array.get a (first sub)))))
963       ((null (rest sub))
964        (array.get a (first sub)))))
965
966(defun (setf jref) (val array &rest subscripts)
967  (assert (every #'integerp subscripts))
968  (do*
969       ((sub subscripts (rest sub))
970        (a (get-ref array) (get-ref (array.get a (first sub)))))
971       ((null (rest sub))
972        (array.set a (first sub) (get-ref val))
973        val)))
974
975(eval-when (:compile-toplevel :load-toplevel :execute)
976  (defmacro def-refs (&rest types)
977    `(locally
978       ,@(mapcan
979          (lambda (type)
980            (let ((ref-sym (intern (string-upcase (jni::string-append "jref-" (symbol-name type))))))
981              (list 
982               `(defun ,ref-sym (array &rest subscripts)
983                  ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type))
984                  (assert (every #'integerp subscripts))
985                  (do*
986                       ((sub subscripts (rest sub))
987                        (a (get-ref array) (get-ref (array.get a (first sub)))))
988                       ((null (rest sub))
989                        (,(intern (string-upcase (jni::string-append "array.get" (symbol-name type))))
990                         a (first sub)))))
991
992               `(defun (setf ,ref-sym) (val array &rest subscripts)
993                  (assert (every #'integerp subscripts))
994                  (do*
995                       ((sub subscripts (rest sub))
996                        (a (get-ref array) (get-ref (array.get a (first sub)))))
997                       ((null (rest sub))
998                        (array.set a (first sub)
999                                   (,(intern (string-upcase (jni::string-append "box-"
1000                                                                           (symbol-name type))))
1001                                    val))
1002                        val))))))
1003          types))))
1004
1005;arrays of primitives have their own accessors
1006(def-refs boolean byte char double float int short long)
1007
1008(defun jlength (array)
1009  "like length, for Java arrays"
1010  (array.getlength (get-ref array)))
1011
1012(defgeneric make-new-array (type &rest dimensions)
1013  (:documentation "generic function, with methods for all Java class designators")
1014  (:method (type &rest dims)
1015   (assert (every #'integerp dims))
1016   (if (rest dims)
1017       (let* ((ndim (length dims))
1018              (dim-array (new-int-array ndim)))
1019         (dotimes (i ndim)
1020           (array.set dim-array i (box-int (nth i dims))))
1021         (array.newinstance<java.lang.class-int<>> type dim-array))
1022     (array.newinstance<java.lang.class-int> type (first dims)))))
1023
1024(defmethod make-new-array ((type symbol) &rest dimensions)
1025  (apply #'make-new-array (get-java-class-ref type) dimensions))
1026
1027(defmethod make-new-array ((type string) &rest dimensions)
1028  (apply #'make-new-array (find-java-class type) dimensions))
1029
1030(defmethod make-new-array ((type (eql :char)) &rest dimensions)
1031  (apply #'make-new-array character.type dimensions))
1032
1033(defmethod make-new-array ((type (eql :int)) &rest dimensions)
1034  (apply #'make-new-array integer.type dimensions))
1035
1036(defmethod make-new-array ((type (eql :boolean)) &rest dimensions)
1037  (apply #'make-new-array boolean.type dimensions))
1038
1039(defmethod make-new-array ((type (eql :double)) &rest dimensions)
1040  (apply #'make-new-array double.type dimensions))
1041
1042(defmethod make-new-array ((type (eql :byte)) &rest dimensions)
1043  (apply #'make-new-array byte.type dimensions))
1044
1045(defmethod make-new-array ((type (eql :float)) &rest dimensions)
1046  (apply #'make-new-array float.type dimensions))
1047
1048(defmethod make-new-array ((type (eql :short)) &rest dimensions)
1049  (apply #'make-new-array short.type dimensions))
1050
1051(defmethod make-new-array ((type (eql :long)) &rest dimensions)
1052  (apply #'make-new-array long.type dimensions))
1053
1054;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;;
1055
1056(defun get-arg-boxers (param-types)
1057  "returns a list with one entry per param, either nil or a function that boxes the arg"
1058  (let (ret)
1059    (do-jarray (param-type param-types)
1060      (push (get-boxer-fn (class.getname param-type))
1061            ret))
1062    (nreverse ret)))
1063
1064(defun build-arg-array (args arg-boxers)
1065  (when args
1066    (let* ((arg-array (new-object-array (length args)
1067                                      ;duplication of class-symbol logic
1068                                      ;but must be fast
1069                                        (get-java-class-ref '|java.lang|::|Object|)
1070                                        nil)))
1071      (do ((i 0 (incf i))
1072           (args args (rest args))
1073           (boxers arg-boxers (rest boxers)))
1074          ((null args))
1075        (let ((arg (first args))
1076              (boxer (first boxers)))
1077          (setf (jaref arg-array i)
1078                (get-ref (if (and boxer (not (boxed? arg)))
1079                             (funcall boxer arg)
1080                           arg)))))
1081      arg-array)))
1082
1083(defun get-types-of-args (args)
1084  (let (ret)
1085    (dolist (arg args)
1086      (push (infer-box-type arg)
1087            ret))
1088    (nreverse ret)))
1089
1090(defun is-congruent-type-list (param-types arg-types)
1091  (every #'(lambda (arg-type param-type)
1092             (if arg-type
1093                 (is-assignable-from arg-type param-type)
1094               ;nil was passed - must be boolean or non-primitive target type
1095               (or (not (class.isprimitive param-type))
1096                   (is-assignable-from boolean.type param-type))))
1097         arg-types param-types))
1098
1099
1100;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;;
1101(defun box-string (s)
1102"Given a string or symbol, returns reference to a Java string"
1103  (local-ref-to-global-ref (convert-to-java-string s)))
1104
1105(defun unbox-string (ref &optional delete-local)
1106  "Given a reference to a Java string, returns a Lisp string" 
1107  (declare (ignore delete-local))
1108  (convert-from-java-string (get-ref ref)))
1109
1110(defun get-boxer-fn (class-name)
1111  (case-equal class-name
1112    ("int" #'box-int)
1113    ("boolean" #'box-boolean)
1114    ("double" #'box-double)
1115    ("java.lang.String" #'convert-to-java-string)
1116    ("char" #'box-char)
1117    ("byte" #'box-byte)
1118    ("float" #'box-float)
1119    ("long" #'box-long)
1120    ("short" #'box-short)
1121    (otherwise nil)))
1122
1123(defun get-boxer-fn-sym (class-name)
1124  (case-equal class-name
1125    ("int" 'box-int)
1126    ("boolean" 'box-boolean)
1127    ("double" 'box-double)
1128    ("java.lang.String" 'convert-to-java-string)
1129    ("char" 'box-char)
1130    ("byte" 'box-byte)
1131    ("float" 'box-float)
1132    ("long" 'box-long)
1133    ("short" 'box-short)
1134    ("void" 'box-void)
1135    (otherwise 'identity)))
1136
1137(defun boxed? (x)
1138  (or (java-ref-p x)
1139      (typep x '|java.lang|::object.)))
1140
1141(defun infer-box-type (x)
1142  (cond
1143   ((null x) nil)
1144   ((boxed? x) (object.getclass (get-ref x)))
1145   ((integerp x) integer.type)
1146   ((numberp x) double.type)
1147   ((eq x t) boolean.type)
1148   ((or (stringp x) (symbolp x))
1149    (get-java-class-ref '|java.lang|::|String|))
1150   (t (error "can't infer box type"))))
1151
1152(defun get-unboxer-fn (class-name)
1153  (case-equal class-name
1154    ("int" #'unbox-int)
1155    ("boolean" #'unbox-boolean)
1156    ("double" #'unbox-double)
1157    ("java.lang.String" #'unbox-string)
1158    ("void" #'unbox-void)
1159    ("char" #'unbox-char)
1160    ("byte" #'unbox-byte)
1161    ("float" #'unbox-float)
1162    ("long" #'unbox-long)
1163    ("short" #'unbox-short)
1164    (otherwise  #'unbox-ref)))
1165
1166(defun get-unboxer-fn-sym (class-name)
1167  (case-equal class-name
1168    ("int" 'unbox-int)
1169    ("boolean" 'unbox-boolean)
1170    ("double" 'unbox-double)
1171    ("java.lang.String" 'unbox-string)
1172    ("void" 'unbox-void)
1173    ("char" 'unbox-char)
1174    ("byte" 'unbox-byte)
1175    ("float" 'unbox-float)
1176    ("long" 'unbox-long)
1177    ("short" 'unbox-short)
1178    (otherwise  'unbox-ref)))
1179
1180(defun unbox-ref (x &optional delete-local)
1181  (declare (ignore delete-local))
1182  (local-ref-to-global-ref x))
1183
1184(defun unbox-void (x &optional delete-local)
1185  (declare (ignore x delete-local))
1186  nil)
1187
1188(defun box-void (x)
1189  (declare (ignore x))
1190  nil)
1191
1192(defun box-boolean (x)
1193  (boolean.new x))
1194
1195(defun unbox-boolean (obj &optional delete-local)
1196  (prog1
1197      (boolean.booleanvalue (get-ref obj))
1198    (when delete-local (delete-local-ref obj))))
1199
1200(defun box-byte (x)
1201  (assert (integerp x))
1202  (byte.new x))
1203
1204(defun unbox-byte (x &optional delete-local)
1205  (prog1
1206      (byte.bytevalue (get-ref x))
1207    (when delete-local (delete-local-ref x))))
1208
1209(defun box-char (x)
1210  (character.new x))
1211
1212(defun unbox-char (x &optional delete-local)
1213  (prog1
1214      (character.charvalue (get-ref x))
1215    (when delete-local (delete-local-ref x))))
1216
1217(defun box-double (x)
1218  (assert (floatp x))
1219  (double.new (coerce x 'double-float)))
1220
1221(defun unbox-double (x &optional delete-local)
1222  (prog1
1223      (double.doublevalue (get-ref x))
1224    (when delete-local (delete-local-ref x))))
1225
1226(defun box-float (x)
1227  (assert (floatp x))
1228  (float.new x))
1229
1230(defun unbox-float (x &optional delete-local)
1231  (prog1
1232      (float.floatvalue (get-ref x))
1233    (when delete-local (delete-local-ref x))))
1234
1235(defun box-int (x)
1236  (assert (integerp x))
1237  (integer.new x))
1238
1239(defun unbox-int (x &optional delete-local)
1240  (prog1
1241      (integer.intvalue (get-ref x))
1242    (when delete-local (delete-local-ref x))))
1243
1244;can't directly construct Long because LW doesn't support long long fli on 32 bit platforms
1245(defun box-long (x)
1246  (assert (integerp x))
1247  (long.valueof (princ-to-string x)))
1248
1249;here too, can only get an ints worth - aargh
1250(defun unbox-long (obj &optional delete-local)
1251  (prog1
1252      (parse-integer (object.tostring (get-ref obj)))
1253    (when delete-local (delete-local-ref obj))))
1254
1255(defun box-short (x)
1256  (assert (integerp x))
1257  (short.new x))
1258
1259(defun unbox-short (x &optional delete-local)
1260  (prog1
1261      (short.shortvalue (get-ref x))
1262    (when delete-local (delete-local-ref x))))
1263
1264
1265;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
1266
1267(defun proxy-hashcode (proxy)
1268  ;use the hashcode of the proxy's class,
1269  ;because hashcode() on the proxy flows through to the invocation handler
1270  ;is this rem guaranteed to be a fixnum?
1271  (rem (object.hashcode (object.getclass proxy)) most-positive-fixnum))
1272
1273(defvar *proxy-table* (make-hash-table :test 'jeq :hash-function 'proxy-hashcode))
1274
1275;(defvar *proxy-list* nil)
1276
1277(defun store-proxy (proxy method-fn-alist)
1278  ;(push (cons proxy method-fn-alist) *proxy-list*)
1279  (setf (gethash proxy *proxy-table*) method-fn-alist))
1280
1281(defun recall-proxy (proxy)
1282  ;(cdr (assoc proxy *proxy-list* :test #'jeq))
1283  (gethash proxy *proxy-table*))
1284
1285(defun unregister-proxy (proxy)
1286"Stops handling for the proxy and removes references from the Lisp side.
1287Make sure it is no longer referenced from Java first!"
1288  (remhash proxy *proxy-table*))
1289
1290(defun invocation-handler (proxy method args)
1291  (let* ((method-fn-alist (recall-proxy proxy))
1292         (fn (and method-fn-alist (second (assoc (object.tostring method) method-fn-alist
1293                                                 :test #'equal)))))
1294    (if fn
1295        (funcall fn args)
1296      (progn
1297        ;(throw-new  (find-java-class "java.lang.UnsupportedOperationException")
1298        ;            "No function registered in Lisp proxy object")
1299        nil))))
1300
1301(defun enable-java-proxies ()
1302  "must be called before any call to new-proxy, and requires jfli.jar be in the classpath"
1303  (jni:register-invocation-handler #'invocation-handler))
1304
1305(defun make-proxy-instance (&rest interface-defs)
1306  (let* ((interfaces (mapcar #'first interface-defs))
1307         (method-fn-alist (mapcan #'second interface-defs))
1308         (len (length interfaces))
1309         (iarray (array.newinstance<java.lang.class-int> (get-java-class-ref '|java.lang|::|Class|)
1310                                                         len)))
1311    (dotimes (x len)
1312      (setf (jref iarray x) (nth x interfaces)))
1313    (let ((proxy (proxy.newproxyinstance (classloader.getsystemclassloader)
1314                                         iarray
1315                                         (lispinvocationhandler.new))))
1316      (store-proxy proxy method-fn-alist)
1317      proxy)))
1318
1319(defun find-java-class-in-macro (name)
1320  (find-java-class
1321   (if (symbolp name)
1322       (symbol-value name)
1323     name)))
1324
1325(defmacro new-proxy (&rest interface-defs)
1326"interface-def -> (interface-name method-defs+)
1327interface-name -> \"package.qualified.ClassName\" | classname. (must name a Java interface type)
1328method-def -> (method-name arg-defs* body)
1329arg-def -> arg-name | (arg-name arg-type)
1330arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
1331method-name -> symbol | string (matched case-insensitively)
1332
1333Creates, registers and returns a Java object that implements the supplied interfaces"
1334
1335  (labels ((process-idefs (idefs)
1336             (when idefs
1337               (cons (process-idef (first idefs))
1338                     (process-idefs (rest idefs)))))
1339           (process-idef (idef)
1340             (destructuring-bind (interface-name &rest method-defs) idef
1341               (let* ((methods (class.getmethods (find-java-class-in-macro interface-name)))
1342                      (ret `(list (find-java-class ,interface-name)
1343                                  (list ,@(mapcar (lambda (method-def)
1344                                                    (process-method-def method-def methods))
1345                                                  method-defs)))))
1346                 ;check to make sure every function is defined
1347                 (do-jarray (method methods)
1348                   (let ((mname (object.tostring method)))
1349                     (unless (member mname (rest (third ret)) :key #'second :test #'equal)
1350                       (warn (format nil "proxy doesn't define:~%~A" mname)))))
1351                 ret)))
1352           (process-method-def (method-def methods)
1353             (destructuring-bind (method-name (&rest arg-defs) &body body) method-def
1354               (let ((method (matching-method method-name arg-defs methods))
1355                     (gargs (gensym)))
1356                 `(list ,(object.tostring method)
1357                        (lambda (,gargs)
1358                          (,(get-boxer-fn-sym (class.getname (method.getreturntype method)))
1359                           (let ,(arg-lets arg-defs
1360                                           (jarray-to-list (method.getparametertypes method))
1361                                           gargs
1362                                           0)
1363                             ,@body)))))))
1364           (arg-lets (arg-defs params gargs idx)
1365             (when arg-defs
1366               (let ((arg (first arg-defs))
1367                     (param (first params)))
1368                 (cons `(,(if (atom arg) arg (first arg))
1369                         (,(get-unboxer-fn-sym (class.getname param))
1370                          (jref ,gargs ,idx) t))
1371                       (arg-lets (rest arg-defs) (rest params) gargs (1+ idx))))))
1372           (matching-method (method-name arg-defs methods)
1373             (let (match)
1374               (do-jarray (method methods)
1375                 (when (method-matches method-name arg-defs method)
1376                   (if match
1377                       (error (format nil "more than one method matches ~A" method-name))
1378                     (setf match method))))
1379               (or match (error (format nil "no method matches ~A" method-name)))))
1380           (method-matches (method-name arg-defs method)
1381             (when (string-equal method-name (method.getname method))
1382               (let ((params (method.getparametertypes method)))
1383                 (when (= (length arg-defs) (jlength params))
1384                   (is-congruent arg-defs params)))))
1385           (is-congruent (arg-defs params)
1386             (every (lambda (arg param)
1387                      (or (atom arg) ;no type spec matches anything
1388                          (jeq (find-java-class-in-macro (second arg)) param)))
1389                    arg-defs (jarray-to-list params))))
1390    `(make-proxy-instance ,@(process-idefs interface-defs))))
Note: See TracBrowser for help on using the repository browser.