| 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 | (current-class-loader (java:get-current-classloader)) |
|---|
| 40 | (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" current-class-loader))) |
|---|
| 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") |
|---|
