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 #:jboolean
  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 (defun jboolean (thing)
 266   "Return JAVA-TRUE if THING is non-nil, JAVA-FALSE if THING is nil."
 267   (if thing java-true java-false))
 268
 269 (defmacro define-java-method (lisp-name class method &body args)
 270   "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
 271    given arguments.  The CLASS may be a string or symbol (it is converted by
 272    java-name).  The ARGS are (NAME TYPE) lists, where each TYPE is a string
 273    or symbol naming a Java class."
 274   (let ((arg-names (mapcar #'car args))
 275         (arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args)))
 276   `(let ((meth (jmethod (jclass ,(java-name class))
 277                         ,(java-name method)
 278                         ,@arg-types)))
 279      (defun ,lisp-name (this ,@arg-names)
 280        (jcall meth this ,@arg-names)))))
 281
 282 (defun find-java-class (class)
 283   "Return the java-class structure for the given CLASS, which may be a
 284    java-class structure, a Java class object (note the difference!), a string
 285    naming a Java class, or a symbol giving the name in Lisp form."
 286   (if (java-class-p class)
 287       class
 288       (let ((jclass (jclass (if (symbolp class) (java-name class) class))))
 289         (or (gethash jclass *class-table*)
 290             (setf (gethash jclass *class-table*)
 291                   (make-java-class :name (lisp-name (jclass-name jclass))
 292                                    :jclass jclass))))))
 293
 294 (defun construct-method-table (methods get-params get-name)
 295   "Constructs the method table (as a hash-table) for a java-class object.
 296    The METHODS are a vector of method (or constructor) objects; GET-PARAMS is
 297    a function which is given a method object and returns a sequence of
 298    argument type objects; and GET-NAME is a function which is given a method
 299    object and returns the method's name, as a Lisp symbol.
 300
 301    The indirection is because, inexplicably, one has to use different
 302    functions to extract this information from methods or constructors."
 303
 304   (let ((by-name (make-hash-table))
 305         (output (make-hash-table)))
 306
 307     ;; First pass: break the list up by name.
 308     (dotimes (i (length methods))
 309       (let* ((jmethod (aref methods i))
 310              (arg-types (funcall get-params jmethod)))
 311         (push (list* (length arg-types)
 312                      jmethod
 313                      (coerce arg-types 'list))
 314               (gethash (funcall get-name jmethod) by-name))))
 315
 316     ;; Second pass: sift each name bucket by numbers of arguments.
 317     (maphash (lambda (name list)
 318                (let* ((arg-lengths (mapcar #'car list))
 319                       (min-args (apply #'min arg-lengths))
 320                       (max-args (apply #'max arg-lengths))
 321                       (overloads (make-array (- max-args min-args -1)
 322                                              :initial-element nil)))
 323                  (dolist (item list)
 324                    (pushnew (cdr item)
 325                             (aref overloads (- (car item) min-args))
 326                             :test #'equal
 327                             :key #'cdr))
 328                  (setf (gethash name output)
 329                        (make-java-method :min-args min-args
 330                                          :name name
 331                                          :max-args max-args
 332                                          :overloads overloads))))
 333              by-name)
 334
 335     ;; Done!
 336     output))
 337
 338 (defun ensure-java-method-table (java-class)
 339   "Ensure that JAVA-CLASS has a method table, and return it."
 340   (or (java-class-methods java-class)
 341       (setf (java-class-methods java-class)
 342             (construct-method-table (jclass-methods
 343                                      (java-class-jclass java-class))
 344                                     #'jmethod-params
 345                                     (lambda (jmethod)
 346                                       (lisp-name (jmethod-name jmethod)))))))
 347
 348 (defun ensure-java-constructor (java-class)
 349   "Ensure that JAVA-CLASS has a constructor object, and return it."
 350   (or (java-class-constructor java-class)
 351       (setf (java-class-constructor java-class)
 352             (gethash :constructor
 353                      (construct-method-table (jclass-constructors
 354                                               (java-class-jclass java-class))
 355                                              #'jconstructor-params
 356                                              (constantly :constructor))))))
 357
 358 (defun find-java-method (class name)
 359   "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp
 360    symbol or Java name string), return the corresponding java-method
 361    structure."
 362   (let ((java-class (find-java-class class)))
 363     (gethash (if (symbolp name) name (lisp-name name))
 364              (ensure-java-method-table java-class))))
 365
 366 (defun find-java-constructor (class)
 367   "Given a CLASS (in a form acceptable to find-java-class), return the
 368    java-method structure for its constructor."
 369   (ensure-java-constructor (find-java-class class)))
 370
 371 (defun expand-java-method (java-method)
 372   "Return a list-of-lists: for each overload of the method, return a list of
 373    its argument types, in ascending order of number of arguments."
 374   (let ((out nil))
 375     (dotimes (i (length (java-method-overloads java-method)))
 376       (dolist (item (cdr (aref (java-method-overloads java-method) i)))
 377         (push (mapcar (lambda (arg)
 378                         (lisp-name (jclass-name arg)))
 379                       (cdr item))
 380               out)))
 381     (nreverse out)))
 382
 383 (defun expand-java-class (java-class)
 384   "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...))
 385    describing the state of a JAVA-CLASS object.  Useful for diagnostics."
 386   (list (java-class-name java-class)
 387         (cons :constructors
 388               (expand-java-method (ensure-java-constructor java-class)))
 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))))))
 394
 395 (defparameter *conversions*
 396   (let ((raw '((java.lang.*object boolean)
 397                (java.lang.*number double)
 398                (java.lang.*comparable double)
 399                (double float java.lang.*double)
 400                (float long java.lang.*float)
 401                (long int java.lang.*long)
 402                (int short char java.lang.*integer)
 403                (short byte java.lang.*short)
 404                (char java.lang.*character)
 405                (boolean java.lang.*boolean))))
 406     (labels ((lookup (type)
 407                (cdr (assoc type raw)))
 408              (closure (type)
 409                (delete-duplicates
 410                 (cons type
 411                       (mapcan #'closure (lookup type))))))
 412       (mapcar (lambda (row) (mapcar (lambda (name)
 413                                       (jclass (java-name name)))
 414                                     (closure (car row))))
 415               raw)))
 416   "Table encoding the various implicit conversions for primitive types, used
 417    occasionally to disambiguate multiple method matches.")
 418
 419 (defun jclass-convertible-p (from to)
 420   "Return whether there is an automatic conversion between FROM and TO.  This
 421    can be considered a partial order on types."
 422   (or (null from)
 423       (jclass-superclass-p to from)
 424       (member from (assoc to *conversions* :test #'equal)
 425               :test #'equal)))
 426
 427 (defun argument-list-betterp (first second)
 428   "Return whether the type-list FIRST is `better' than SECOND, in the sense
 429    that there is an implicit conversion between each element of FIRST and the
 430    corresponding element of SECOND.  This lifts the partial order of
 431    jclass-better-p to lists of types."
 432   (cond ((endp first) (endp second))
 433         ((endp second) nil)
 434         (t (and (jclass-convertible-p (car first) (car second))
 435                 (argument-list-betterp (cdr first) (cdr second))))))
 436
 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.
 440
 441    An overload is considered to be a match if there is an implicit conversion
 442    from each actual argument type to the corresponding formal argument type.
 443    One matching overload is better than another if there is an implicit
 444    conversion from each of the former's argument types to the type of the
 445    corresponding argument of the latter.  If there is no unique best match
 446    then an error is signalled.
 447
 448    In the language of the partial order defined by argument-list-betterp
 449    (q.v.), which we write as <=, let us denote the actual argument types by
 450    A, and the argument types of an overload O as simply O; then O is a match
 451    for A if A <= O and O is a better match than O' if O <= O'; let M be the
 452    set of matching overloads M = { O | A <= O }; we seek the minimum element
 453    of M."
 454
 455   (or (gethash argument-types (java-method-cache java-method))
 456       (labels ((expand-arglist (args)
 457                  (mapcar (lambda (arg)
 458                            (lisp-name (jclass-name arg)))
 459                          args))
 460                (expand-methodlist (methods)
 461                  (mapcar (lambda (method) (expand-arglist (cdr method)))
 462                          methods))
 463                (consider (best next)
 464                  #+debug
 465                  (format t "*** currently: ~S~%*** considering: ~S~%"
 466                          (expand-methodlist best)
 467                          (expand-arglist (cdr next)))
 468                  (let ((winners (remove-if
 469                                  (lambda (method)
 470                                    (argument-list-betterp (cdr next)
 471                                                           (cdr method)))
 472                                  best))
 473                        (include-next-p (every
 474                                         (lambda (method)
 475                                           (not (argument-list-betterp
 476                                                 (cdr method)
 477                                                 (cdr next))))
 478                                         best)))
 479                    (if include-next-p
 480                        (cons next winners)
 481                        winners))))
 482         (let* ((nargs (length argument-types))
 483                (min-args (java-method-min-args java-method))
 484                (max-args (java-method-max-args java-method))
 485                (candidates
 486                 (and (<= min-args nargs max-args)
 487                      (remove-if-not (lambda (method)
 488                                       (argument-list-betterp argument-types
 489                                                              (cdr method)))
 490                                     (aref (java-method-overloads java-method)
 491                                           (- nargs min-args)))))
 492                (chosen (and candidates
 493                             (reduce #'consider (cdr candidates)
 494                                     :initial-value (list
 495                                                     (car candidates))))))
 496           #+debug
 497           (progn
 498             (format t "*** candidates = ~S~%"
 499                     (expand-methodlist candidates))
 500             (format t "*** chosen = ~S~%"
 501                     (expand-methodlist chosen)))
 502           (cond ((null chosen)
 503                  (error "No match found.~%  ~
 504                          class = ~A, method = ~A~%  ~
 505                          args = ~A"
 506                         (java-class-name java-class)
 507                         (java-method-name java-method)
 508                         (expand-arglist argument-types)))
 509                 ((cdr chosen)
 510                  (error "Ambiguous match.~%  ~
 511                            method = ~A, args = ~A~%  ~
 512                            matches = ~A"
 513                         (java-method-name java-method)
 514                         (expand-arglist argument-types)
 515                         (expand-methodlist chosen)))
 516                 (t (setf (gethash argument-types
 517                                   (java-method-cache java-method))
 518                          (caar chosen))))))))
 519
 520 (defun argument-type-list-from-names (names)
 521   "Given a list of type NAMES, return the corresponding Java class objects."
 522   (mapcar (lambda (name)
 523             (java-class-jclass (find-java-class name)))
 524           names))
 525
 526 (defun find-jmethod (class name arg-types)
 527   "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
 528    method object for the best matching overload of the method."
 529   (let ((java-class (find-java-class class)))
 530     (get-jmethod-for-argument-types
 531      java-class
 532      (find-java-method java-class name)
 533      (argument-type-list-from-names arg-types))))
 534
 535 (defun find-jconstructor (class arg-types)
 536   "Given a CLASS and a list of ARG-TYPES, return the Java constructor object
 537    for the best matching constructor overload."
 538   (let ((java-class (find-java-class class)))
 539     (get-jmethod-for-argument-types
 540      java-class
 541      (find-java-constructor java-class)
 542      (argument-type-list-from-names arg-types))))
 543
 544 (defun send (object message &rest arguments)
 545   "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
 546    other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best
 547    matches the types of the ARGUMENTS."
 548   (let ((jargs (mapcar #'make-immediate-object arguments)))
 549     (apply #'jcall
 550            (find-jmethod (jobject-class object) message
 551                          (mapcar (lambda (jarg)
 552                                    (if (equal jarg java-null)
 553                                        nil
 554                                        (jobject-class jarg)))
 555                                  jargs))
 556            object
 557            jargs)))
 558
 559 (defun send-class (class message &rest arguments)
 560   "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name
 561    (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static
 562    method of CLASS named by MESSAGE which best matches the types of the
 563    ARGUMENTS."
 564   (let ((java-class (find-java-class class))
 565         (jargs (mapcar #'make-immediate-object arguments)))
 566     (apply #'jcall
 567            (find-jmethod java-class message
 568                          (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
 569            java-null
 570            jargs)))
 571
 572 (defun make (class &rest arguments)
 573   "Given a CLASS (anything acceptable to find-java-class) and other
 574    ARGUMENTS, invoke the constructor of CLASS which best matches the types of
 575    the ARGUMENTS, returning the result."
 576   (let ((java-class (find-java-class class))
 577         (jargs (mapcar #'make-immediate-object arguments)))
 578     (apply #'jnew
 579            (find-jconstructor java-class
 580                               (mapcar (lambda (jarg) (jobject-class jarg))
 581                                       jargs))
 582            jargs)))
 583
 584 ;;;--------------------------------------------------------------------------
 585 ;;; Field access.
 586
 587 (defun field (object name)
 588   "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return
 589    the value of the OBJECT's field with the given NAME.  This is a valid
 590    place for setf."
 591   (jfield (java-name name) object))
 592
 593 (defun (setf field) (value object name)
 594   "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set
 595    the OBJECT's field with the given NAME to be VALUE."
 596   (jfield object name value))
 597
 598 (defun class-field (class name)
 599   "Given a CLASS and a field NAME (Lisp symbol or Java name string), return
 600    the value of the CLASS's static field with the given NAME.  This is a
 601    valid place for setf."
 602   (jfield (jclass (java-name class)) (java-name name)))
 603
 604 (defun (setf class-field) (value class name)
 605   "Given an CLASS and a field NAME (Lisp symbol or Java name string), set
 606    the CLASS's static field with the given NAME to be VALUE."
 607   (jfield (jclass (java-name class)) (java-name name) nil value))
 608
 609 ;;;--------------------------------------------------------------------------
 610 ;;; Arrays.
 611
 612 (defun make-java-array (class items)
 613   "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS,
 614    return a Java array specialized for the named CLASS, containing the
 615    ITEMS."
 616   (jnew-array-from-array (if (symbolp class) (java-name class) class)
 617                          (if (listp items) (coerce items 'vector) items)))
 618
 619 (defun java-array (class &rest items)
 620   "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a
 621    Java array specialized for the named CLASS, containing the ITEMS."
 622   (make-java-array class items))
 623
 624 ;;;--------------------------------------------------------------------------
 625 ;;; Interfaces.
 626
 627 (defmacro implementation (class &body clauses)
 628   "Returns an implementation of the interface names by CLASS (Lisp symbol or
 629    Java name string), whose methods are defined by CLAUSES; each clause has
 630    the form (NAME (BVL ...) FORMS...) where NAME is the name of a method
 631    (Lisp symbol or Java name string), BVL is a standard bound-variable list,
 632    and FORMS are any Lisp forms providing the implementation of the method."
 633   `(jinterface-implementation
 634     ,(java-name class)
 635     ,@(loop for (name bvl . body) in clauses
 636             collect (java-name name)
 637             collect `(lambda ,bvl ,@body))))
 638
 639 ;;;--------------------------------------------------------------------------
 640 ;;; Other useful hacks.
 641
 642 (defmacro magic-constant-case ((selector class) &body keywords)
 643   "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java
 644    class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp
 645    keyword objects.  The SELECTOR is matched against the KEYWORDS.  If a
 646    match is found, the keyword is converted to upper-case, `-' is converted
 647    to `_', and the result used as a Java static field name of the specified
 648    CLASS; the value of this field is returned as the value of the expression.
 649
 650    Note that the class field lookups are really done at macro-expansion time,
 651    not at run-time."
 652   `(ecase ,selector
 653      ,@(mapcar (lambda (key)
 654                  `(,key ,(class-field class
 655                                       (substitute #\_ #\-
 656                                                   (string-upcase key)))))
 657                keywords)))
 658
 659 ;;;----- That's all, folks --------------------------------------------------