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