source: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp

Last change on this file was 14903, checked in by Mark Evenson, 5 years ago

[PATCH 4/5] Runtime class improvements (ferada)

From faceaa2be78d92b6a6c43f5925fae926f9607bce Mon Sep 17 00:00:00 2001
Work in progress to get to a more functioning runtime class support.

Make static functions and :int parameters work.
Fix return conversion for null.
Ensure that the same classloader is used.

Because otherwise the name of the superclass couldn't be found as it's
not cached anywhere.

It would probably make sense to make the normal classloader a caching
one, so that custom classes can be found by other parts of the (Java)
system?

<http://abcl.org/trac/timeline/14903>

vc:reverts <http://abcl.org/trac/changeset/14882> ;
vc:restores <http://abcl.org/trac/changeset/14858> .

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