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

Last change on this file since 14215 was 13981, checked in by astalla, 9 years ago

runtime-class: basic support for calling superclass methods (only with the same signature and only defined in the direct superclass)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.1 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: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   (method-name return-type argument-types function &key modifiers annotations)
32   where method-name is a string, return-type and argument-types are strings or keywords for
33   primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
34   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
35
36   Field definitions are lists of the form (field-name type &key modifiers annotations)."
37  (declare (ignorable superclass interfaces constructors methods fields access-flags annotations))
38  (let ((stream (sys::%make-byte-array-output-stream))
39         ;;TODO provide constructor in MemoryClassLoader
40        (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" "")))
41    (multiple-value-bind (class-file method-implementation-fields)
42        (apply #'java::%jnew-runtime-class class-name stream args)
43      (sys::put-memory-function memory-class-loader
44                                class-name (sys::%get-output-stream-bytes stream))
45      (let ((jclass (java:jcall "loadClass" memory-class-loader class-name)))
46        (dolist (method method-implementation-fields)
47          (setf (java:jfield jclass (car method)) (cdr method)))
48        jclass))))
49
50(defun java::%jnew-runtime-class
51    (class-name stream &key (superclass "java.lang.Object")
52     interfaces constructors methods fields (access-flags '(:public)) annotations)
53  "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."
54  (let* ((jvm-class-name (make-jvm-class-name class-name))
55         (class-file (make-class-file jvm-class-name (make-jvm-class-name superclass) access-flags))
56         method-implementation-fields)
57    (setf (class-file-interfaces class-file)
58          (mapcar #'make-jvm-class-name interfaces))
59    (when annotations
60      (class-add-attribute class-file (make-runtime-visible-annotations-attribute
61                                       :list (mapcar #'parse-annotation annotations))))
62    (setf method-implementation-fields (java::runtime-class-add-methods class-file methods))
63    (java::runtime-class-add-fields class-file fields)
64    (if (null constructors)
65      (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public))))
66        (class-add-method class-file ctor)
67        (with-code-to-method (class-file ctor)
68          (aload 0)
69          (emit-invokespecial-init (class-file-superclass class-file) nil)
70          (emit 'return)))
71      (error "constructors not supported"))
72    (finalize-class-file class-file)
73    (write-class-file class-file stream)
74    (finish-output stream)
75    #+test-record-generated-class-file
76    (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8))
77      (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f))
78    (values class-file method-implementation-fields)))
79
80(defun java::make-accessor-name (prefix name)
81  (let ((initial (char-upcase (aref name 0)))
82        (rest (subseq name 1)))
83    (format nil "~A~A~A" prefix initial rest)))
84
85;;This is missing from compiler-pass2.lisp. Probably this and similar functions should reside
86;;in a dedicated file, independent from both runtime-class and compiler-pass2.
87(defun emit-invokespecial (class-name method-name arg-types return-type)
88  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
89         (index (pool-add-method-ref *pool* class-name
90                                     method-name (cons return-type arg-types)))
91         (instruction (apply #'%emit 'invokespecial (u2 index))))
92    (declare (type (signed-byte 8) stack-effect))
93    (setf (instruction-stack instruction) (1- stack-effect))))
94
95(defun java::canonicalize-java-type (type)
96  (cond
97    ((stringp type) (make-jvm-class-name type))
98    ((keywordp type) type)
99    (t (error "Unrecognized Java type: ~A" type))))
100
101(defun java::emit-unbox-and-return (return-type)
102  (cond
103    ((eq return-type :void)
104     (emit 'pop)
105     (emit 'return))
106    ((eq return-type :int)
107     (emit-invokevirtual +lisp-object+ "intValue" nil :int)
108     (emit 'ireturn))
109    ((eq return-type :boolean)
110     (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean)
111     (emit 'ireturn))
112    ((jvm-class-name-p return-type)
113     (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
114     (emit-checkcast return-type)
115     (emit 'areturn))
116    (t
117     (error "Unsupported return type: ~A" return-type))))
118
119(defun java::runtime-class-add-methods (class-file methods)
120  (let (method-implementation-fields)
121    (dolist (m methods)
122      (destructuring-bind (name return-type argument-types function
123                           &key (modifiers '(:public)) annotations override) m
124        (let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
125               (argc (length argument-types))
126               (return-type (java::canonicalize-java-type return-type))
127               (jmethod (make-jvm-method name return-type argument-types :flags modifiers))
128               (field-name (string (gensym name))))
129          (class-add-method class-file jmethod)
130          (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
131            (class-add-field class-file field)
132            (push (cons field-name function) method-implementation-fields))
133          (when annotations
134            (method-add-attribute jmethod (make-runtime-visible-annotations-attribute
135                                           :list (mapcar #'parse-annotation annotations))))
136          (with-code-to-method (class-file jmethod)
137            ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
138            (dotimes (i (* 2 (1+ argc)))
139              (allocate-register nil))
140            ;;Box "this" (to be passed as the first argument to the Lisp function)
141            (aload 0)
142            (emit 'iconst_1) ;;true
143            (emit-invokestatic +abcl-java-object+ "getInstance"
144                               (list +java-object+ :boolean) +lisp-object+)
145            (astore (1+ argc))
146            ;;Box each argument
147            (loop
148               :for arg-type :in argument-types
149               :for i :from 1
150               :do (progn
151                     (cond
152                       ((keywordp arg-type)
153                        (error "Unsupported arg-type: ~A" arg-type))
154                       ((eq arg-type :int) :todo)
155                       (t (aload i)
156                          (emit 'iconst_1) ;;true
157                          (emit-invokestatic +abcl-java-object+ "getInstance"
158                                             (list +java-object+ :boolean) +lisp-object+)))
159                     (astore (+ i (1+ argc)))))
160            ;;Load the Lisp function from its static field
161            (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
162            (if (<= (1+ argc) call-registers-limit)
163                (progn
164                  ;;Load the boxed this
165                  (aload (1+ argc))
166                  ;;Load each boxed argument
167                  (dotimes (i argc)
168                    (aload (+ argc 2 i))))
169                (error "execute(LispObject[]) is currently not supported"))
170            (emit-call-execute (1+ (length argument-types)))
171            (java::emit-unbox-and-return return-type))
172          (cond
173            ((eq override t)
174             (let ((super-method
175                    (make-jvm-method (format nil "super$~A" name)
176                                     return-type argument-types :flags modifiers)))
177               (class-add-method class-file super-method)
178               (with-code-to-method (class-file super-method)
179                 (dotimes (i (1+ (length argument-types)))
180                   (allocate-register nil))
181                 (aload 0)
182                 (loop
183                    :for arg-type :in argument-types
184                    :for i :from 1
185                    :do (progn
186                          (cond
187                            ((keywordp arg-type)
188                             (error "Unsupported arg-type: ~A" arg-type))
189                            ((eq arg-type :int) :todo)
190                            (t (aload i)))))
191                 (emit-invokespecial (class-file-superclass class-file) name
192                                     argument-types return-type)
193                 ;(emit 'pop)
194                 (cond
195                   ((eq return-type :void)
196                    (emit 'return))
197                   ((eq return-type :int)
198                    (emit 'ireturn))
199                   ((eq return-type :boolean)
200                    (emit 'ireturn))
201                   ((jvm-class-name-p return-type)
202                    (emit 'areturn))
203                   (t
204                    (error "Unsupported return type: ~A" return-type))))))))))
205    method-implementation-fields))
206
207(defun java::runtime-class-add-fields (class-file fields)
208  (dolist (field-spec fields)
209    (destructuring-bind (name type &key (modifiers '(:public)) annotations
210                              (getter nil getter-p) (setter nil setter-p)
211                              (property (and (not getter-p) (not setter-p))))
212        field-spec
213      (let* ((type (if (keywordp type) type (make-jvm-class-name type)))
214             (field (make-field name type :flags modifiers)))
215        (when (member :static modifiers)
216          (setf property nil getter nil setter nil))
217        (when annotations
218          (field-add-attribute field (make-runtime-visible-annotations-attribute
219                                      :list (mapcar #'parse-annotation annotations))))
220        (class-add-field class-file field)
221        (when (or getter property)
222          (unless (stringp getter)
223            (setf getter (java::make-accessor-name "get" (if (stringp property) property name))))
224          (let ((jmethod (make-jvm-method getter type nil :flags '(:public))))
225            (class-add-method class-file jmethod)
226            (with-code-to-method (class-file jmethod)
227              (aload 0)
228              (emit-getfield (class-file-class class-file) name type)
229              (cond
230                ((jvm-class-name-p type) (emit 'areturn))
231                ((eq type :int) (emit 'ireturn))
232                (t (error "Unsupported getter return type: ~A" type))))))
233        (when (or setter property)
234          (unless (stringp setter)
235            (setf setter (java::make-accessor-name "set" (if (stringp property) property name))))
236          (let ((jmethod (make-jvm-method setter :void (list type) :flags '(:public))))
237            (class-add-method class-file jmethod)
238            (with-code-to-method (class-file jmethod)
239              (aload 0)
240              (cond
241                ((jvm-class-name-p type) (aload 1))
242                ((eq type :int) (emit 'iload 1))
243                (t (error "Unsupported setter parameter type: ~A" type)))
244              (emit-putfield (class-file-class class-file) name type)
245              (emit 'return))))))))
246
247(defmacro java:define-java-class () :todo)
248
249(defun parse-annotation (annotation)
250  (when (annotation-p annotation)
251    (return-from parse-annotation annotation))
252  (destructuring-bind (class &rest elements) (if (listp annotation) annotation (list annotation))
253    (let (actual-elements)
254      (dolist (elem elements)
255        (push (parse-annotation-element elem) actual-elements))
256      (make-annotation :type class :elements (nreverse actual-elements)))))
257
258(defun parse-annotation-element (elem)
259  (cond
260    ((annotation-element-p elem) elem)
261    ((atom elem) (make-primitive-or-string-annotation-element :name nil :value elem))
262    ((keywordp (car elem)) (parse-annotation-element `("value" ,@elem)))
263    (t
264     (destructuring-bind (name &key value enum annotation) elem
265       (cond
266         (enum (make-enum-value-annotation-element :name name :type enum :value value))
267         (annotation
268          (make-annotation-value-annotation-element :name name :value (parse-annotation annotation)))
269         ((listp value)
270          (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value)))
271         (t (make-primitive-or-string-annotation-element :name name :value value)))))))
272
273;;TODO:
274;; - Returning nil as null is broken
275;; - Function calls with 8+ args
276;; - 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.
277;; - Constructors
278;; - optional accessors (CLOS methods) for properties?
279
280#+example
281(java:jnew-runtime-class
282 "Foo"
283 :interfaces (list "java.lang.Comparable")
284 :fields (list '("someField" "java.lang.String") '("anotherField" "java.lang.Object" :getter t))
285 :methods (list
286           (list "foo" :void '("java.lang.Object")
287                 (lambda (this that) (print (list this that)))
288                 :annotations (list "java.lang.Deprecated"
289                                    '("java.lang.annotation.Retention"
290                                      (:enum "java.lang.annotation.RetentionPolicy" :value "RUNTIME"))
291                                    '("javax.xml.bind.annotation.XmlAttribute" ("required" :value t))
292                                    '("com.manydesigns.portofino.system.model.users.annotations.RequiresPermissions"
293                                      ("level"
294                                       :enum "com.manydesigns.portofino.model.pages.AccessLevel"
295                                       :value "EDIT")
296                                      ("permissions" :value ("foo" "bar")))))
297           (list "bar" :int '("java.lang.Object")
298                 (lambda (this that) (print (list this that)) 23))))
299
300(provide "RUNTIME-CLASS")
Note: See TracBrowser for help on using the repository browser.