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 #:jboolean
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 (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))
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))
279 (defun ,lisp-name (this ,@arg-names)
280 (jcall meth this ,@arg-names)))))
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)
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))
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.
301 The indirection is because, inexplicably, one has to use different
302 functions to extract this information from methods or constructors."
304 (let ((by-name (make-hash-table))
305 (output (make-hash-table)))
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)
313 (coerce arg-types 'list))
314 (gethash (funcall get-name jmethod) by-name))))
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)))
325 (aref overloads (- (car item) min-args))
328 (setf (gethash name output)
329 (make-java-method :min-args min-args
332 :overloads overloads))))
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))
346 (lisp-name (jmethod-name jmethod)))))))
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))))))
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
362 (let ((java-class (find-java-class class)))
363 (gethash (if (symbolp name) name (lisp-name name))
364 (ensure-java-method-table java-class))))
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)))
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."
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)))
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)
388 (expand-java-method (ensure-java-constructor java-class)))
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))))))
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)))
411 (mapcan #'closure (lookup type))))))
412 (mapcar (lambda (row) (mapcar (lambda (name)
413 (jclass (java-name name)))
414 (closure (car row))))
416 "Table encoding the various implicit conversions for primitive types, used
417 occasionally to disambiguate multiple method matches.")
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."
423 (jclass-superclass-p to from)
424 (member from (assoc to *conversions* :test #'equal)
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))
434 (t (and (jclass-convertible-p (car first) (car second))
435 (argument-list-betterp (cdr first) (cdr second))))))
437 (defun get-jmethod-for-argument-types (java-class java-method argument-types)
438 "Given a JAVA-METHOD structure, return the best match overload for the
439 given list of ARGUMENT-TYPES.
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.
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
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)))
460 (expand-methodlist (methods)
461 (mapcar (lambda (method) (expand-arglist (cdr method)))
463 (consider (best next)
465 (format t "*** currently: ~S~%*** considering: ~S~%"
466 (expand-methodlist best)
467 (expand-arglist (cdr next)))
468 (let ((winners (remove-if
470 (argument-list-betterp (cdr next)
473 (include-next-p (every
475 (not (argument-list-betterp
482 (let* ((nargs (length argument-types))
483 (min-args (java-method-min-args java-method))
484 (max-args (java-method-max-args java-method))
486 (and (<= min-args nargs max-args)
487 (remove-if-not (lambda (method)
488 (argument-list-betterp argument-types
490 (aref (java-method-overloads java-method)
491 (- nargs min-args)))))
492 (chosen (and candidates
493 (reduce #'consider (cdr candidates)
495 (car candidates))))))
498 (format t "*** candidates = ~S~%"
499 (expand-methodlist candidates))
500 (format t "*** chosen = ~S~%"
501 (expand-methodlist chosen)))
503 (error "No match found.~% ~
504 class = ~A, method = ~A~% ~
506 (java-class-name java-class)
507 (java-method-name java-method)
508 (expand-arglist argument-types)))
510 (error "Ambiguous match.~% ~
511 method = ~A, args = ~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))
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)))
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."
529 (let ((java-class (find-java-class class)))
530 (get-jmethod-for-argument-types
532 (find-java-method java-class name)
533 (argument-type-list-from-names arg-types))))
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."
538 (let ((java-class (find-java-class class)))
539 (get-jmethod-for-argument-types
541 (find-java-constructor java-class)
542 (argument-type-list-from-names arg-types))))
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)))
550 (find-jmethod (jobject-class object) message
551 (mapcar (lambda (jarg)
552 (if (equal jarg java-null)
554 (jobject-class jarg)))
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
564 (let ((java-class (find-java-class class))
565 (jargs (mapcar #'make-immediate-object arguments)))
567 (find-jmethod java-class message
568 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
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)))
579 (find-jconstructor java-class
580 (mapcar (lambda (jarg) (jobject-class jarg))
584 ;;;--------------------------------------------------------------------------
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
591 (jfield (java-name name) object))
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))
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)))
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))
609 ;;;--------------------------------------------------------------------------
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
616 (jnew-array-from-array (if (symbolp class) (java-name class) class)
617 (if (listp items) (coerce items 'vector) items)))
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))
624 ;;;--------------------------------------------------------------------------
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
635 ,@(loop for (name bvl . body) in clauses
636 collect (java-name name)
637 collect `(lambda ,bvl ,@body))))
639 ;;;--------------------------------------------------------------------------
640 ;;; Other useful hacks.
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.
650 Note that the class field lookups are really done at macro-expansion time,
653 ,@(mapcar (lambda (key)
654 `(,key ,(class-field class
656 (string-upcase key)))))
659 ;;;----- That's all, folks --------------------------------------------------