1 | (require "JVM") |
---|
2 | |
---|
3 | ;;The package is set to :jvm for convenience, since most of the symbols used |
---|
4 | ;;here come from that package. However, the functions we're definining belong |
---|
5 | ;;to the :java package. |
---|
6 | (in-package :jvm) |
---|
7 | |
---|
8 | (defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject")) |
---|
9 | |
---|
10 | (defun java:jnew-runtime-class |
---|
11 | (class-name &rest args &key (superclass "java.lang.Object") |
---|
12 | interfaces constructors methods fields (access-flags '(:public)) annotations) |
---|
13 | "Creates and loads a Java class with methods calling Lisp closures |
---|
14 | as given in METHODS. CLASS-NAME and SUPER-NAME are strings, |
---|
15 | INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are |
---|
16 | lists of constructor, method and field definitions. |
---|
17 | |
---|
18 | Constructor definitions - currently NOT supported - are lists of the form |
---|
19 | (argument-types function &optional super-invocation-arguments) |
---|
20 | where argument-types is a list of strings and function is a lisp function of |
---|
21 | (1+ (length argument-types)) arguments; the instance (`this') is passed in as |
---|
22 | the last argument. The optional super-invocation-arguments is a list of numbers |
---|
23 | between 1 and (length argument-types), where the number k stands for the kth argument |
---|
24 | to the just defined constructor. If present, the constructor of the superclass |
---|
25 | will be called with the appropriate arguments. E.g., if the constructor definition is |
---|
26 | ((\"java.lang.String\" \"int\") #'(lambda (string i this) ...) (2 1)) |
---|
27 | then the constructor of the superclass with argument types (int, java.lang.String) will |
---|
28 | be called with the second and first arguments. |
---|
29 | |
---|
30 | Method definitions are lists of the form |
---|
31 | |
---|
32 | (METHOD-NAME RETURN-TYPE ARGUMENT-TYPES FUNCTION &key MODIFIERS ANNOTATIONS) |
---|
33 | |
---|
34 | where |
---|
35 | METHOD-NAME is a string |
---|
36 | RETURN-TYPE denotes the type of the object returned by the method |
---|
37 | ARGUMENT-TYPES is a list of parameters to the method |
---|
38 | |
---|
39 | The types are either strings naming fully qualified java classes or Lisp keywords referring to |
---|
40 | primitive types (:void, :int, etc.). |
---|
41 | |
---|
42 | FUNCTION is a Lisp function of minimum arity (1+ (length |
---|
43 | argument-types)). The instance (`this') is passed as the first |
---|
44 | argument. |
---|
45 | |
---|
46 | Field definitions are lists of the form (field-name type &key modifiers annotations)." |
---|
47 | (declare (ignorable superclass interfaces constructors methods fields access-flags annotations)) |
---|
48 | (let* ((stream (sys::%make-byte-array-output-stream)) |
---|
49 | (current-class-loader (java:get-current-classloader)) |
---|
50 | (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" current-class-loader))) |
---|
51 | (multiple-value-bind (class-file method-implementation-fields) |
---|
52 | (apply #'java::%jnew-runtime-class class-name stream args) |
---|
53 | (sys::put-memory-function memory-class-loader |
---|
54 | class-name (sys::%get-output-stream-bytes stream)) |
---|
55 | (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) |
---|
56 | (dolist (method method-implementation-fields) |
---|
57 | (setf (java:jfield jclass (car method)) (cdr method))) |
---|
58 | jclass)))) |
---|
59 | |
---|
60 | (defun java::%jnew-runtime-class |
---|
61 | (class-name stream &key (superclass "java.lang.Object") |
---|
62 | interfaces constructors methods fields (access-flags '(:public)) annotations) |
---|
63 | "Actual implementation of jnew-runtime-class. Writes the class bytes to a stream. Returns two values: the finalized class-file structure and the alist of method implementation fields." |
---|
64 | (let* ((jvm-class-name (make-jvm-class-name class-name)) |
---|
65 | (class-file (make-class-file jvm-class-name (make-jvm-class-name superclass) access-flags)) |
---|
66 | method-implementation-fields) |
---|
67 | (setf (class-file-interfaces class-file) |
---|
68 | (mapcar #'make-jvm-class-name interfaces)) |
---|
69 | (when annotations |
---|
70 | (class-add-attribute class-file (make-runtime-visible-annotations-attribute |
---|
71 | :list (mapcar #'parse-annotation annotations)))) |
---|
72 | (setf method-implementation-fields (java::runtime-class-add-methods class-file methods)) |
---|
73 | (java::runtime-class-add-fields class-file fields) |
---|
74 | (if (null constructors) |
---|
75 | (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) |
---|
76 | (class-add-method class-file ctor) |
---|
77 | (with-code-to-method (class-file ctor) |
---|
78 | (aload 0) |
---|
79 | (emit-invokespecial-init (class-file-superclass class-file) nil) |
---|
80 | (emit 'return))) |
---|
81 | (error "constructors not supported")) |
---|
82 | (finalize-class-file class-file) |
---|
83 | (write-class-file class-file stream) |
---|
84 | (finish-output stream) |
---|
85 | #+test-record-generated-class-file |
---|
86 | (let ((filename (merge-pathnames (format nil "~A.class" class-name)))) |
---|
87 | (with-open-file (f filename :direction :output :element-type '(signed-byte 8)) |
---|
88 | (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) |
---|
89 | (format *standard-output* "~&Wrote class file ~A.~%" filename)) |
---|
90 | (values class-file method-implementation-fields))) |
---|
91 | |
---|
92 | (defun java::make-accessor-name (prefix name) |
---|
93 | (let ((initial (char-upcase (aref name 0))) |
---|
94 | (rest (subseq name 1))) |
---|
95 | (format nil "~A~A~A" prefix initial rest))) |
---|
96 | |
---|
97 | ;;This is missing from compiler-pass2.lisp. Probably this and similar functions should reside |
---|
98 | ;;in a dedicated file, independent from both runtime-class and compiler-pass2. |
---|
99 | (defun emit-invokespecial (class-name method-name arg-types return-type) |
---|
100 | (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) |
---|
101 | (index (pool-add-method-ref *pool* class-name |
---|
102 | method-name (cons return-type arg-types))) |
---|
103 | (instruction (apply #'%emit 'invokespecial (u2 index)))) |
---|
104 | (declare (type (signed-byte 8) stack-effect)) |
---|
105 | (setf (instruction-stack instruction) (1- stack-effect)))) |
---|
106 | |
---|
107 | (defun java::canonicalize-java-type (type) |
---|
108 | (cond |
---|
109 | ((stringp type) (make-jvm-class-name type)) |
---|
110 | ((keywordp type) type) |
---|
111 | (t (error "Unrecognized Java type: ~A" type)))) |
---|
112 | |
---|
113 | (defun java::emit-unbox-and-return (return-type) |
---|
114 | (cond |
---|
115 | ((eq return-type :void) |
---|
116 | (emit 'pop) |
---|
117 | (emit 'return)) |
---|
118 | ((eq return-type :int) |
---|
119 | (emit-invokevirtual +lisp-object+ "intValue" nil :int) |
---|
120 | (emit 'ireturn)) |
---|
121 | ((eq return-type :boolean) |
---|
122 | (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean) |
---|
123 | (emit 'ireturn)) |
---|
124 | ((jvm-class-name-p return-type) |
---|
125 | (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) |
---|
126 | (emit-checkcast return-type) |
---|
127 | (emit 'areturn)) |
---|
128 | (t |
---|
129 | (error "Unsupported return type: ~A" return-type)))) |
---|
130 | |
---|
131 | (defun java::runtime-class-add-methods (class-file methods) |
---|
132 | (let (method-implementation-fields) |
---|
133 | (dolist (m methods) |
---|
134 | (destructuring-bind (name return-type argument-types function |
---|
135 | &key (modifiers '(:public)) annotations override) m |
---|
136 | (let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types)) |
---|
137 | (argc (length argument-types)) |
---|
138 | (return-type (java::canonicalize-java-type return-type)) |
---|
139 | (jmethod (make-jvm-method name return-type argument-types :flags modifiers)) |
---|
140 | (field-name (string (gensym name)))) |
---|
141 | (class-add-method class-file jmethod) |
---|
142 | (let ((field (make-field field-name +lisp-object+ :flags '(:public :static)))) |
---|
143 | (class-add-field class-file field) |
---|
144 | (push (cons field-name function) method-implementation-fields)) |
---|
145 | (when annotations |
---|
146 | (method-add-attribute jmethod (make-runtime-visible-annotations-attribute |
---|
147 | :list (mapcar #'parse-annotation annotations)))) |
---|
148 | (with-code-to-method (class-file jmethod) |
---|
149 | ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this") |
---|
150 | (dotimes (i (* 2 (1+ argc))) |
---|
151 | (allocate-register nil)) |
---|
152 | ;;Box "this" (to be passed as the first argument to the Lisp function) |
---|
153 | (aload 0) |
---|
154 | (emit 'iconst_1) ;;true |
---|
155 | (emit-invokestatic +abcl-java-object+ "getInstance" |
---|
156 | (list +java-object+ :boolean) +lisp-object+) |
---|
157 | (astore (1+ argc)) |
---|
158 | ;;Box each argument |
---|
159 | (loop |
---|
160 | :for arg-type :in argument-types |
---|
161 | :for i :from 1 |
---|
162 | :do (progn |
---|
163 | (cond |
---|
164 | ((keywordp arg-type) |
---|
165 | (error "Unsupported arg-type: ~A" arg-type)) |
---|
166 | ((eq arg-type :int) :todo) |
---|
167 | (t (aload i) |
---|
168 | (emit 'iconst_1) ;;true |
---|
169 | (emit-invokestatic +abcl-java-object+ "getInstance" |
---|
170 | (list +java-object+ :boolean) +lisp-object+))) |
---|
171 | (astore (+ i (1+ argc))))) |
---|
172 | ;;Load the Lisp function from its static field |
---|
173 | (emit-getstatic (class-file-class class-file) field-name +lisp-object+) |
---|
174 | (if (<= (1+ argc) call-registers-limit) |
---|
175 | (progn |
---|
176 | ;;Load the boxed this |
---|
177 | (aload (1+ argc)) |
---|
178 | ;;Load each boxed argument |
---|
179 | (dotimes (i argc) |
---|
180 | (aload (+ argc 2 i)))) |
---|
181 | (error "execute(LispObject[]) is currently not supported")) |
---|
182 | (emit-call-execute (1+ (length argument-types))) |
---|
183 | (java::emit-unbox-and-return return-type)) |
---|
184 | (cond |
---|
185 | ((eq override t) |
---|
186 | (let ((super-method |
---|
187 | (make-jvm-method (format nil "super$~A" name) |
---|
188 | return-type argument-types :flags modifiers))) |
---|
189 | (class-add-method class-file super-method) |
---|
190 | (with-code-to-method (class-file super-method) |
---|
191 | (dotimes (i (1+ (length argument-types))) |
---|
192 | (allocate-register nil)) |
---|
193 | (aload 0) |
---|
194 | (loop |
---|
195 | :for arg-type :in argument-types |
---|
196 | :for i :from 1 |
---|
197 | :do (progn |
---|
198 | (cond |
---|
199 | ((keywordp arg-type) |
---|
200 | (error "Unsupported arg-type: ~A" arg-type)) |
---|
201 | ((eq arg-type :int) :todo) |
---|
202 | (t (aload i))))) |
---|
203 | (emit-invokespecial (class-file-superclass class-file) name |
---|
204 | argument-types return-type) |
---|
205 | ;(emit 'pop) |
---|
206 | (cond |
---|
207 | ((eq return-type :void) |
---|
208 | (emit 'return)) |
---|
209 | ((eq return-type :int) |
---|
210 | (emit 'ireturn)) |
---|
211 | ((eq return-type :boolean) |
---|
212 | (emit 'ireturn)) |
---|
213 | ((jvm-class-name-p return-type) |
---|
214 | (emit 'areturn)) |
---|
215 | (t |
---|
216 | (error "Unsupported return type: ~A" return-type)))))))))) |
---|
217 | method-implementation-fields)) |
---|
218 | |
---|
219 | (defun java::runtime-class-add-fields (class-file fields) |
---|
220 | (dolist (field-spec fields) |
---|
221 | (destructuring-bind (name type &key (modifiers '(:public)) annotations |
---|
222 | (getter nil getter-p) (setter nil setter-p) |
---|
223 | (property (and (not getter-p) (not setter-p)))) |
---|
224 | field-spec |
---|
225 | (let* ((type (if (keywordp type) type (make-jvm-class-name type))) |
---|
226 | (field (make-field name type :flags modifiers))) |
---|
227 | (when (member :static modifiers) |
---|
228 | (setf property nil getter nil setter nil)) |
---|
229 | (when annotations |
---|
230 | (field-add-attribute field (make-runtime-visible-annotations-attribute |
---|
231 | :list (mapcar #'parse-annotation annotations)))) |
---|
232 | (class-add-field class-file field) |
---|
233 | (when (or getter property) |
---|
234 | (unless (stringp getter) |
---|
235 | (setf getter (java::make-accessor-name "get" (if (stringp property) property name)))) |
---|
236 | (let ((jmethod (make-jvm-method getter type nil :flags '(:public)))) |
---|
237 | (class-add-method class-file jmethod) |
---|
238 | (with-code-to-method (class-file jmethod) |
---|
239 | (aload 0) |
---|
240 | (emit-getfield (class-file-class class-file) name type) |
---|
241 | (cond |
---|
242 | ((jvm-class-name-p type) (emit 'areturn)) |
---|
243 | ((eq type :int) (emit 'ireturn)) |
---|
244 | (t (error "Unsupported getter return type: ~A" type)))))) |
---|
245 | (when (or setter property) |
---|
246 | (unless (stringp setter) |
---|
247 | (setf setter (java::make-accessor-name "set" (if (stringp property) property name)))) |
---|
248 | (let ((jmethod (make-jvm-method setter :void (list type) :flags '(:public)))) |
---|
249 | (class-add-method class-file jmethod) |
---|
250 | (with-code-to-method (class-file jmethod) |
---|
251 | (aload 0) |
---|
252 | (cond |
---|
253 | ((jvm-class-name-p type) (aload 1)) |
---|
254 | ((eq type :int) (emit 'iload 1)) |
---|
255 | (t (error "Unsupported setter parameter type: ~A" type))) |
---|
256 | (emit-putfield (class-file-class class-file) name type) |
---|
257 | (emit 'return)))))))) |
---|
258 | |
---|
259 | (defmacro java:define-java-class () :todo) |
---|
260 | |
---|
261 | (defun parse-annotation (annotation) |
---|
262 | (when (annotation-p annotation) |
---|
263 | (return-from parse-annotation annotation)) |
---|
264 | (destructuring-bind (class &rest elements) (if (listp annotation) annotation (list annotation)) |
---|
265 | (let (actual-elements) |
---|
266 | (dolist (elem elements) |
---|
267 | (push (parse-annotation-element elem) actual-elements)) |
---|
268 | (make-annotation :type class :elements (nreverse actual-elements))))) |
---|
269 | |
---|
270 | (defun parse-annotation-element (elem) |
---|
271 | (cond |
---|
272 | ((annotation-element-p elem) elem) |
---|
273 | ((atom elem) (make-primitive-or-string-annotation-element :name nil :value elem)) |
---|
274 | ((keywordp (car elem)) (parse-annotation-element `("value" ,@elem))) |
---|
275 | (t |
---|
276 | (destructuring-bind (name &key value enum annotation) elem |
---|
277 | (cond |
---|
278 | (enum (make-enum-value-annotation-element :name name :type enum :value value)) |
---|
279 | (annotation |
---|
280 | (make-annotation-value-annotation-element :name name :value (parse-annotation annotation))) |
---|
281 | ((listp value) |
---|
282 | (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value))) |
---|
283 | (t (make-primitive-or-string-annotation-element :name name :value value))))))) |
---|
284 | |
---|
285 | ;;TODO: |
---|
286 | ;; - Returning nil as null is broken |
---|
287 | ;; - Function calls with 8+ args |
---|
288 | ;; - super method invocation. Idea: generate companion methods super_... to use with plain jcall. Add a flag per method to optionally disable this when not needed. |
---|
289 | ;; - Constructors |
---|
290 | ;; - optional accessors (CLOS methods) for properties? |
---|
291 | |
---|
292 | #+example |
---|
293 | (java:jnew-runtime-class |
---|
294 | "Foo" |
---|
295 | :interfaces (list "java.lang.Comparable") |
---|
296 | :fields (list '("someField" "java.lang.String") '("anotherField" "java.lang.Object" :getter t)) |
---|
297 | :methods (list |
---|
298 | (list "foo" :void '("java.lang.Object") |
---|
299 | (lambda (this that) (print (list this that))) |
---|
300 | :annotations (list "java.lang.Deprecated" |
---|
301 | '("java.lang.annotation.Retention" |
---|
302 | (:enum "java.lang.annotation.RetentionPolicy" :value "RUNTIME")) |
---|
303 | '("javax.xml.bind.annotation.XmlAttribute" ("required" :value t)) |
---|
304 | '("com.manydesigns.portofino.system.model.users.annotations.RequiresPermissions" |
---|
305 | ("level" |
---|
306 | :enum "com.manydesigns.portofino.model.pages.AccessLevel" |
---|
307 | :value "EDIT") |
---|
308 | ("permissions" :value ("foo" "bar"))))) |
---|
309 | (list "bar" :int '("java.lang.Object") |
---|
310 | (lambda (this that) (print (list this that)) 23)))) |
---|
311 | |
---|
312 | (provide "RUNTIME-CLASS") |
---|