source: trunk/abcl/src/org/armedbear/lisp/java.lisp @ 11529

Last change on this file since 11529 was 11529, checked in by Mark Evenson, 12 years ago

Revert inadvertent r11528.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.5 KB
Line 
1;;; java.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves, Andras Simon
4;;; $Id: java.lisp 11529 2009-01-03 13:17:22Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JAVA")
33
34(require "CLOS")
35
36(defun jregister-handler (object event handler &key data count)
37  (%jregister-handler object event handler data count))
38
39(defun jinterface-implementation (interface &rest method-names-and-defs)
40  "Creates and returns an implementation of a Java interface with
41   methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
42
43   INTERFACE is either a Java interface or a string naming one.
44
45   METHOD-NAMES-AND-DEFS is an alternating list of method names
46   (strings) and method definitions (closures).
47
48   For missing methods, a dummy implementation is provided that
49   returns nothing or null depending on whether the return type is
50   void or not. This is for convenience only, and a warning is issued
51   for each undefined method."
52  (let ((interface (jclass interface))
53        (implemented-methods
54         (loop for m in method-names-and-defs
55           for i from 0
56           if (evenp i)
57           do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
58           else
59           do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))
60        (null (make-immediate-object nil :ref)))
61    (loop for method across
62      (jclass-methods interface :declared nil :public t)
63      for method-name = (jmethod-name method)
64      when (not (member method-name implemented-methods :test #'string=))
65      do
66      (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void"))
67             (arglist (when (plusp (length (jmethod-params method))) '(&rest ignore)))
68             (def `(lambda
69                     ,arglist
70                     ,(when arglist '(declare (ignore ignore)))
71                     ,(if void-p '(values) null))))
72        (warn "Implementing dummy method ~a for interface ~a"
73              method-name (jclass-name interface))
74        (push (coerce def 'function) method-names-and-defs)
75        (push method-name method-names-and-defs)))
76    (apply #'%jnew-proxy interface method-names-and-defs)))
77
78(defun jobject-class (obj)
79  "Returns the Java class that OBJ belongs to"
80  (jcall (jmethod "java.lang.Object" "getClass") obj))
81
82(defun jclass-superclass (class)
83  "Returns the superclass of CLASS, or NIL if it hasn't got one"
84  (jcall (jmethod "java.lang.Class" "getSuperclass") (jclass class)))
85
86(defun jclass-interfaces (class)
87  "Returns the vector of interfaces of CLASS"
88  (jcall (jmethod "java.lang.Class" "getInterfaces") (jclass class)))
89
90(defun jclass-interface-p (class)
91  "Returns T if CLASS is an interface"
92  (jcall (jmethod "java.lang.Class" "isInterface") (jclass class)))
93
94(defun jclass-superclass-p (class-1 class-2)
95  "Returns T if CLASS-1 is a superclass or interface of CLASS-2"
96  (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
97         (jclass class-1)
98         (jclass class-2)))
99
100(defun jclass-array-p (class)
101  "Returns T if CLASS is an array class"
102  (jcall (jmethod "java.lang.Class" "isArray") (jclass class)))
103
104(defun jarray-component-type (atype)
105  "Returns the component type of the array type ATYPE"
106  (assert (jclass-array-p atype))
107  (jcall (jmethod "java.lang.Class" "getComponentType") atype))
108
109(defun jarray-length (java-array)
110  (jstatic "getLength" "java.lang.reflect.Array" java-array)  )
111
112(defun (setf jarray-ref) (new-value java-array &rest indices)
113  (apply #'jarray-set java-array new-value indices))
114
115(defun jnew-array-from-array (element-type array)
116  "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref)
117   initialized from ARRAY"
118  (flet
119    ((row-major-to-index (dimensions n)
120                         (loop for dims on dimensions
121                           with indices
122                           do
123                           (multiple-value-bind (m r) (floor n (apply #'* (cdr dims)))
124                             (push m indices)
125                             (setq n r))
126                           finally (return (nreverse indices)))))
127    (let* ((fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array)))
128           (dimensions (if fill-pointer (list fill-pointer) (array-dimensions array)))
129           (jarray (apply #'jnew-array element-type dimensions)))
130      (dotimes (i (if fill-pointer fill-pointer (array-total-size array)) jarray)
131        #+maybe_one_day
132        (setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i))
133        (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i))))))
134
135(defun jclass-constructors (class)
136  "Returns a vector of constructors for CLASS"
137  (jcall (jmethod "java.lang.Class" "getConstructors") (jclass class)))
138
139(defun jconstructor-params (constructor)
140  "Returns a vector of parameter types (Java classes) for CONSTRUCTOR"
141  (jcall (jmethod "java.lang.reflect.Constructor" "getParameterTypes") constructor))
142
143(defun jclass-fields (class &key declared public)
144  "Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS"
145  (let* ((getter (if declared "getDeclaredFields" "getFields"))
146         (fields (jcall (jmethod "java.lang.Class" getter) (jclass class))))
147    (if public (delete-if-not #'jmember-public-p fields) fields)))
148
149(defun jclass-field (class field-name)
150  "Returns the field named FIELD-NAME of CLASS"
151  (jcall (jmethod "java.lang.Class" "getField" "java.lang.String")
152         (jclass class) field-name))
153
154(defun jfield-type (field)
155  "Returns the type (Java class) of FIELD"
156  (jcall (jmethod "java.lang.reflect.Field" "getType") field))
157
158(defun jfield-name (field)
159  "Returns the name of FIELD as a Lisp string"
160  (jcall (jmethod "java.lang.reflect.Field" "getName") field))
161
162(defun jclass-methods (class &key declared public)
163  "Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS"
164  (let* ((getter (if declared "getDeclaredMethods" "getMethods"))
165         (methods (jcall (jmethod "java.lang.Class" getter) (jclass class))))
166    (if public (delete-if-not #'jmember-public-p methods) methods)))
167
168(defun jmethod-params (method)
169  "Returns a vector of parameter types (Java classes) for METHOD"
170  (jcall (jmethod "java.lang.reflect.Method" "getParameterTypes") method))
171
172;; (defun jmethod-return-type (method)
173;;   "Returns the result type (Java class) of the METHOD"
174;;   (jcall (jmethod "java.lang.reflect.Method" "getReturnType") method))
175
176(defun jmethod-name (method)
177  "Returns the name of METHOD as a Lisp string"
178  (jcall (jmethod "java.lang.reflect.Method" "getName") method))
179
180(defun jinstance-of-p (obj class)
181  "OBJ is an instance of CLASS (or one of its subclasses)"
182  (and (java-object-p obj)
183       (jcall (jmethod "java.lang.Class" "isInstance" "java.lang.Object") (jclass class) obj)))
184
185(defun jmember-static-p (member)
186  "MEMBER is a static member of its declaring class"
187  (jstatic (jmethod "java.lang.reflect.Modifier" "isStatic" "int")
188           "java.lang.reflect.Modifier"
189           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
190
191(defun jmember-public-p (member)
192  "MEMBER is a public member of its declaring class"
193  (jstatic (jmethod "java.lang.reflect.Modifier" "isPublic" "int")
194           "java.lang.reflect.Modifier"
195           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
196
197(defun jmember-protected-p (member)
198  "MEMBER is a protected member of its declaring class"
199  (jstatic (jmethod "java.lang.reflect.Modifier" "isProtected" "int")
200           "java.lang.reflect.Modifier"
201           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
202
203(defmethod make-load-form ((object java-object) &optional environment)
204  (declare (ignore environment))
205  (let ((class-name (jclass-name (jclass-of object))))
206    (cond
207     ((string= class-name "java.lang.reflect.Constructor")
208      `(java:jconstructor ,(jclass-name
209                            (jcall (jmethod "java.lang.reflect.Constructor"
210                                            "getDeclaringClass") object))
211                          ,@(loop for arg-type across
212                              (jcall
213                               (jmethod "java.lang.reflect.Constructor"
214                                        "getParameterTypes")
215                               object)
216                              collecting
217                              (jclass-name arg-type))))
218     ((string= class-name "java.lang.reflect.Method")
219      `(java:jmethod ,(jclass-name
220                       (jcall (jmethod "java.lang.reflect.Method"
221                                       "getDeclaringClass") object))
222                     ,(jmethod-name object)
223                     ,@(loop for arg-type across
224                         (jcall
225                          (jmethod "java.lang.reflect.Method"
226                                   "getParameterTypes")
227                          object)
228                         collecting
229                         (jclass-name arg-type))))
230     ((jinstance-of-p object "java.lang.Class")
231      `(java:jclass ,(jcall (jmethod "java.lang.Class" "getName") object)))
232     (t
233      (error "Unknown load-from for ~A" class-name)))))
234
235(provide "JAVA-EXTENSIONS")
Note: See TracBrowser for help on using the repository browser.