source: trunk/j/src/org/armedbear/lisp/java.lisp @ 9266

Last change on this file since 9266 was 7509, checked in by asimon, 17 years ago

JMEMBER-PROTECTED-P

File size: 8.5 KB
Line 
1;;; java.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: java.lisp,v 1.17 2004-08-28 12:55:56 asimon Exp $
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "JAVA")
21
22(defun jregister-handler (object event handler &key data count)
23  (%jregister-handler object event handler data count))
24
25(defun jinterface-implementation (interface &rest method-names-and-defs)
26  "Creates and returns an implementation of a Java interface with
27   methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
28
29   INTERFACE is either a Java interface or a string naming one.
30
31   METHOD-NAMES-AND-DEFS is an alternating list of method names
32   (strings) and method definitions (closures).
33
34   For missing methods, a dummy implementation is provided that
35   returns nothing or null depending on whether the return type is
36   void or not. This is for convenience only, and a warning is issued
37   for each undefined method."
38  (let ((interface (ensure-jclass interface))
39        (implemented-methods
40         (loop for m in method-names-and-defs
41           for i from 0
42           when (evenp i)
43           collect m)))
44    (loop for method across
45      (jclass-methods interface :declared nil :public t)
46      for method-name = (jmethod-name method)
47      with null = (make-immediate-object nil :ref)
48      when (not (member method-name implemented-methods :test #'string=))
49      do
50      (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void"))
51             (arglist (when (plusp (length (jmethod-params method))) '(&rest ignore)))
52             (def `(lambda
53                     ,arglist
54                     ,(when arglist '(declare (ignore ignore)))
55                     ,(if void-p '(values) null))))
56        (warn "Implementing dummy method ~a for interface ~a"
57              method-name (jclass-name interface))
58        (push (coerce def 'function) method-names-and-defs)
59        (push method-name method-names-and-defs)))
60    (apply #'%jnew-proxy interface method-names-and-defs)))
61
62(defun jclass-name (class)
63  "Returns the name of CLASS as a Lisp string"
64  (jcall (jmethod "java.lang.Class" "getName") class))
65
66(defun jobject-class (obj)
67  "Returns the Java class that OBJ belongs to"
68  (jcall (jmethod "java.lang.Object" "getClass") obj))
69
70(defun ensure-jclass (class-or-string)
71  "If handed a string, return a Class object."
72  (if (stringp class-or-string)
73      (jclass class-or-string)
74      class-or-string))
75
76(defun jclass-superclass (class)
77  "Returns the superclass of CLASS, or NIL if it hasn't got one"
78  (jcall (jmethod "java.lang.Class" "getSuperclass") (ensure-jclass class)))
79
80(defun jclass-interfaces (class)
81  "Returns the vector of interfaces of CLASS"
82  (jcall (jmethod "java.lang.Class" "getInterfaces") (ensure-jclass class)))
83
84(defun jclass-interface-p (class)
85  "Returns T if CLASS is an interface"
86  (jcall (jmethod "java.lang.Class" "isInterface") (ensure-jclass class)))
87
88(defun jclass-superclass-p (class-1 class-2)
89  "Returns T if CLASS-1 is a superclass or interface of CLASS-2"
90  (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
91         (ensure-jclass class-1)
92         (ensure-jclass class-2)))
93
94(defun jclass-array-p (class)
95  "Returns T if CLASS is an array class"
96  (jcall (jmethod "java.lang.Class" "isArray") (ensure-jclass class)))
97
98(defun jarray-component-type (atype)
99  "Returns the component type of the array type ATYPE"
100  (assert (jclass-array-p atype))
101  (jcall (jmethod "java.lang.Class" "getComponentType") atype))
102
103(defun jarray-length (java-array)
104  (jstatic "getLength" "java.lang.reflect.Array" java-array)  )
105
106(defun (setf jarray-ref) (new-value java-array &rest indices)
107  (apply #'jarray-set java-array new-value indices))
108
109(defun jnew-array-from-array (element-type array)
110  "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref)
111   initialized from ARRAY"
112  (flet
113    ((row-major-to-index (dimensions n)
114                         (loop for dims on dimensions
115                           for dim = (car dims)
116                           with indices
117                           do
118                           (multiple-value-bind (m r) (floor n (apply #'* (cdr dims)))
119                             (push m indices)
120                             (setq n r))
121                           finally (return (nreverse indices)))))
122    (let* ((fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array)))
123           (dimensions (if fill-pointer (list fill-pointer) (array-dimensions array)))
124           (jarray (apply #'jnew-array element-type dimensions)))
125      (dotimes (i (if fill-pointer fill-pointer (array-total-size array)) jarray)
126        #+maybe_one_day
127        (setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i))
128        (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i))))))
129
130(defun jclass-constructors (class)
131  "Returns a vector of constructors for CLASS"
132  (jcall (jmethod "java.lang.Class" "getConstructors") (ensure-jclass class)))
133
134(defun jconstructor-params (constructor)
135  "Returns a vector of parameter types (Java classes) for CONSTRUCTOR"
136  (jcall (jmethod "java.lang.reflect.Constructor" "getParameterTypes") constructor))
137
138(defun jclass-fields (class &key declared public)
139  "Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS"
140  (let* ((getter (if declared "getDeclaredFields" "getFields"))
141         (fields (jcall (jmethod "java.lang.Class" getter) (ensure-jclass class))))
142    (if public (delete-if-not #'jmember-public-p fields) fields)))
143
144(defun jclass-field (class field-name)
145  "Returns the field named FIELD-NAME of CLASS"
146  (jcall (jmethod "java.lang.Class" "getField" "java.lang.String") 
147         (ensure-jclass class) field-name))
148
149(defun jfield-type (field)
150  "Returns the type (Java class) of FIELD"
151  (jcall (jmethod "java.lang.reflect.Field" "getType") field))
152
153(defun jfield-name (field)
154  "Returns the name of FIELD as a Lisp string"
155  (jcall (jmethod "java.lang.reflect.Field" "getName") field))
156
157(defun jclass-methods (class &key declared public)
158  "Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS"
159  (let* ((getter (if declared "getDeclaredMethods" "getMethods"))
160         (methods (jcall (jmethod "java.lang.Class" getter) (ensure-jclass class))))
161    (if public (delete-if-not #'jmember-public-p methods) methods)))
162
163(defun jmethod-params (method)
164  "Returns a vector of parameter types (Java classes) for METHOD"
165  (jcall (jmethod "java.lang.reflect.Method" "getParameterTypes") method))
166
167(defun jmethod-return-type (method)
168  "Returns the result type (Java class) of the METHOD"
169  (jcall (jmethod "java.lang.reflect.Method" "getReturnType") method))
170
171(defun jmethod-name (method)
172  "Returns the name of METHOD as a Lisp string"
173  (jcall (jmethod "java.lang.reflect.Method" "getName") method))
174
175(defun jinstance-of-p (obj class)
176  "OBJ is an instance of CLASS (or one of its subclasses)"
177  (and (java-object-p obj)
178       (jcall (jmethod "java.lang.Class" "isInstance" "java.lang.Object") (ensure-jclass class) obj)))
179
180(defun jmember-static-p (member)
181  "MEMBER is a static member of its declaring class"
182  (jstatic (jmethod "java.lang.reflect.Modifier" "isStatic" "int")
183           "java.lang.reflect.Modifier"
184           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
185
186(defun jmember-public-p (member)
187  "MEMBER is a public member of its declaring class"
188  (jstatic (jmethod "java.lang.reflect.Modifier" "isPublic" "int")
189           "java.lang.reflect.Modifier"
190           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
191
192(defun jmember-protected-p (member)
193  "MEMBER is a protected member of its declaring class"
194  (jstatic (jmethod "java.lang.reflect.Modifier" "isProtected" "int")
195           "java.lang.reflect.Modifier"
196           (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member)))
197
198(provide :java-extensions)
Note: See TracBrowser for help on using the repository browser.