Commit | Line | Data |
---|---|---|
ee79a5f1 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Pleasant Lisp interface to Java class libraries | |
4 | ;;; | |
5 | ;;; (c) 2007 Mark Wooding | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
14 | ;;; | |
15 | ;;; This program is distributed in the hope that it will be useful, | |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | (defpackage #:jj | |
25 | (:use #:common-lisp #:java) | |
26 | (:export #:java-name #:lisp-name | |
fc7489de | 27 | #:java-true #:java-false #:java-null #:jboolean |
ee79a5f1 MW |
28 | #:send #:send-class #:make #:make-java-array #:java-array |
29 | #:field #:class-field | |
30 | #:magic-constant-case | |
31 | #:implementation)) | |
32 | ||
33 | (in-package #:jj) | |
34 | ||
35 | ;;;-------------------------------------------------------------------------- | |
36 | ;;; Utilities. | |
37 | ||
38 | (defmacro with-string-iterator ((iterator | |
39 | string | |
40 | &key | |
41 | (character (gensym "CHAR")) | |
42 | (index (gensym "INDEX")) | |
43 | (start 0) | |
44 | (end nil)) | |
45 | &body body) | |
46 | "Evaluate BODY with ITERATOR fbound to a function which returns successive | |
47 | characters from the substring of STRING indicated by START and END. The | |
48 | variables named by INDEX and CHARACTER are bound to the current index | |
49 | within STRING and the current character; they are modified by assignment | |
50 | by the ITERATOR function. The ITERATOR takes one (optional) argument | |
51 | EOSP: if false (the default), ITERATOR signals an error if it reads past | |
52 | the end of the indicated substring; if true, it returns nil at | |
53 | end-of-string." | |
54 | (let ((tstring (gensym "STRING")) | |
55 | (tend (gensym "END"))) | |
56 | `(let* ((,tstring ,string) | |
57 | (,index ,start) | |
58 | (,tend (or ,end (length ,tstring))) | |
59 | (,character nil)) | |
60 | (flet ((,iterator (&optional eosp) | |
61 | (cond ((< ,index ,tend) | |
62 | (setf ,character (char ,tstring ,index)) | |
63 | (incf ,index) | |
64 | ,character) | |
65 | (eosp nil) | |
66 | (t (error "Unexpected end-of-string."))))) | |
67 | ,@body)))) | |
68 | ||
69 | ;;;-------------------------------------------------------------------------- | |
70 | ;;; Name conversion. | |
71 | ||
72 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
73 | ||
74 | (defun java-name (name) | |
75 | "Returns the Java-name for NAME, as a string. If NAME is a string, it is | |
76 | returned as-is. If NAME is a symbol, its print-name is converted | |
77 | according to these rules. The name is split into components separated | |
78 | by `.' characters; the components are converted independently, and | |
79 | joined, again using `.'s. | |
80 | ||
81 | * The final component is treated specially: if the first and last | |
82 | characters are both `*' then the `*'s are stripped off, all `-'s are | |
83 | replaced by `_'s, and other characters are emitted as-is. | |
84 | ||
85 | * If the first character of a component is `*' then the `*' is | |
86 | stripped and the following character is converted to upper-case. | |
87 | ||
88 | * A double `-' is replaced by an underscore `_'. | |
89 | ||
90 | * A single `-' is stripped and the following character converted to | |
91 | upper-case. | |
92 | ||
93 | * Other characters are converted to lower-case. | |
94 | ||
95 | These are the inverse of the rules for lisp-name (q.v.). | |
96 | ||
97 | Examples: | |
98 | ||
99 | Lisp name Java name | |
100 | ||
101 | FOO foo | |
102 | JAVA.AWT.*GRID-BAG-CONSTRAINTS java.awt.GridBagConstraints | |
103 | *HORIZONTAL-SPLIT* HORIZONTAL_SPLIT" | |
104 | ||
105 | (etypecase name | |
106 | (string name) | |
107 | (symbol | |
108 | (let* ((name (symbol-name name)) | |
109 | (n (length name))) | |
110 | (with-output-to-string (out) | |
111 | (with-string-iterator (getch name :character ch :index i :end n) | |
112 | (tagbody | |
113 | top | |
114 | (getch) | |
115 | (case ch | |
116 | (#\- (go upnext)) | |
117 | (#\* (cond ((and (char= #\* (char name (1- n))) | |
118 | (every (lambda (ch) | |
119 | (or (char= #\- ch) | |
120 | (alphanumericp ch))) | |
121 | (subseq name i (1- n)))) | |
122 | (map nil | |
123 | (lambda (ch) | |
124 | (write-char (if (char= #\- ch) #\_ ch) | |
125 | out)) | |
126 | (subseq name i (1- n))) | |
127 | (go done)) | |
128 | (t | |
129 | (go upnext)))) | |
130 | (t (go main))) | |
131 | main | |
132 | (unless (alphanumericp ch) | |
133 | (error "Bad character in name.")) | |
134 | (write-char (char-downcase ch) out) | |
135 | next | |
136 | (unless (getch t) (go done)) | |
137 | (case ch | |
138 | (#\- (go upnext)) | |
139 | (#\. (write-char #\. out) (go top)) | |
140 | (t (go main))) | |
141 | upnext | |
142 | (getch) | |
143 | (cond ((char= ch #\-) (write-char #\_ out)) | |
144 | ((alphanumericp ch) (write-char (char-upcase ch) out)) | |
145 | (t (error "Bad character in name."))) | |
146 | (go next) | |
147 | done))))))) | |
148 | ||
149 | (defun lisp-name (name &optional (package :keyword)) | |
150 | "Returns the Lisp-name for NAME, as a symbol interned in the given | |
151 | PACKAGE (defaults to keyword). The name is split into components | |
152 | separated by `.' characters, converted independently, and joined again | |
153 | using `.'s. | |
154 | ||
155 | * The final component is treated specially. If it consists entirely | |
156 | of `_', digits and upper-case letters, it is converted by replacing | |
157 | the `_'s by `-'s, and adding a `*' to the beginning and end. | |
158 | ||
159 | * If the first character of a component is upper-case, an `*' is | |
160 | prepended. Other upper-case characters are preceded by `-'s. | |
161 | ||
162 | * Any `_' characters are replaced by `--'. | |
163 | ||
164 | * All letters are converted to upper-case. | |
165 | ||
166 | These are the inverse of the rules for java-name (q.v.)." | |
167 | ||
168 | (let ((n (length name))) | |
169 | (intern (with-output-to-string (out) | |
170 | (with-string-iterator | |
171 | (getch name :character ch :index i :end n) | |
172 | (tagbody | |
173 | top | |
174 | (getch) | |
175 | (when (upper-case-p ch) | |
176 | (write-char #\* out) | |
177 | (let ((mid (make-array (- n i -1) | |
178 | :element-type | |
179 | (array-element-type name) | |
180 | :displaced-to name | |
181 | :displaced-index-offset | |
182 | (1- i)))) | |
183 | (when (every (lambda (ch) | |
184 | (or (char= #\_ ch) | |
185 | (digit-char-p ch) | |
186 | (upper-case-p ch))) | |
187 | mid) | |
188 | (map nil | |
189 | (lambda (ch) | |
190 | (write-char (if (char= #\_ ch) #\- ch) | |
191 | out)) | |
192 | mid) | |
193 | (write-char #\* out) | |
194 | (go done)))) | |
195 | main | |
196 | (write-char (char-upcase ch) out) | |
197 | next | |
198 | (unless (getch t) (go done)) | |
199 | (cond ((char= #\_ ch) | |
200 | (write-string "--" out) | |
201 | (go next)) | |
202 | ((char= #\. ch) | |
203 | (write-char #\. out) | |
204 | (go top)) | |
205 | ((upper-case-p ch) | |
206 | (write-char #\- out))) | |
207 | (go main) | |
208 | done))) | |
209 | package)))) | |
210 | ||
211 | ;;;-------------------------------------------------------------------------- | |
212 | ;;; Dynamic method dispatch. | |
213 | ||
214 | (defparameter *class-table* (make-hash-table :test #'equal) | |
215 | "A hash table mapping Java class names (as strings, using their Java names) | |
216 | to java-class structures. ") | |
217 | ||
218 | (defstruct java-method | |
219 | "Structure describing a Java method or constructor. The slots are as | |
220 | follows. | |
221 | ||
222 | * cache -- hash table mapping a list of argument types (as Java class | |
223 | objects) to appropriate method. This table is populated as we go. | |
224 | ||
225 | * name -- Lisp symbol naming the method; :constructor for constructors. | |
226 | ||
227 | * min-args -- smallest number of arguments acceptable to the method. | |
228 | ||
229 | * max-args -- largest number of arguments acceptable. | |
230 | ||
231 | * overloads -- vector, indexed by (- nargs min-args), of (jmethod . | |
232 | argument-types) pairs." | |
233 | ||
234 | (cache (make-hash-table :test #'equal) :type hash-table) | |
235 | (name nil :type symbol) | |
236 | (min-args 0 :type fixnum) | |
237 | (max-args 0 :type fixnum) | |
238 | (overloads nil :type vector)) | |
239 | ||
240 | (defstruct java-class | |
241 | "Structure describing a Java class. The slots are as follows. | |
242 | ||
243 | * name -- Lisp symbol naming the class. | |
244 | ||
245 | * jclass -- the Java class object. | |
246 | ||
247 | * methods -- hash table mapping Lisp method names to java-method | |
248 | structures. | |
249 | ||
250 | * constructor -- java-method structure describing the available | |
251 | constructors." | |
252 | ||
253 | (name nil :type symbol) | |
254 | (jclass nil :type java-object) | |
255 | (methods nil :type (or hash-table null)) | |
256 | (constructor nil :type (or java-method null))) | |
257 | ||
258 | (defconstant java-true (make-immediate-object t :boolean) | |
259 | "The Java `true' object.") | |
260 | (defconstant java-false (make-immediate-object nil :boolean) | |
261 | "The Java `false' object.") | |
262 | (defconstant java-null (make-immediate-object nil :ref) | |
263 | "A Java null reference.") | |
264 | ||
fc7489de MW |
265 | (defun jboolean (thing) |
266 | "Return JAVA-TRUE if THING is non-nil, JAVA-FALSE if THING is nil." | |
267 | (if thing java-true java-false)) | |
268 | ||
ee79a5f1 MW |
269 | (defmacro define-java-method (lisp-name class method &body args) |
270 | "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the | |
271 | given arguments. The CLASS may be a string or symbol (it is converted by | |
272 | java-name). The ARGS are (NAME TYPE) lists, where each TYPE is a string | |
273 | or symbol naming a Java class." | |
274 | (let ((arg-names (mapcar #'car args)) | |
275 | (arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args))) | |
276 | `(let ((meth (jmethod (jclass ,(java-name class)) | |
277 | ,(java-name method) | |
278 | ,@arg-types))) | |
279 | (defun ,lisp-name (this ,@arg-names) | |
280 | (jcall meth this ,@arg-names))))) | |
281 | ||
282 | (defun find-java-class (class) | |
283 | "Return the java-class structure for the given CLASS, which may be a | |
284 | java-class structure, a Java class object (note the difference!), a string | |
285 | naming a Java class, or a symbol giving the name in Lisp form." | |
286 | (if (java-class-p class) | |
287 | class | |
288 | (let ((jclass (jclass (if (symbolp class) (java-name class) class)))) | |
289 | (or (gethash jclass *class-table*) | |
290 | (setf (gethash jclass *class-table*) | |
291 | (make-java-class :name (lisp-name (jclass-name jclass)) | |
292 | :jclass jclass)))))) | |
293 | ||
294 | (defun construct-method-table (methods get-params get-name) | |
295 | "Constructs the method table (as a hash-table) for a java-class object. | |
296 | The METHODS are a vector of method (or constructor) objects; GET-PARAMS is | |
297 | a function which is given a method object and returns a sequence of | |
298 | argument type objects; and GET-NAME is a function which is given a method | |
299 | object and returns the method's name, as a Lisp symbol. | |
300 | ||
301 | The indirection is because, inexplicably, one has to use different | |
302 | functions to extract this information from methods or constructors." | |
303 | ||
304 | (let ((by-name (make-hash-table)) | |
305 | (output (make-hash-table))) | |
306 | ||
307 | ;; First pass: break the list up by name. | |
308 | (dotimes (i (length methods)) | |
309 | (let* ((jmethod (aref methods i)) | |
310 | (arg-types (funcall get-params jmethod))) | |
311 | (push (list* (length arg-types) | |
312 | jmethod | |
313 | (coerce arg-types 'list)) | |
314 | (gethash (funcall get-name jmethod) by-name)))) | |
315 | ||
316 | ;; Second pass: sift each name bucket by numbers of arguments. | |
317 | (maphash (lambda (name list) | |
318 | (let* ((arg-lengths (mapcar #'car list)) | |
319 | (min-args (apply #'min arg-lengths)) | |
320 | (max-args (apply #'max arg-lengths)) | |
321 | (overloads (make-array (- max-args min-args -1) | |
322 | :initial-element nil))) | |
323 | (dolist (item list) | |
324 | (pushnew (cdr item) | |
325 | (aref overloads (- (car item) min-args)) | |
326 | :test #'equal | |
327 | :key #'cdr)) | |
328 | (setf (gethash name output) | |
329 | (make-java-method :min-args min-args | |
330 | :name name | |
331 | :max-args max-args | |
332 | :overloads overloads)))) | |
333 | by-name) | |
334 | ||
335 | ;; Done! | |
336 | output)) | |
337 | ||
338 | (defun ensure-java-method-table (java-class) | |
339 | "Ensure that JAVA-CLASS has a method table, and return it." | |
340 | (or (java-class-methods java-class) | |
341 | (setf (java-class-methods java-class) | |
342 | (construct-method-table (jclass-methods | |
343 | (java-class-jclass java-class)) | |
344 | #'jmethod-params | |
345 | (lambda (jmethod) | |
346 | (lisp-name (jmethod-name jmethod))))))) | |
347 | ||
348 | (defun ensure-java-constructor (java-class) | |
349 | "Ensure that JAVA-CLASS has a constructor object, and return it." | |
350 | (or (java-class-constructor java-class) | |
351 | (setf (java-class-constructor java-class) | |
352 | (gethash :constructor | |
353 | (construct-method-table (jclass-constructors | |
354 | (java-class-jclass java-class)) | |
355 | #'jconstructor-params | |
356 | (constantly :constructor)))))) | |
357 | ||
358 | (defun find-java-method (class name) | |
359 | "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp | |
360 | symbol or Java name string), return the corresponding java-method | |
361 | structure." | |
362 | (let ((java-class (find-java-class class))) | |
363 | (gethash (if (symbolp name) name (lisp-name name)) | |
364 | (ensure-java-method-table java-class)))) | |
365 | ||
366 | (defun find-java-constructor (class) | |
367 | "Given a CLASS (in a form acceptable to find-java-class), return the | |
368 | java-method structure for its constructor." | |
369 | (ensure-java-constructor (find-java-class class))) | |
370 | ||
371 | (defun expand-java-method (java-method) | |
372 | "Return a list-of-lists: for each overload of the method, return a list of | |
373 | its argument types, in ascending order of number of arguments." | |
374 | (let ((out nil)) | |
375 | (dotimes (i (length (java-method-overloads java-method))) | |
376 | (dolist (item (cdr (aref (java-method-overloads java-method) i))) | |
377 | (push (mapcar (lambda (arg) | |
378 | (lisp-name (jclass-name arg))) | |
379 | (cdr item)) | |
380 | out))) | |
381 | (nreverse out))) | |
382 | ||
383 | (defun expand-java-class (java-class) | |
384 | "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...)) | |
385 | describing the state of a JAVA-CLASS object. Useful for diagnostics." | |
386 | (list (java-class-name java-class) | |
387 | (cons :constructors | |
388 | (expand-java-method (ensure-java-constructor java-class))) | |
fc7489de MW |
389 | (sort (loop for name being the hash-keys |
390 | of (ensure-java-method-table java-class) | |
391 | using (hash-value method) | |
392 | collect (cons name (expand-java-method method))) | |
393 | (lambda (x y) (string< (car x) (car y)))))) | |
ee79a5f1 MW |
394 | |
395 | (defparameter *conversions* | |
396 | (let ((raw '((java.lang.*object boolean) | |
397 | (java.lang.*number double) | |
398 | (java.lang.*comparable double) | |
399 | (double float java.lang.*double) | |
400 | (float long java.lang.*float) | |
401 | (long int java.lang.*long) | |
402 | (int short char java.lang.*integer) | |
403 | (short byte java.lang.*short) | |
404 | (char java.lang.*character) | |
405 | (boolean java.lang.*boolean)))) | |
406 | (labels ((lookup (type) | |
407 | (cdr (assoc type raw))) | |
408 | (closure (type) | |
409 | (delete-duplicates | |
410 | (cons type | |
411 | (mapcan #'closure (lookup type)))))) | |
412 | (mapcar (lambda (row) (mapcar (lambda (name) | |
413 | (jclass (java-name name))) | |
414 | (closure (car row)))) | |
415 | raw))) | |
416 | "Table encoding the various implicit conversions for primitive types, used | |
417 | occasionally to disambiguate multiple method matches.") | |
418 | ||
419 | (defun jclass-convertible-p (from to) | |
420 | "Return whether there is an automatic conversion between FROM and TO. This | |
421 | can be considered a partial order on types." | |
fc7489de MW |
422 | (or (null from) |
423 | (jclass-superclass-p to from) | |
ee79a5f1 MW |
424 | (member from (assoc to *conversions* :test #'equal) |
425 | :test #'equal))) | |
426 | ||
427 | (defun argument-list-betterp (first second) | |
428 | "Return whether the type-list FIRST is `better' than SECOND, in the sense | |
429 | that there is an implicit conversion between each element of FIRST and the | |
430 | corresponding element of SECOND. This lifts the partial order of | |
431 | jclass-better-p to lists of types." | |
432 | (cond ((endp first) (endp second)) | |
433 | ((endp second) nil) | |
434 | (t (and (jclass-convertible-p (car first) (car second)) | |
435 | (argument-list-betterp (cdr first) (cdr second)))))) | |
436 | ||
fc7489de | 437 | (defun get-jmethod-for-argument-types (java-class java-method argument-types) |
ee79a5f1 MW |
438 | "Given a JAVA-METHOD structure, return the best match overload for the |
439 | given list of ARGUMENT-TYPES. | |
440 | ||
441 | An overload is considered to be a match if there is an implicit conversion | |
442 | from each actual argument type to the corresponding formal argument type. | |
443 | One matching overload is better than another if there is an implicit | |
444 | conversion from each of the former's argument types to the type of the | |
445 | corresponding argument of the latter. If there is no unique best match | |
446 | then an error is signalled. | |
447 | ||
448 | In the language of the partial order defined by argument-list-betterp | |
449 | (q.v.), which we write as <=, let us denote the actual argument types by | |
450 | A, and the argument types of an overload O as simply O; then O is a match | |
451 | for A if A <= O and O is a better match than O' if O <= O'; let M be the | |
452 | set of matching overloads M = { O | A <= O }; we seek the minimum element | |
453 | of M." | |
454 | ||
455 | (or (gethash argument-types (java-method-cache java-method)) | |
456 | (labels ((expand-arglist (args) | |
457 | (mapcar (lambda (arg) | |
458 | (lisp-name (jclass-name arg))) | |
459 | args)) | |
460 | (expand-methodlist (methods) | |
461 | (mapcar (lambda (method) (expand-arglist (cdr method))) | |
462 | methods)) | |
463 | (consider (best next) | |
464 | #+debug | |
465 | (format t "*** currently: ~S~%*** considering: ~S~%" | |
466 | (expand-methodlist best) | |
467 | (expand-arglist (cdr next))) | |
468 | (let ((winners (remove-if | |
469 | (lambda (method) | |
470 | (argument-list-betterp (cdr next) | |
471 | (cdr method))) | |
472 | best)) | |
473 | (include-next-p (every | |
474 | (lambda (method) | |
475 | (not (argument-list-betterp | |
476 | (cdr method) | |
477 | (cdr next)))) | |
478 | best))) | |
479 | (if include-next-p | |
480 | (cons next winners) | |
481 | winners)))) | |
482 | (let* ((nargs (length argument-types)) | |
483 | (min-args (java-method-min-args java-method)) | |
484 | (max-args (java-method-max-args java-method)) | |
485 | (candidates | |
486 | (and (<= min-args nargs max-args) | |
487 | (remove-if-not (lambda (method) | |
488 | (argument-list-betterp argument-types | |
489 | (cdr method))) | |
490 | (aref (java-method-overloads java-method) | |
491 | (- nargs min-args))))) | |
492 | (chosen (and candidates | |
493 | (reduce #'consider (cdr candidates) | |
494 | :initial-value (list | |
495 | (car candidates)))))) | |
496 | #+debug | |
497 | (progn | |
498 | (format t "*** candidates = ~S~%" | |
499 | (expand-methodlist candidates)) | |
500 | (format t "*** chosen = ~S~%" | |
501 | (expand-methodlist chosen))) | |
502 | (cond ((null chosen) | |
fc7489de MW |
503 | (error "No match found.~% ~ |
504 | class = ~A, method = ~A~% ~ | |
505 | args = ~A" | |
506 | (java-class-name java-class) | |
ee79a5f1 MW |
507 | (java-method-name java-method) |
508 | (expand-arglist argument-types))) | |
509 | ((cdr chosen) | |
510 | (error "Ambiguous match.~% ~ | |
511 | method = ~A, args = ~A~% ~ | |
512 | matches = ~A" | |
513 | (java-method-name java-method) | |
514 | (expand-arglist argument-types) | |
515 | (expand-methodlist chosen))) | |
516 | (t (setf (gethash argument-types | |
517 | (java-method-cache java-method)) | |
518 | (caar chosen)))))))) | |
519 | ||
520 | (defun argument-type-list-from-names (names) | |
521 | "Given a list of type NAMES, return the corresponding Java class objects." | |
522 | (mapcar (lambda (name) | |
523 | (java-class-jclass (find-java-class name))) | |
524 | names)) | |
525 | ||
526 | (defun find-jmethod (class name arg-types) | |
527 | "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java | |
528 | method object for the best matching overload of the method." | |
fc7489de MW |
529 | (let ((java-class (find-java-class class))) |
530 | (get-jmethod-for-argument-types | |
531 | java-class | |
532 | (find-java-method java-class name) | |
533 | (argument-type-list-from-names arg-types)))) | |
ee79a5f1 MW |
534 | |
535 | (defun find-jconstructor (class arg-types) | |
536 | "Given a CLASS and a list of ARG-TYPES, return the Java constructor object | |
537 | for the best matching constructor overload." | |
fc7489de MW |
538 | (let ((java-class (find-java-class class))) |
539 | (get-jmethod-for-argument-types | |
540 | java-class | |
541 | (find-java-constructor java-class) | |
542 | (argument-type-list-from-names arg-types)))) | |
ee79a5f1 MW |
543 | |
544 | (defun send (object message &rest arguments) | |
545 | "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and | |
546 | other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best | |
547 | matches the types of the ARGUMENTS." | |
548 | (let ((jargs (mapcar #'make-immediate-object arguments))) | |
549 | (apply #'jcall | |
550 | (find-jmethod (jobject-class object) message | |
fc7489de MW |
551 | (mapcar (lambda (jarg) |
552 | (if (equal jarg java-null) | |
553 | nil | |
554 | (jobject-class jarg))) | |
555 | jargs)) | |
ee79a5f1 MW |
556 | object |
557 | jargs))) | |
558 | ||
559 | (defun send-class (class message &rest arguments) | |
560 | "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name | |
561 | (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static | |
562 | method of CLASS named by MESSAGE which best matches the types of the | |
563 | ARGUMENTS." | |
564 | (let ((java-class (find-java-class class)) | |
565 | (jargs (mapcar #'make-immediate-object arguments))) | |
566 | (apply #'jcall | |
567 | (find-jmethod java-class message | |
568 | (mapcar (lambda (jarg) (jobject-class jarg)) jargs)) | |
569 | java-null | |
570 | jargs))) | |
571 | ||
572 | (defun make (class &rest arguments) | |
573 | "Given a CLASS (anything acceptable to find-java-class) and other | |
574 | ARGUMENTS, invoke the constructor of CLASS which best matches the types of | |
575 | the ARGUMENTS, returning the result." | |
576 | (let ((java-class (find-java-class class)) | |
577 | (jargs (mapcar #'make-immediate-object arguments))) | |
578 | (apply #'jnew | |
579 | (find-jconstructor java-class | |
580 | (mapcar (lambda (jarg) (jobject-class jarg)) | |
581 | jargs)) | |
582 | jargs))) | |
583 | ||
584 | ;;;-------------------------------------------------------------------------- | |
585 | ;;; Field access. | |
586 | ||
587 | (defun field (object name) | |
588 | "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return | |
589 | the value of the OBJECT's field with the given NAME. This is a valid | |
590 | place for setf." | |
591 | (jfield (java-name name) object)) | |
592 | ||
593 | (defun (setf field) (value object name) | |
594 | "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set | |
595 | the OBJECT's field with the given NAME to be VALUE." | |
596 | (jfield object name value)) | |
597 | ||
598 | (defun class-field (class name) | |
599 | "Given a CLASS and a field NAME (Lisp symbol or Java name string), return | |
600 | the value of the CLASS's static field with the given NAME. This is a | |
601 | valid place for setf." | |
602 | (jfield (jclass (java-name class)) (java-name name))) | |
603 | ||
604 | (defun (setf class-field) (value class name) | |
605 | "Given an CLASS and a field NAME (Lisp symbol or Java name string), set | |
606 | the CLASS's static field with the given NAME to be VALUE." | |
607 | (jfield (jclass (java-name class)) (java-name name) nil value)) | |
608 | ||
609 | ;;;-------------------------------------------------------------------------- | |
610 | ;;; Arrays. | |
611 | ||
612 | (defun make-java-array (class items) | |
613 | "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS, | |
614 | return a Java array specialized for the named CLASS, containing the | |
615 | ITEMS." | |
616 | (jnew-array-from-array (if (symbolp class) (java-name class) class) | |
617 | (if (listp items) (coerce items 'vector) items))) | |
618 | ||
619 | (defun java-array (class &rest items) | |
620 | "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a | |
621 | Java array specialized for the named CLASS, containing the ITEMS." | |
622 | (make-java-array class items)) | |
623 | ||
624 | ;;;-------------------------------------------------------------------------- | |
625 | ;;; Interfaces. | |
626 | ||
627 | (defmacro implementation (class &body clauses) | |
628 | "Returns an implementation of the interface names by CLASS (Lisp symbol or | |
629 | Java name string), whose methods are defined by CLAUSES; each clause has | |
630 | the form (NAME (BVL ...) FORMS...) where NAME is the name of a method | |
631 | (Lisp symbol or Java name string), BVL is a standard bound-variable list, | |
632 | and FORMS are any Lisp forms providing the implementation of the method." | |
633 | `(jinterface-implementation | |
634 | ,(java-name class) | |
635 | ,@(loop for (name bvl . body) in clauses | |
636 | collect (java-name name) | |
637 | collect `(lambda ,bvl ,@body)))) | |
638 | ||
639 | ;;;-------------------------------------------------------------------------- | |
640 | ;;; Other useful hacks. | |
641 | ||
642 | (defmacro magic-constant-case ((selector class) &body keywords) | |
643 | "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java | |
644 | class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp | |
645 | keyword objects. The SELECTOR is matched against the KEYWORDS. If a | |
646 | match is found, the keyword is converted to upper-case, `-' is converted | |
647 | to `_', and the result used as a Java static field name of the specified | |
648 | CLASS; the value of this field is returned as the value of the expression. | |
649 | ||
650 | Note that the class field lookups are really done at macro-expansion time, | |
651 | not at run-time." | |
652 | `(ecase ,selector | |
653 | ,@(mapcar (lambda (key) | |
654 | `(,key ,(class-field class | |
655 | (substitute #\_ #\- | |
656 | (string-upcase key))))) | |
657 | keywords))) | |
658 | ||
659 | ;;;----- That's all, folks -------------------------------------------------- |