Changeset 13785 for trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
- Timestamp:
- 01/16/12 23:38:52 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
r13764 r13785 10 10 11 11 (defun java:jnew-runtime-class 12 (class-name & key (superclass (make-jvm-class-name "java.lang.Object"))13 interfaces constructors methods fields (access-flags '(:public)) )12 (class-name &rest args &key (superclass "java.lang.Object") 13 interfaces constructors methods fields (access-flags '(:public)) annotations) 14 14 "Creates and loads a Java class with methods calling Lisp closures 15 15 as given in METHODS. CLASS-NAME and SUPER-NAME are strings, … … 17 17 lists of constructor, method and field definitions. 18 18 19 Constructor definitions are lists of the form19 Constructor definitions - currently NOT supported - are lists of the form 20 20 (argument-types function &optional super-invocation-arguments) 21 21 where argument-types is a list of strings and function is a lisp function of … … 35 35 (1+ (length argument-types)); the instance (`this') is passed in as the first argument. 36 36 37 Field definitions are lists of the form 38 (field-name type modifier*) 39 40 If FILE-NAME is given, a .class file will be written; this is useful for debugging only." 41 (declare (ignorable constructors fields)) 37 Field definitions are lists of the form (field-name type &key modifiers annotations)." 38 (declare (ignorable superclass interfaces constructors methods fields access-flags annotations)) 39 (let ((stream (sys::%make-byte-array-output-stream)) 40 ;;TODO provide constructor in MemoryClassLoader 41 (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" ""))) 42 (multiple-value-bind (class-file method-implementation-fields) 43 (apply #'java::%jnew-runtime-class class-name stream args) 44 (sys::put-memory-function memory-class-loader 45 class-name (sys::%get-output-stream-bytes stream)) 46 (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) 47 (dolist (method method-implementation-fields) 48 (setf (java:jfield jclass (car method)) (cdr method))) 49 jclass)))) 50 51 (defun java::%jnew-runtime-class 52 (class-name stream &key (superclass "java.lang.Object") 53 interfaces constructors methods fields (access-flags '(:public)) annotations) 54 "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." 42 55 (let* ((jvm-class-name (make-jvm-class-name class-name)) 43 (class-file (make-class-file jvm-class-name superclass access-flags)) 44 (stream (sys::%make-byte-array-output-stream)) 45 ;;TODO provide constructor in MemoryClassLoader 46 (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" "")) 56 (class-file (make-class-file jvm-class-name (make-jvm-class-name superclass) access-flags)) 47 57 method-implementation-fields) 48 58 (setf (class-file-interfaces class-file) 49 59 (mapcar #'make-jvm-class-name interfaces)) 60 (when annotations 61 (class-add-attribute class-file (make-runtime-visible-annotations-attribute 62 :list (mapcar #'parse-annotation annotations)))) 63 (setf method-implementation-fields (java::runtime-class-add-methods class-file methods)) 64 (dolist (field-spec fields) 65 (destructuring-bind (name type &key (modifiers '(:public)) annotations) field-spec 66 (let ((field (make-field name (if (keywordp type) type (make-jvm-class-name type)) 67 :flags modifiers))) 68 (when annotations 69 (field-add-attribute field (make-runtime-visible-annotations-attribute 70 :list (mapcar #'parse-annotation annotations)))) 71 (class-add-field class-file field)))) 72 (if (null constructors) 73 (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) 74 (class-add-method class-file ctor) 75 (with-code-to-method (class-file ctor) 76 (aload 0) 77 (emit-invokespecial-init (class-file-superclass class-file) nil) 78 (emit 'return))) 79 (error "constructors not supported")) 80 (finalize-class-file class-file) 81 (write-class-file class-file stream) 82 (finish-output stream) 83 #+test-record-generated-class-file 84 (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8)) 85 (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) 86 (values class-file method-implementation-fields))) 87 88 (defun java::runtime-class-add-methods (class-file methods) 89 (let (method-implementation-fields) 50 90 (dolist (m methods) 51 91 (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m … … 89 129 (astore (+ i (1+ argc))))) 90 130 ;;Load the Lisp function from its static field 91 (emit-getstatic jvm-class-namefield-name +lisp-object+)131 (emit-getstatic (class-file-class class-file) field-name +lisp-object+) 92 132 (if (<= (1+ argc) call-registers-limit) 93 133 (progn … … 112 152 (t 113 153 (error "Unsupported return type: ~A" return-type))))))) 114 (when (null constructors) 115 (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) 116 (class-add-method class-file ctor) 117 (with-code-to-method (class-file ctor) 118 (aload 0) 119 (emit-invokespecial-init (class-file-superclass class-file) nil) 120 (emit 'return)))) 121 (finalize-class-file class-file) 122 (write-class-file class-file stream) 123 (finish-output stream) 124 #+test-record-generated-class-file 125 (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8)) 126 (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) 127 (sys::put-memory-function memory-class-loader 128 class-name (sys::%get-output-stream-bytes stream)) 129 (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) 130 (dolist (method method-implementation-fields) 131 (setf (java:jfield jclass (car method)) (cdr method))) 132 jclass))) 154 method-implementation-fields)) 155 156 (defmacro java:define-java-class () :todo) 133 157 134 158 (defun parse-annotation (annotation) … … 155 179 (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value))) 156 180 (t (make-primitive-or-string-annotation-element :name name :value value))))))) 181 182 ;;TODO: 183 ;; - Fields: test 184 ;; - Properties + optional accessors (CLOS methods) 185 ;; - Function calls with 8+ args 186 ;; - super? 187 ;; - Constructors? 157 188 158 189 #+example
Note: See TracChangeset
for help on using the changeset viewer.