source: branches/1.1.x/contrib/jfli/jfli.lisp

Last change on this file was 14295, checked in by Mark Evenson, 12 years ago

jfli: use MOP::ENSURE-CLASS.

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