source: branches/scripting/j/src/org/armedbear/lisp/java.lisp @ 11369

Last change on this file since 11369 was 11369, checked in by astalla, 13 years ago

Introduced jmake-invocation-handler and jmake-proxy.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.9 KB
Line 
1;;; java.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves, Andras Simon
4;;; $Id: java.lisp 11369 2008-10-30 06:30:25Z astalla $
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(in-package "JAVA")
21
22(require "CLOS")
23
24(defun jregister-handler (object event handler &key data count)
25  (%jregister-handler object event handler data count))
26
27(defun jinterface-implementation (interface &rest method-names-and-defs)
28  "Creates and returns an implementation of a Java interface with
29   methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
30
31   INTERFACE is either a Java interface or a string naming one.
32
33   METHOD-NAMES-AND-DEFS is an alternating list of method names
34   (strings) and method definitions (closures).
35
36   For missing methods, a dummy implementation is provided that
37   returns nothing or null depending on whether the return type is
38   void or not. This is for convenience only, and a warning is issued
39   for each undefined method."
40  (let ((interface (jclass interface))
41        (implemented-methods
42         (loop for m in method-names-and-defs
43           for i from 0
44           if (evenp i)
45           do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
46           else
47           do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))
48        (null (make-immediate-object nil :ref)))
49    (loop for method across
50      (jclass-methods interface :declared nil :public t)
51      for method-name = (jmethod-name method)
52      when (not (member method-name implemented-methods :test #'string=))
53      do
54      (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void"))
55             (arglist (when (plusp (length (jmethod-params method))) '(&rest ignore)))
56             (def `(lambda
57                     ,arglist
58                     ,(when arglist '(declare (ignore ignore)))
59                     ,(if void-p '(values) null))))
60        (warn "Implementing dummy method ~a for interface ~a"
61              method-name (jclass-name interface))
62        (push (coerce def 'function) method-names-and-defs)
63        (push method-name method-names-and-defs)))
64    (apply #'%jnew-proxy interface method-names-and-defs)))
65
66(defun jimplement-interface (interface &rest method-names-and-defs)
67  "Creates and returns an implementation of a Java interface with
68   methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
69
70   INTERFACE is either a Java interface or a string naming one.
71
72   METHOD-NAMES-AND-DEFS is an alternating list of method names
73   (strings) and method definitions (closures).
74
75   For missing methods, a dummy implementation is provided that
76   returns nothing or null depending on whether the return type is
77   void or not. This is for convenience only, and a warning is issued
78   for each undefined method."
79  (let ((interface (jclass interface))
80        (implemented-methods
81         (loop for m in method-names-and-defs
82           for i from 0
83           if (evenp i)
84           do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
85           else
86           do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))
87        (null (make-immediate-object nil :ref)))
88    (loop for method across
89      (jclass-methods interface :declared nil :public t)
90      for method-name = (jmethod-name method)
91      when (not (member method-name implemented-methods :test #'string=))
92      do
93      (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void"))
94             (arglist '(&rest ignore))
95             (def `(lambda
96                     ,arglist
97                     ,(when arglist '(declare (ignore ignore)))
98                     ,(if void-p '(values) null))))
99        (warn "Implementing dummy method ~a for interface ~a"
100              method-name (jclass-name interface))
101        (push (coerce def 'function) method-names-and-defs)
102        (push method-name method-names-and-defs)))
103    (apply #'%jimplement-interface interface method-names-and-defs)))
104
105(defun jmake-invocation-handler (function)
106  (%jmake-invocation-handler function))
107
108(defun jmake-proxy (interface invocation-handler)
109  (let ((handler (if (functionp invocation-handler)
110         (jmake-invocation-handler invocation-handler)
111         invocation-handler)))
112    (%jmake-proxy (jclass interface) handler)))
113
114(defun jobject-class (obj)
115  "Returns the Java class that OBJ belongs to"
116  (jcall (jmethod "java.lang.Object" "getClass") obj))
117
118(defun jclass-superclass (class)
119  "Returns the superclass of CLASS, or NIL if it hasn't got one"
120  (jcall (jmethod "java.lang.Class" "getSuperclass") (jclass class)))
121
122(defun jclass-interfaces (class)
123  "Returns the vector of interfaces of CLASS"
124  (jcall (jmethod "java.lang.Class" "getInterfaces") (jclass class)))
125
126(defun jclass-interface-p (class)
127  "Returns T if CLASS is an interface"
128  (jcall (jmethod "java.lang.Class" "isInterface") (jclass class)))
129
130(defun jclass-superclass-p (class-1 class-2)
131  "Returns T if CLASS-1 is a superclass or interface of CLASS-2"
132  (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
133         (jclass class-1)
134         (jclass class-2)))
135
136(defun jclass-array-p (class)
137  "Returns T if CLASS is an array class"
138  (jcall (jmethod "java.lang.Class" "isArray") (jclass class)))
139
140(defun jarray-component-type (atype)
141  "Returns the component type of the array type ATYPE"
142  (assert (jclass-array-p atype))
143  (jcall (jmethod "java.lang.Class" "getComponentType") atype))
144
145(defun jarray-length (java-array)
146  (jstatic "getLength" "java.lang.reflect.Array" java-array)  )
147
148(defun (setf jarray-ref) (new-value java-array &rest indices)
149  (apply #'jarray-set java-array new-value indices))
150
151(defun jnew-array-from-array (element-type array)
152  "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref)
153   initialized from ARRAY"
154  (flet
155    ((row-major-to-index (dimensions n)
156                         (loop for dims on dimensions
157                           with indices
158                           do
159                           (multiple-value-bind (m r) (floor n (apply #'* (cdr dims)))
160                             (push m indices)
161                             (setq n r))
162                           finally (return (nreverse indices)))))
163    (let* ((fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array)))
164           (dimensions (if fill-pointer (list fill-pointer) (array-dimensions array)))
165           (jarray (apply #'jnew-array element-type dimensions)))
166      (dotimes (i (if fill-pointer fill-pointer (array-total-size array)) jarray)
167        #+maybe_one_day
168        (setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i))
169        (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i))))))
170
171(defun jclass-constructors (class)
172  "Returns a vector of constructors for CLASS"
173  (jcall (jmethod "java.lang.Class" "getConstructors") (jclass class)))
174
175(defun jconstructor-params (constructor)
176  "Returns a vector of parameter types (Java classes) for CONSTRUCTOR"
177  (jcall (jmethod "java.lang.reflect.Constructor" "getParameterTypes") constructor))
178
179(defun jclass-fields (class &key declared public)
180  "Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS"
181  (let* ((getter (if declared "getDeclaredFields" "getFields"))
182         (fields (jcall (jmethod "java.lang.Class" getter) (jclass class))))
183    (if public (delete-if-not #'jmember-public-p fields) fields)))
184
185(defun jclass-field (class field-name)
186  "Returns the field named FIELD-NAME of CLASS"
187  (jcall (jmethod "java.lang.Class" "getField" "java.lang.String")
188         (jclass class) field-name))
189
190(defun jfield-type (field)
191  "Returns the type (Java class) of FIELD"
192  (jcall (jmethod "java.lang.reflect.Field" "getType") field))
193
194(defun jfield-name (field)
195  "Returns the name of FIELD as a Lisp string"
196  (jcall (jmethod "java.lang.reflect.Field" "getName") field))
197
198(defun jclass-methods (class &key declared public)
199  "Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS"
200  (let* ((getter (if declared "getDeclaredMethods" "getMethods"))
201         (methods (jcall (jmethod "java.lang.Class" getter) (jclass class))))
202    (if public (delete-if-not #'jmember-public-p methods) methods)))
203
204(defun jmethod-params (method)
205  "Returns a vector of parameter types (Java classes) for METHOD"
206  (jcall (jmethod "java.lang.reflect.Method" "getParameterTypes") method))
207
208;; (defun jmethod-return-type (method)
209;;   "Returns the result type (Java class) of the METHOD"
210;;   (jcall (jmethod "java.lang.reflect.Method" "getReturnType") method))
211
212(defun jmethod-name (method)
213  "Returns the name of METHOD as a Lisp string"
214  (jcall (jmethod "java.lang.reflect.Method" "getName") method))
215
216(defun jinstance-of-p (obj class)
217  "OBJ is an instance of CLASS (or one of its subclasses)"
218  (and (java-object-p obj)
219       (jcall (jmethod "java.lang.Class" "isInstance" "java.lang.Object") (jclass class) obj)))
220
221(defun jmember-static-p (member)
222  "MEMBER is a static member of its declaring class"
223  (jstatic (jmethod "java.lang.reflect.Modifier" "isStatic" "int")
224           "java.lang.reflect.Modifier"
225           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
226
227(defun jmember-public-p (member)
228  "MEMBER is a public member of its declaring class"
229  (jstatic (jmethod "java.lang.reflect.Modifier" "isPublic" "int")
230           "java.lang.reflect.Modifier"
231           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
232
233(defun jmember-protected-p (member)
234  "MEMBER is a protected member of its declaring class"
235  (jstatic (jmethod "java.lang.reflect.Modifier" "isProtected" "int")
236           "java.lang.reflect.Modifier"
237           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
238
239(defmethod make-load-form ((object java-object) &optional environment)
240  (declare (ignore environment))
241  (let ((class-name (jclass-name (jclass-of object))))
242    (cond
243     ((string= class-name "java.lang.reflect.Constructor")
244      `(java:jconstructor ,(jclass-name
245                            (jcall (jmethod "java.lang.reflect.Constructor"
246                                            "getDeclaringClass") object))
247                          ,@(loop for arg-type across
248                              (jcall
249                               (jmethod "java.lang.reflect.Constructor"
250                                        "getParameterTypes")
251                               object)
252                              collecting
253                              (jclass-name arg-type))))
254     ((string= class-name "java.lang.reflect.Method")
255      `(java:jmethod ,(jclass-name
256                       (jcall (jmethod "java.lang.reflect.Method"
257                                       "getDeclaringClass") object))
258                     ,(jmethod-name object)
259                     ,@(loop for arg-type across
260                         (jcall
261                          (jmethod "java.lang.reflect.Method"
262                                   "getParameterTypes")
263                          object)
264                         collecting
265                         (jclass-name arg-type))))
266     ((jinstance-of-p object "java.lang.Class")
267      `(java:jclass ,(jcall (jmethod "java.lang.Class" "getName") object)))
268     (t
269      (error "Unknown load-from for ~A" class-name)))))
270
271(provide "JAVA-EXTENSIONS")
Note: See TracBrowser for help on using the repository browser.