+;;; -*-lisp-*-
+;;;
+;;; Pleasant Lisp interface to Java class libraries
+;;;
+;;; (c) 2007 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:jj
+ (:use #:common-lisp #:java)
+ (:export #:java-name #:lisp-name
+ #:java-true #:java-false #:java-null
+ #:send #:send-class #:make #:make-java-array #:java-array
+ #:field #:class-field
+ #:magic-constant-case
+ #:implementation))
+
+(in-package #:jj)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defmacro with-string-iterator ((iterator
+ string
+ &key
+ (character (gensym "CHAR"))
+ (index (gensym "INDEX"))
+ (start 0)
+ (end nil))
+ &body body)
+ "Evaluate BODY with ITERATOR fbound to a function which returns successive
+ characters from the substring of STRING indicated by START and END. The
+ variables named by INDEX and CHARACTER are bound to the current index
+ within STRING and the current character; they are modified by assignment
+ by the ITERATOR function. The ITERATOR takes one (optional) argument
+ EOSP: if false (the default), ITERATOR signals an error if it reads past
+ the end of the indicated substring; if true, it returns nil at
+ end-of-string."
+ (let ((tstring (gensym "STRING"))
+ (tend (gensym "END")))
+ `(let* ((,tstring ,string)
+ (,index ,start)
+ (,tend (or ,end (length ,tstring)))
+ (,character nil))
+ (flet ((,iterator (&optional eosp)
+ (cond ((< ,index ,tend)
+ (setf ,character (char ,tstring ,index))
+ (incf ,index)
+ ,character)
+ (eosp nil)
+ (t (error "Unexpected end-of-string.")))))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Name conversion.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defun java-name (name)
+ "Returns the Java-name for NAME, as a string. If NAME is a string, it is
+ returned as-is. If NAME is a symbol, its print-name is converted
+ according to these rules. The name is split into components separated
+ by `.' characters; the components are converted independently, and
+ joined, again using `.'s.
+
+ * The final component is treated specially: if the first and last
+ characters are both `*' then the `*'s are stripped off, all `-'s are
+ replaced by `_'s, and other characters are emitted as-is.
+
+ * If the first character of a component is `*' then the `*' is
+ stripped and the following character is converted to upper-case.
+
+ * A double `-' is replaced by an underscore `_'.
+
+ * A single `-' is stripped and the following character converted to
+ upper-case.
+
+ * Other characters are converted to lower-case.
+
+ These are the inverse of the rules for lisp-name (q.v.).
+
+ Examples:
+
+ Lisp name Java name
+
+ FOO foo
+ JAVA.AWT.*GRID-BAG-CONSTRAINTS java.awt.GridBagConstraints
+ *HORIZONTAL-SPLIT* HORIZONTAL_SPLIT"
+
+ (etypecase name
+ (string name)
+ (symbol
+ (let* ((name (symbol-name name))
+ (n (length name)))
+ (with-output-to-string (out)
+ (with-string-iterator (getch name :character ch :index i :end n)
+ (tagbody
+ top
+ (getch)
+ (case ch
+ (#\- (go upnext))
+ (#\* (cond ((and (char= #\* (char name (1- n)))
+ (every (lambda (ch)
+ (or (char= #\- ch)
+ (alphanumericp ch)))
+ (subseq name i (1- n))))
+ (map nil
+ (lambda (ch)
+ (write-char (if (char= #\- ch) #\_ ch)
+ out))
+ (subseq name i (1- n)))
+ (go done))
+ (t
+ (go upnext))))
+ (t (go main)))
+ main
+ (unless (alphanumericp ch)
+ (error "Bad character in name."))
+ (write-char (char-downcase ch) out)
+ next
+ (unless (getch t) (go done))
+ (case ch
+ (#\- (go upnext))
+ (#\. (write-char #\. out) (go top))
+ (t (go main)))
+ upnext
+ (getch)
+ (cond ((char= ch #\-) (write-char #\_ out))
+ ((alphanumericp ch) (write-char (char-upcase ch) out))
+ (t (error "Bad character in name.")))
+ (go next)
+ done)))))))
+
+ (defun lisp-name (name &optional (package :keyword))
+ "Returns the Lisp-name for NAME, as a symbol interned in the given
+ PACKAGE (defaults to keyword). The name is split into components
+ separated by `.' characters, converted independently, and joined again
+ using `.'s.
+
+ * The final component is treated specially. If it consists entirely
+ of `_', digits and upper-case letters, it is converted by replacing
+ the `_'s by `-'s, and adding a `*' to the beginning and end.
+
+ * If the first character of a component is upper-case, an `*' is
+ prepended. Other upper-case characters are preceded by `-'s.
+
+ * Any `_' characters are replaced by `--'.
+
+ * All letters are converted to upper-case.
+
+ These are the inverse of the rules for java-name (q.v.)."
+
+ (let ((n (length name)))
+ (intern (with-output-to-string (out)
+ (with-string-iterator
+ (getch name :character ch :index i :end n)
+ (tagbody
+ top
+ (getch)
+ (when (upper-case-p ch)
+ (write-char #\* out)
+ (let ((mid (make-array (- n i -1)
+ :element-type
+ (array-element-type name)
+ :displaced-to name
+ :displaced-index-offset
+ (1- i))))
+ (when (every (lambda (ch)
+ (or (char= #\_ ch)
+ (digit-char-p ch)
+ (upper-case-p ch)))
+ mid)
+ (map nil
+ (lambda (ch)
+ (write-char (if (char= #\_ ch) #\- ch)
+ out))
+ mid)
+ (write-char #\* out)
+ (go done))))
+ main
+ (write-char (char-upcase ch) out)
+ next
+ (unless (getch t) (go done))
+ (cond ((char= #\_ ch)
+ (write-string "--" out)
+ (go next))
+ ((char= #\. ch)
+ (write-char #\. out)
+ (go top))
+ ((upper-case-p ch)
+ (write-char #\- out)))
+ (go main)
+ done)))
+ package))))
+
+;;;--------------------------------------------------------------------------
+;;; Dynamic method dispatch.
+
+(defparameter *class-table* (make-hash-table :test #'equal)
+ "A hash table mapping Java class names (as strings, using their Java names)
+ to java-class structures. ")
+
+(defstruct java-method
+ "Structure describing a Java method or constructor. The slots are as
+ follows.
+
+ * cache -- hash table mapping a list of argument types (as Java class
+ objects) to appropriate method. This table is populated as we go.
+
+ * name -- Lisp symbol naming the method; :constructor for constructors.
+
+ * min-args -- smallest number of arguments acceptable to the method.
+
+ * max-args -- largest number of arguments acceptable.
+
+ * overloads -- vector, indexed by (- nargs min-args), of (jmethod .
+ argument-types) pairs."
+
+ (cache (make-hash-table :test #'equal) :type hash-table)
+ (name nil :type symbol)
+ (min-args 0 :type fixnum)
+ (max-args 0 :type fixnum)
+ (overloads nil :type vector))
+
+(defstruct java-class
+ "Structure describing a Java class. The slots are as follows.
+
+ * name -- Lisp symbol naming the class.
+
+ * jclass -- the Java class object.
+
+ * methods -- hash table mapping Lisp method names to java-method
+ structures.
+
+ * constructor -- java-method structure describing the available
+ constructors."
+
+ (name nil :type symbol)
+ (jclass nil :type java-object)
+ (methods nil :type (or hash-table null))
+ (constructor nil :type (or java-method null)))
+
+(defconstant java-true (make-immediate-object t :boolean)
+ "The Java `true' object.")
+(defconstant java-false (make-immediate-object nil :boolean)
+ "The Java `false' object.")
+(defconstant java-null (make-immediate-object nil :ref)
+ "A Java null reference.")
+
+(defmacro define-java-method (lisp-name class method &body args)
+ "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
+ given arguments. The CLASS may be a string or symbol (it is converted by
+ java-name). The ARGS are (NAME TYPE) lists, where each TYPE is a string
+ or symbol naming a Java class."
+ (let ((arg-names (mapcar #'car args))
+ (arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args)))
+ `(let ((meth (jmethod (jclass ,(java-name class))
+ ,(java-name method)
+ ,@arg-types)))
+ (defun ,lisp-name (this ,@arg-names)
+ (jcall meth this ,@arg-names)))))
+
+(defun find-java-class (class)
+ "Return the java-class structure for the given CLASS, which may be a
+ java-class structure, a Java class object (note the difference!), a string
+ naming a Java class, or a symbol giving the name in Lisp form."
+ (if (java-class-p class)
+ class
+ (let ((jclass (jclass (if (symbolp class) (java-name class) class))))
+ (or (gethash jclass *class-table*)
+ (setf (gethash jclass *class-table*)
+ (make-java-class :name (lisp-name (jclass-name jclass))
+ :jclass jclass))))))
+
+(defun construct-method-table (methods get-params get-name)
+ "Constructs the method table (as a hash-table) for a java-class object.
+ The METHODS are a vector of method (or constructor) objects; GET-PARAMS is
+ a function which is given a method object and returns a sequence of
+ argument type objects; and GET-NAME is a function which is given a method
+ object and returns the method's name, as a Lisp symbol.
+
+ The indirection is because, inexplicably, one has to use different
+ functions to extract this information from methods or constructors."
+
+ (let ((by-name (make-hash-table))
+ (output (make-hash-table)))
+
+ ;; First pass: break the list up by name.
+ (dotimes (i (length methods))
+ (let* ((jmethod (aref methods i))
+ (arg-types (funcall get-params jmethod)))
+ (push (list* (length arg-types)
+ jmethod
+ (coerce arg-types 'list))
+ (gethash (funcall get-name jmethod) by-name))))
+
+ ;; Second pass: sift each name bucket by numbers of arguments.
+ (maphash (lambda (name list)
+ (let* ((arg-lengths (mapcar #'car list))
+ (min-args (apply #'min arg-lengths))
+ (max-args (apply #'max arg-lengths))
+ (overloads (make-array (- max-args min-args -1)
+ :initial-element nil)))
+ (dolist (item list)
+ (pushnew (cdr item)
+ (aref overloads (- (car item) min-args))
+ :test #'equal
+ :key #'cdr))
+ (setf (gethash name output)
+ (make-java-method :min-args min-args
+ :name name
+ :max-args max-args
+ :overloads overloads))))
+ by-name)
+
+ ;; Done!
+ output))
+
+(defun ensure-java-method-table (java-class)
+ "Ensure that JAVA-CLASS has a method table, and return it."
+ (or (java-class-methods java-class)
+ (setf (java-class-methods java-class)
+ (construct-method-table (jclass-methods
+ (java-class-jclass java-class))
+ #'jmethod-params
+ (lambda (jmethod)
+ (lisp-name (jmethod-name jmethod)))))))
+
+(defun ensure-java-constructor (java-class)
+ "Ensure that JAVA-CLASS has a constructor object, and return it."
+ (or (java-class-constructor java-class)
+ (setf (java-class-constructor java-class)
+ (gethash :constructor
+ (construct-method-table (jclass-constructors
+ (java-class-jclass java-class))
+ #'jconstructor-params
+ (constantly :constructor))))))
+
+(defun find-java-method (class name)
+ "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp
+ symbol or Java name string), return the corresponding java-method
+ structure."
+ (let ((java-class (find-java-class class)))
+ (gethash (if (symbolp name) name (lisp-name name))
+ (ensure-java-method-table java-class))))
+
+(defun find-java-constructor (class)
+ "Given a CLASS (in a form acceptable to find-java-class), return the
+ java-method structure for its constructor."
+ (ensure-java-constructor (find-java-class class)))
+
+(defun expand-java-method (java-method)
+ "Return a list-of-lists: for each overload of the method, return a list of
+ its argument types, in ascending order of number of arguments."
+ (let ((out nil))
+ (dotimes (i (length (java-method-overloads java-method)))
+ (dolist (item (cdr (aref (java-method-overloads java-method) i)))
+ (push (mapcar (lambda (arg)
+ (lisp-name (jclass-name arg)))
+ (cdr item))
+ out)))
+ (nreverse out)))
+
+(defun expand-java-class (java-class)
+ "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...))
+ describing the state of a JAVA-CLASS object. Useful for diagnostics."
+ (list (java-class-name java-class)
+ (cons :constructors
+ (expand-java-method (ensure-java-constructor java-class)))
+ (loop for name being the hash-keys
+ of (ensure-java-method-table java-class)
+ using (hash-value method)
+ collect (cons name (expand-java-method method)))))
+
+(defparameter *conversions*
+ (let ((raw '((java.lang.*object boolean)
+ (java.lang.*number double)
+ (java.lang.*comparable double)
+ (double float java.lang.*double)
+ (float long java.lang.*float)
+ (long int java.lang.*long)
+ (int short char java.lang.*integer)
+ (short byte java.lang.*short)
+ (char java.lang.*character)
+ (boolean java.lang.*boolean))))
+ (labels ((lookup (type)
+ (cdr (assoc type raw)))
+ (closure (type)
+ (delete-duplicates
+ (cons type
+ (mapcan #'closure (lookup type))))))
+ (mapcar (lambda (row) (mapcar (lambda (name)
+ (jclass (java-name name)))
+ (closure (car row))))
+ raw)))
+ "Table encoding the various implicit conversions for primitive types, used
+ occasionally to disambiguate multiple method matches.")
+
+(defun jclass-convertible-p (from to)
+ "Return whether there is an automatic conversion between FROM and TO. This
+ can be considered a partial order on types."
+ (or (jclass-superclass-p to from)
+ (member from (assoc to *conversions* :test #'equal)
+ :test #'equal)))
+
+(defun argument-list-betterp (first second)
+ "Return whether the type-list FIRST is `better' than SECOND, in the sense
+ that there is an implicit conversion between each element of FIRST and the
+ corresponding element of SECOND. This lifts the partial order of
+ jclass-better-p to lists of types."
+ (cond ((endp first) (endp second))
+ ((endp second) nil)
+ (t (and (jclass-convertible-p (car first) (car second))
+ (argument-list-betterp (cdr first) (cdr second))))))
+
+(defun get-jmethod-for-argument-types (java-method argument-types)
+ "Given a JAVA-METHOD structure, return the best match overload for the
+ given list of ARGUMENT-TYPES.
+
+ An overload is considered to be a match if there is an implicit conversion
+ from each actual argument type to the corresponding formal argument type.
+ One matching overload is better than another if there is an implicit
+ conversion from each of the former's argument types to the type of the
+ corresponding argument of the latter. If there is no unique best match
+ then an error is signalled.
+
+ In the language of the partial order defined by argument-list-betterp
+ (q.v.), which we write as <=, let us denote the actual argument types by
+ A, and the argument types of an overload O as simply O; then O is a match
+ for A if A <= O and O is a better match than O' if O <= O'; let M be the
+ set of matching overloads M = { O | A <= O }; we seek the minimum element
+ of M."
+
+ (or (gethash argument-types (java-method-cache java-method))
+ (labels ((expand-arglist (args)
+ (mapcar (lambda (arg)
+ (lisp-name (jclass-name arg)))
+ args))
+ (expand-methodlist (methods)
+ (mapcar (lambda (method) (expand-arglist (cdr method)))
+ methods))
+ (consider (best next)
+ #+debug
+ (format t "*** currently: ~S~%*** considering: ~S~%"
+ (expand-methodlist best)
+ (expand-arglist (cdr next)))
+ (let ((winners (remove-if
+ (lambda (method)
+ (argument-list-betterp (cdr next)
+ (cdr method)))
+ best))
+ (include-next-p (every
+ (lambda (method)
+ (not (argument-list-betterp
+ (cdr method)
+ (cdr next))))
+ best)))
+ (if include-next-p
+ (cons next winners)
+ winners))))
+ (let* ((nargs (length argument-types))
+ (min-args (java-method-min-args java-method))
+ (max-args (java-method-max-args java-method))
+ (candidates
+ (and (<= min-args nargs max-args)
+ (remove-if-not (lambda (method)
+ (argument-list-betterp argument-types
+ (cdr method)))
+ (aref (java-method-overloads java-method)
+ (- nargs min-args)))))
+ (chosen (and candidates
+ (reduce #'consider (cdr candidates)
+ :initial-value (list
+ (car candidates))))))
+ #+debug
+ (progn
+ (format t "*** candidates = ~S~%"
+ (expand-methodlist candidates))
+ (format t "*** chosen = ~S~%"
+ (expand-methodlist chosen)))
+ (cond ((null chosen)
+ (error "No match found.~% method = ~A, args = ~A"
+ (java-method-name java-method)
+ (expand-arglist argument-types)))
+ ((cdr chosen)
+ (error "Ambiguous match.~% ~
+ method = ~A, args = ~A~% ~
+ matches = ~A"
+ (java-method-name java-method)
+ (expand-arglist argument-types)
+ (expand-methodlist chosen)))
+ (t (setf (gethash argument-types
+ (java-method-cache java-method))
+ (caar chosen))))))))
+
+(defun argument-type-list-from-names (names)
+ "Given a list of type NAMES, return the corresponding Java class objects."
+ (mapcar (lambda (name)
+ (java-class-jclass (find-java-class name)))
+ names))
+
+(defun find-jmethod (class name arg-types)
+ "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
+ method object for the best matching overload of the method."
+ (get-jmethod-for-argument-types (find-java-method class name)
+ (argument-type-list-from-names arg-types)))
+
+(defun find-jconstructor (class arg-types)
+ "Given a CLASS and a list of ARG-TYPES, return the Java constructor object
+ for the best matching constructor overload."
+ (get-jmethod-for-argument-types (find-java-constructor class)
+ (argument-type-list-from-names arg-types)))
+
+(defun send (object message &rest arguments)
+ "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
+ other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best
+ matches the types of the ARGUMENTS."
+ (let ((jargs (mapcar #'make-immediate-object arguments)))
+ (apply #'jcall
+ (find-jmethod (jobject-class object) message
+ (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
+ object
+ jargs)))
+
+(defun send-class (class message &rest arguments)
+ "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name
+ (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static
+ method of CLASS named by MESSAGE which best matches the types of the
+ ARGUMENTS."
+ (let ((java-class (find-java-class class))
+ (jargs (mapcar #'make-immediate-object arguments)))
+ (apply #'jcall
+ (find-jmethod java-class message
+ (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
+ java-null
+ jargs)))
+
+(defun make (class &rest arguments)
+ "Given a CLASS (anything acceptable to find-java-class) and other
+ ARGUMENTS, invoke the constructor of CLASS which best matches the types of
+ the ARGUMENTS, returning the result."
+ (let ((java-class (find-java-class class))
+ (jargs (mapcar #'make-immediate-object arguments)))
+ (apply #'jnew
+ (find-jconstructor java-class
+ (mapcar (lambda (jarg) (jobject-class jarg))
+ jargs))
+ jargs)))
+
+;;;--------------------------------------------------------------------------
+;;; Field access.
+
+(defun field (object name)
+ "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return
+ the value of the OBJECT's field with the given NAME. This is a valid
+ place for setf."
+ (jfield (java-name name) object))
+
+(defun (setf field) (value object name)
+ "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set
+ the OBJECT's field with the given NAME to be VALUE."
+ (jfield object name value))
+
+(defun class-field (class name)
+ "Given a CLASS and a field NAME (Lisp symbol or Java name string), return
+ the value of the CLASS's static field with the given NAME. This is a
+ valid place for setf."
+ (jfield (jclass (java-name class)) (java-name name)))
+
+(defun (setf class-field) (value class name)
+ "Given an CLASS and a field NAME (Lisp symbol or Java name string), set
+ the CLASS's static field with the given NAME to be VALUE."
+ (jfield (jclass (java-name class)) (java-name name) nil value))
+
+;;;--------------------------------------------------------------------------
+;;; Arrays.
+
+(defun make-java-array (class items)
+ "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS,
+ return a Java array specialized for the named CLASS, containing the
+ ITEMS."
+ (jnew-array-from-array (if (symbolp class) (java-name class) class)
+ (if (listp items) (coerce items 'vector) items)))
+
+(defun java-array (class &rest items)
+ "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a
+ Java array specialized for the named CLASS, containing the ITEMS."
+ (make-java-array class items))
+
+;;;--------------------------------------------------------------------------
+;;; Interfaces.
+
+(defmacro implementation (class &body clauses)
+ "Returns an implementation of the interface names by CLASS (Lisp symbol or
+ Java name string), whose methods are defined by CLAUSES; each clause has
+ the form (NAME (BVL ...) FORMS...) where NAME is the name of a method
+ (Lisp symbol or Java name string), BVL is a standard bound-variable list,
+ and FORMS are any Lisp forms providing the implementation of the method."
+ `(jinterface-implementation
+ ,(java-name class)
+ ,@(loop for (name bvl . body) in clauses
+ collect (java-name name)
+ collect `(lambda ,bvl ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Other useful hacks.
+
+(defmacro magic-constant-case ((selector class) &body keywords)
+ "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java
+ class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp
+ keyword objects. The SELECTOR is matched against the KEYWORDS. If a
+ match is found, the keyword is converted to upper-case, `-' is converted
+ to `_', and the result used as a Java static field name of the specified
+ CLASS; the value of this field is returned as the value of the expression.
+
+ Note that the class field lookups are really done at macro-expansion time,
+ not at run-time."
+ `(ecase ,selector
+ ,@(mapcar (lambda (key)
+ `(,key ,(class-field class
+ (substitute #\_ #\-
+ (string-upcase key)))))
+ keywords)))
+
+;;;----- That's all, folks --------------------------------------------------