3 ;;; Pleasant Lisp interface to Java class libraries
5 ;;; (c) 2007 Mark Wooding
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
25 (:use #:common-lisp #:java)
26 (:export #:java-name #:lisp-name
27 #:java-true #:java-false #:java-null
28 #:send #:send-class #:make #:make-java-array #:java-array
35 ;;;--------------------------------------------------------------------------
38 (defmacro with-string-iterator ((iterator
41 (character (gensym "CHAR"))
42 (index (gensym "INDEX"))
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
54 (let ((tstring (gensym "STRING"))
55 (tend (gensym "END")))
56 `(let* ((,tstring ,string)
58 (,tend (or ,end (length ,tstring)))
60 (flet ((,iterator (&optional eosp)
61 (cond ((< ,index ,tend)
62 (setf ,character (char ,tstring ,index))
66 (t (error "Unexpected end-of-string.")))))
69 ;;;--------------------------------------------------------------------------
72 (eval-when (:compile-toplevel :load-toplevel :execute)
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.
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.
85 * If the first character of a component is `*' then the `*' is
86 stripped and the following character is converted to upper-case.
88 * A double `-' is replaced by an underscore `_'.
90 * A single `-' is stripped and the following character converted to
93 * Other characters are converted to lower-case.
95 These are the inverse of the rules for lisp-name (q.v.).
102 JAVA.AWT.*GRID-BAG-CONSTRAINTS java.awt.GridBagConstraints
103 *HORIZONTAL-SPLIT* HORIZONTAL_SPLIT"
108 (let* ((name (symbol-name name))
110 (with-output-to-string (out)
111 (with-string-iterator (getch name :character ch :index i :end n)
117 (#\* (cond ((and (char= #\* (char name (1- n)))
121 (subseq name i (1- n))))
124 (write-char (if (char= #\- ch) #\_ ch)
126 (subseq name i (1- n)))
132 (unless (alphanumericp ch)
133 (error "Bad character in name."))
134 (write-char (char-downcase ch) out)
136 (unless (getch t) (go done))
139 (#\. (write-char #\. out) (go top))
143 (cond ((char= ch #\-) (write-char #\_ out))
144 ((alphanumericp ch) (write-char (char-upcase ch) out))
145 (t (error "Bad character in name.")))
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
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.
159 * If the first character of a component is upper-case, an `*' is
160 prepended. Other upper-case characters are preceded by `-'s.
162 * Any `_' characters are replaced by `--'.
164 * All letters are converted to upper-case.
166 These are the inverse of the rules for java-name (q.v.)."
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)
175 (when (upper-case-p ch)
177 (let ((mid (make-array (- n i -1)
179 (array-element-type name)
181 :displaced-index-offset
183 (when (every (lambda (ch)
190 (write-char (if (char= #\_ ch) #\- ch)
196 (write-char (char-upcase ch) out)
198 (unless (getch t) (go done))
199 (cond ((char= #\_ ch)
200 (write-string "--" out)
206 (write-char #\- out)))
211 ;;;--------------------------------------------------------------------------
212 ;;; Dynamic method dispatch.
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. ")
218 (defstruct java-method
219 "Structure describing a Java method or constructor. The slots are as
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.
225 * name -- Lisp symbol naming the method; :constructor for constructors.
227 * min-args -- smallest number of arguments acceptable to the method.
229 * max-args -- largest number of arguments acceptable.
231 * overloads -- vector, indexed by (- nargs min-args), of (jmethod .
232 argument-types) pairs."
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))
240 (defstruct java-class
241 "Structure describing a Java class. The slots are as follows.
243 * name -- Lisp symbol naming the class.
245 * jclass -- the Java class object.
247 * methods -- hash table mapping Lisp method names to java-method
250 * constructor -- java-method structure describing the available
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)))
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.")
265 (defmacro define-java-method (lisp-name class method &body args)
266 "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
267 given arguments. The CLASS may be a string or symbol (it is converted by
268 java-name). The ARGS are (NAME TYPE) lists, where each TYPE is a string
269 or symbol naming a Java class."
270 (let ((arg-names (mapcar #'car args))
271 (arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args)))
272 `(let ((meth (jmethod (jclass ,(java-name class))
275 (defun ,lisp-name (this ,@arg-names)
276 (jcall meth this ,@arg-names)))))
278 (defun find-java-class (class)
279 "Return the java-class structure for the given CLASS, which may be a
280 java-class structure, a Java class object (note the difference!), a string
281 naming a Java class, or a symbol giving the name in Lisp form."
282 (if (java-class-p class)
284 (let ((jclass (jclass (if (symbolp class) (java-name class) class))))
285 (or (gethash jclass *class-table*)
286 (setf (gethash jclass *class-table*)
287 (make-java-class :name (lisp-name (jclass-name jclass))
290 (defun construct-method-table (methods get-params get-name)
291 "Constructs the method table (as a hash-table) for a java-class object.
292 The METHODS are a vector of method (or constructor) objects; GET-PARAMS is
293 a function which is given a method object and returns a sequence of
294 argument type objects; and GET-NAME is a function which is given a method
295 object and returns the method's name, as a Lisp symbol.
297 The indirection is because, inexplicably, one has to use different
298 functions to extract this information from methods or constructors."
300 (let ((by-name (make-hash-table))
301 (output (make-hash-table)))
303 ;; First pass: break the list up by name.
304 (dotimes (i (length methods))
305 (let* ((jmethod (aref methods i))
306 (arg-types (funcall get-params jmethod)))
307 (push (list* (length arg-types)
309 (coerce arg-types 'list))
310 (gethash (funcall get-name jmethod) by-name))))
312 ;; Second pass: sift each name bucket by numbers of arguments.
313 (maphash (lambda (name list)
314 (let* ((arg-lengths (mapcar #'car list))
315 (min-args (apply #'min arg-lengths))
316 (max-args (apply #'max arg-lengths))
317 (overloads (make-array (- max-args min-args -1)
318 :initial-element nil)))
321 (aref overloads (- (car item) min-args))
324 (setf (gethash name output)
325 (make-java-method :min-args min-args
328 :overloads overloads))))
334 (defun ensure-java-method-table (java-class)
335 "Ensure that JAVA-CLASS has a method table, and return it."
336 (or (java-class-methods java-class)
337 (setf (java-class-methods java-class)
338 (construct-method-table (jclass-methods
339 (java-class-jclass java-class))
342 (lisp-name (jmethod-name jmethod)))))))
344 (defun ensure-java-constructor (java-class)
345 "Ensure that JAVA-CLASS has a constructor object, and return it."
346 (or (java-class-constructor java-class)
347 (setf (java-class-constructor java-class)
348 (gethash :constructor
349 (construct-method-table (jclass-constructors
350 (java-class-jclass java-class))
351 #'jconstructor-params
352 (constantly :constructor))))))
354 (defun find-java-method (class name)
355 "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp
356 symbol or Java name string), return the corresponding java-method
358 (let ((java-class (find-java-class class)))
359 (gethash (if (symbolp name) name (lisp-name name))
360 (ensure-java-method-table java-class))))
362 (defun find-java-constructor (class)
363 "Given a CLASS (in a form acceptable to find-java-class), return the
364 java-method structure for its constructor."
365 (ensure-java-constructor (find-java-class class)))
367 (defun expand-java-method (java-method)
368 "Return a list-of-lists: for each overload of the method, return a list of
369 its argument types, in ascending order of number of arguments."
371 (dotimes (i (length (java-method-overloads java-method)))
372 (dolist (item (cdr (aref (java-method-overloads java-method) i)))
373 (push (mapcar (lambda (arg)
374 (lisp-name (jclass-name arg)))
379 (defun expand-java-class (java-class)
380 "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...))
381 describing the state of a JAVA-CLASS object. Useful for diagnostics."
382 (list (java-class-name java-class)
384 (expand-java-method (ensure-java-constructor java-class)))
385 (loop for name being the hash-keys
386 of (ensure-java-method-table java-class)
387 using (hash-value method)
388 collect (cons name (expand-java-method method)))))
390 (defparameter *conversions*
391 (let ((raw '((java.lang.*object boolean)
392 (java.lang.*number double)
393 (java.lang.*comparable double)
394 (double float java.lang.*double)
395 (float long java.lang.*float)
396 (long int java.lang.*long)
397 (int short char java.lang.*integer)
398 (short byte java.lang.*short)
399 (char java.lang.*character)
400 (boolean java.lang.*boolean))))
401 (labels ((lookup (type)
402 (cdr (assoc type raw)))
406 (mapcan #'closure (lookup type))))))
407 (mapcar (lambda (row) (mapcar (lambda (name)
408 (jclass (java-name name)))
409 (closure (car row))))
411 "Table encoding the various implicit conversions for primitive types, used
412 occasionally to disambiguate multiple method matches.")
414 (defun jclass-convertible-p (from to)
415 "Return whether there is an automatic conversion between FROM and TO. This
416 can be considered a partial order on types."
417 (or (jclass-superclass-p to from)
418 (member from (assoc to *conversions* :test #'equal)
421 (defun argument-list-betterp (first second)
422 "Return whether the type-list FIRST is `better' than SECOND, in the sense
423 that there is an implicit conversion between each element of FIRST and the
424 corresponding element of SECOND. This lifts the partial order of
425 jclass-better-p to lists of types."
426 (cond ((endp first) (endp second))
428 (t (and (jclass-convertible-p (car first) (car second))
429 (argument-list-betterp (cdr first) (cdr second))))))
431 (defun get-jmethod-for-argument-types (java-method argument-types)
432 "Given a JAVA-METHOD structure, return the best match overload for the
433 given list of ARGUMENT-TYPES.
435 An overload is considered to be a match if there is an implicit conversion
436 from each actual argument type to the corresponding formal argument type.
437 One matching overload is better than another if there is an implicit
438 conversion from each of the former's argument types to the type of the
439 corresponding argument of the latter. If there is no unique best match
440 then an error is signalled.
442 In the language of the partial order defined by argument-list-betterp
443 (q.v.), which we write as <=, let us denote the actual argument types by
444 A, and the argument types of an overload O as simply O; then O is a match
445 for A if A <= O and O is a better match than O' if O <= O'; let M be the
446 set of matching overloads M = { O | A <= O }; we seek the minimum element
449 (or (gethash argument-types (java-method-cache java-method))
450 (labels ((expand-arglist (args)
451 (mapcar (lambda (arg)
452 (lisp-name (jclass-name arg)))
454 (expand-methodlist (methods)
455 (mapcar (lambda (method) (expand-arglist (cdr method)))
457 (consider (best next)
459 (format t "*** currently: ~S~%*** considering: ~S~%"
460 (expand-methodlist best)
461 (expand-arglist (cdr next)))
462 (let ((winners (remove-if
464 (argument-list-betterp (cdr next)
467 (include-next-p (every
469 (not (argument-list-betterp
476 (let* ((nargs (length argument-types))
477 (min-args (java-method-min-args java-method))
478 (max-args (java-method-max-args java-method))
480 (and (<= min-args nargs max-args)
481 (remove-if-not (lambda (method)
482 (argument-list-betterp argument-types
484 (aref (java-method-overloads java-method)
485 (- nargs min-args)))))
486 (chosen (and candidates
487 (reduce #'consider (cdr candidates)
489 (car candidates))))))
492 (format t "*** candidates = ~S~%"
493 (expand-methodlist candidates))
494 (format t "*** chosen = ~S~%"
495 (expand-methodlist chosen)))
497 (error "No match found.~% method = ~A, args = ~A"
498 (java-method-name java-method)
499 (expand-arglist argument-types)))
501 (error "Ambiguous match.~% ~
502 method = ~A, args = ~A~% ~
504 (java-method-name java-method)
505 (expand-arglist argument-types)
506 (expand-methodlist chosen)))
507 (t (setf (gethash argument-types
508 (java-method-cache java-method))
511 (defun argument-type-list-from-names (names)
512 "Given a list of type NAMES, return the corresponding Java class objects."
513 (mapcar (lambda (name)
514 (java-class-jclass (find-java-class name)))
517 (defun find-jmethod (class name arg-types)
518 "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
519 method object for the best matching overload of the method."
520 (get-jmethod-for-argument-types (find-java-method class name)
521 (argument-type-list-from-names arg-types)))
523 (defun find-jconstructor (class arg-types)
524 "Given a CLASS and a list of ARG-TYPES, return the Java constructor object
525 for the best matching constructor overload."
526 (get-jmethod-for-argument-types (find-java-constructor class)
527 (argument-type-list-from-names arg-types)))
529 (defun send (object message &rest arguments)
530 "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
531 other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best
532 matches the types of the ARGUMENTS."
533 (let ((jargs (mapcar #'make-immediate-object arguments)))
535 (find-jmethod (jobject-class object) message
536 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
540 (defun send-class (class message &rest arguments)
541 "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name
542 (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static
543 method of CLASS named by MESSAGE which best matches the types of the
545 (let ((java-class (find-java-class class))
546 (jargs (mapcar #'make-immediate-object arguments)))
548 (find-jmethod java-class message
549 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
553 (defun make (class &rest arguments)
554 "Given a CLASS (anything acceptable to find-java-class) and other
555 ARGUMENTS, invoke the constructor of CLASS which best matches the types of
556 the ARGUMENTS, returning the result."
557 (let ((java-class (find-java-class class))
558 (jargs (mapcar #'make-immediate-object arguments)))
560 (find-jconstructor java-class
561 (mapcar (lambda (jarg) (jobject-class jarg))
565 ;;;--------------------------------------------------------------------------
568 (defun field (object name)
569 "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return
570 the value of the OBJECT's field with the given NAME. This is a valid
572 (jfield (java-name name) object))
574 (defun (setf field) (value object name)
575 "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set
576 the OBJECT's field with the given NAME to be VALUE."
577 (jfield object name value))
579 (defun class-field (class name)
580 "Given a CLASS and a field NAME (Lisp symbol or Java name string), return
581 the value of the CLASS's static field with the given NAME. This is a
582 valid place for setf."
583 (jfield (jclass (java-name class)) (java-name name)))
585 (defun (setf class-field) (value class name)
586 "Given an CLASS and a field NAME (Lisp symbol or Java name string), set
587 the CLASS's static field with the given NAME to be VALUE."
588 (jfield (jclass (java-name class)) (java-name name) nil value))
590 ;;;--------------------------------------------------------------------------
593 (defun make-java-array (class items)
594 "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS,
595 return a Java array specialized for the named CLASS, containing the
597 (jnew-array-from-array (if (symbolp class) (java-name class) class)
598 (if (listp items) (coerce items 'vector) items)))
600 (defun java-array (class &rest items)
601 "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a
602 Java array specialized for the named CLASS, containing the ITEMS."
603 (make-java-array class items))
605 ;;;--------------------------------------------------------------------------
608 (defmacro implementation (class &body clauses)
609 "Returns an implementation of the interface names by CLASS (Lisp symbol or
610 Java name string), whose methods are defined by CLAUSES; each clause has
611 the form (NAME (BVL ...) FORMS...) where NAME is the name of a method
612 (Lisp symbol or Java name string), BVL is a standard bound-variable list,
613 and FORMS are any Lisp forms providing the implementation of the method."
614 `(jinterface-implementation
616 ,@(loop for (name bvl . body) in clauses
617 collect (java-name name)
618 collect `(lambda ,bvl ,@body))))
620 ;;;--------------------------------------------------------------------------
621 ;;; Other useful hacks.
623 (defmacro magic-constant-case ((selector class) &body keywords)
624 "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java
625 class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp
626 keyword objects. The SELECTOR is matched against the KEYWORDS. If a
627 match is found, the keyword is converted to upper-case, `-' is converted
628 to `_', and the result used as a Java static field name of the specified
629 CLASS; the value of this field is returned as the value of the expression.
631 Note that the class field lookups are really done at macro-expansion time,
634 ,@(mapcar (lambda (key)
635 `(,key ,(class-field class
637 (string-upcase key)))))
640 ;;;----- That's all, folks --------------------------------------------------