Changeset 13785

01/16/12 23:38:52 (12 years ago)

Refactoring in runtime-class.
Added annotations on class.
Added fields (with annotations as well).

2 edited


  • trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

    r13710 r13785  
    279279(export 'jnew-runtime-class "JAVA")
    280280(autoload 'jnew-runtime-class "runtime-class")
     281(export 'define-java-class "JAVA")
     282(autoload-macro 'define-java-class "runtime-class")
    281283(export 'ensure-java-class "JAVA")
    282284(autoload 'ensure-java-class "java")
    286288(autoload-macro 'jmethod-let "java")
    287289(export 'jequal "JAVA")
    288 (autoload-macro 'jequal "java")
     290(autoload 'jequal "java")
    290292;; Profiler.
  • trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp

    r13764 r13785  
    1111(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)
    1414  "Creates and loads a Java class with methods calling Lisp closures
    1515   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
    1717   lists of constructor, method and field definitions.
    19    Constructor definitions are lists of the form
     19   Constructor definitions - currently NOT supported - are lists of the form
    2020   (argument-types function &optional super-invocation-arguments)
    2121   where argument-types is a list of strings and function is a lisp function of
    3535   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
    37    Field definitions are lists of the form
    38    (field-name type modifier*)
    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))))
     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."
    4255  (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))
    4757         method-implementation-fields)
    4858    (setf (class-file-interfaces class-file)
    4959          (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)))
     88(defun java::runtime-class-add-methods (class-file methods)
     89  (let (method-implementation-fields)
    5090    (dolist (m methods)
    5191      (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m
    89129                     (astore (+ i (1+ argc)))))
    90130            ;;Load the Lisp function from its static field
    91             (emit-getstatic jvm-class-name field-name +lisp-object+)
     131            (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
    92132            (if (<= (1+ argc) call-registers-limit)
    93133                (progn
    112152              (t
    113153               (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))
     156(defmacro java:define-java-class () :todo)
    134158(defun parse-annotation (annotation)
    155179          (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value)))
    156180         (t (make-primitive-or-string-annotation-element :name name :value value)))))))
     183;; - Fields: test
     184;; - Properties + optional accessors (CLOS methods)
     185;; - Function calls with 8+ args
     186;; - super?
     187;; - Constructors?
Note: See TracChangeset for help on using the changeset viewer.