chiark - git - mdw - jlisp/blob - jj.lisp

   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
  27            #:java-true #:java-false #:java-null
  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
 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))
 273                         ,(java-name method)
 274                         ,@arg-types)))
 275      (defun ,lisp-name (this ,@arg-names)
 276        (jcall meth this ,@arg-names)))))
 277
 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)
 283       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))
 288                                    :jclass jclass))))))
 289
 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.
 296
 297    The indirection is because, inexplicably, one has to use different
 298    functions to extract this information from methods or constructors."
 299
 300   (let ((by-name (make-hash-table))
 301         (output (make-hash-table)))
 302
 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)
 308                      jmethod
 309                      (coerce arg-types 'list))
 310               (gethash (funcall get-name jmethod) by-name))))
 311
 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)))
 319                  (dolist (item list)
 320                    (pushnew (cdr item)
 321                             (aref overloads (- (car item) min-args))
 322                             :test #'equal
 323                             :key #'cdr))
 324                  (setf (gethash name output)
 325                        (make-java-method :min-args min-args
 326                                          :name name
 327                                          :max-args max-args
 328                                          :overloads overloads))))
 329              by-name)
 330
 331     ;; Done!
 332     output))
 333
 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))
 340                                     #'jmethod-params
 341                                     (lambda (jmethod)
 342                                       (lisp-name (jmethod-name jmethod)))))))
 343
 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))))))
 353
 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
 357    structure."
 358   (let ((java-class (find-java-class class)))
 359     (gethash (if (symbolp name) name (lisp-name name))
 360              (ensure-java-method-table java-class))))
 361
 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)))
 366
 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."
 370   (let ((out nil))
 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)))
 375                       (cdr item))
 376               out)))
 377     (nreverse out)))
 378
 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)
 383         (cons :constructors
 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)))))
 389
 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)))
 403              (closure (type)
 404                (delete-duplicates
 405                 (cons type
 406                       (mapcan #'closure (lookup type))))))
 407       (mapcar (lambda (row) (mapcar (lambda (name)
 408                                       (jclass (java-name name)))
 409                                     (closure (car row))))
 410               raw)))
 411   "Table encoding the various implicit conversions for primitive types, used
 412    occasionally to disambiguate multiple method matches.")
 413
 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)
 419               :test #'equal)))
 420
 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))
 427         ((endp second) nil)
 428         (t (and (jclass-convertible-p (car first) (car second))
 429                 (argument-list-betterp (cdr first) (cdr second))))))
 430
 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.
 434
 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.
 441
 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
 447    of M."
 448
 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)))
 453                          args))
 454                (expand-methodlist (methods)
 455                  (mapcar (lambda (method) (expand-arglist (cdr method)))
 456                          methods))
 457                (consider (best next)
 458                  #+debug
 459                  (format t "*** currently: ~S~%*** considering: ~S~%"
 460                          (expand-methodlist best)
 461                          (expand-arglist (cdr next)))
 462                  (let ((winners (remove-if
 463                                  (lambda (method)
 464                                    (argument-list-betterp (cdr next)
 465                                                           (cdr method)))
 466                                  best))
 467                        (include-next-p (every
 468                                         (lambda (method)
 469                                           (not (argument-list-betterp
 470                                                 (cdr method)
 471                                                 (cdr next))))
 472                                         best)))
 473                    (if include-next-p
 474                        (cons next winners)
 475                        winners))))
 476         (let* ((nargs (length argument-types))
 477                (min-args (java-method-min-args java-method))
 478                (max-args (java-method-max-args java-method))
 479                (candidates
 480                 (and (<= min-args nargs max-args)
 481                      (remove-if-not (lambda (method)
 482                                       (argument-list-betterp argument-types
 483                                                              (cdr method)))
 484                                     (aref (java-method-overloads java-method)
 485                                           (- nargs min-args)))))
 486                (chosen (and candidates
 487                             (reduce #'consider (cdr candidates)
 488                                     :initial-value (list
 489                                                     (car candidates))))))
 490           #+debug
 491           (progn
 492             (format t "*** candidates = ~S~%"
 493                     (expand-methodlist candidates))
 494             (format t "*** chosen = ~S~%"
 495                     (expand-methodlist chosen)))
 496           (cond ((null chosen)
 497                  (error "No match found.~%  method = ~A, args = ~A"
 498                         (java-method-name java-method)
 499                         (expand-arglist argument-types)))
 500                 ((cdr chosen)
 501                  (error "Ambiguous match.~%  ~
 502                            method = ~A, args = ~A~%  ~
 503                            matches = ~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))
 509                          (caar chosen))))))))
 510
 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)))
 515           names))
 516
 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)))
 522
 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)))
 528
 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)))
 534     (apply #'jcall
 535            (find-jmethod (jobject-class object) message
 536                          (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
 537            object
 538            jargs)))
 539
 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
 544    ARGUMENTS."
 545   (let ((java-class (find-java-class class))
 546         (jargs (mapcar #'make-immediate-object arguments)))
 547     (apply #'jcall
 548            (find-jmethod java-class message
 549                          (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
 550            java-null
 551            jargs)))
 552
 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)))
 559     (apply #'jnew
 560            (find-jconstructor java-class
 561                               (mapcar (lambda (jarg) (jobject-class jarg))
 562                                       jargs))
 563            jargs)))
 564
 565 ;;;--------------------------------------------------------------------------
 566 ;;; Field access.
 567
 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
 571    place for setf."
 572   (jfield (java-name name) object))
 573
 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))
 578
 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)))
 584
 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))
 589
 590 ;;;--------------------------------------------------------------------------
 591 ;;; Arrays.
 592
 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
 596    ITEMS."
 597   (jnew-array-from-array (if (symbolp class) (java-name class) class)
 598                          (if (listp items) (coerce items 'vector) items)))
 599
 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))
 604
 605 ;;;--------------------------------------------------------------------------
 606 ;;; Interfaces.
 607
 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
 615     ,(java-name class)
 616     ,@(loop for (name bvl . body) in clauses
 617             collect (java-name name)
 618             collect `(lambda ,bvl ,@body))))
 619
 620 ;;;--------------------------------------------------------------------------
 621 ;;; Other useful hacks.
 622
 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.
 630
 631    Note that the class field lookups are really done at macro-expansion time,
 632    not at run-time."
 633   `(ecase ,selector
 634      ,@(mapcar (lambda (key)
 635                  `(,key ,(class-field class
 636                                       (substitute #\_ #\-
 637                                                   (string-upcase key)))))
 638                keywords)))
 639
 640 ;;;----- That's all, folks --------------------------------------------------