Changeset 13727

Timestamp:

01/07/12 23:09:30 (11 years ago)

Author:

astalla

Message:

Class writer: basic support for annotations (only without parameters)
Runtime-class: annotations on methods only, with no syntax sugar yet

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• jvm-class-file.lisp (modified) (1 diff)
• runtime-class.lisp (modified) (5 diffs)

trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

@@ -1322 +1322 @@
     (write-u2 (local-index local-variable) stream)))
 
+;;Annotations
+
+(defstruct (annotations-attribute
+             (:conc-name annotations-)
+             (:include attribute
+                       ;;Name is to be provided by subtypes
+                       (finalizer #'finalize-annotations)
+                       (writer #'write-annotations)))
+  "An attribute of a class, method or field, containing a list of annotations.
+This structure serves as the abstract supertype of concrete annotations types."
+  list ;; a list of annotation structures, in reverse order
+  )
+
+(defstruct annotation
+  "Each value of the annotations table represents a single runtime-visible annotation on a program element.
+   The annotation structure has the following format:
+     annotation {
+       u2 type_index;
+       u2 num_element_value_pairs;
+       {
+         u2 element_name_index;
+         element_value value;
+       } element_value_pairs[num_element_value_pairs]
+     }"
+  type
+  elements)
+
+(defstruct annotation-element name value)
+
+(defstruct annotation-element-value tag finalizer writer)
+
+(defstruct (primitive-or-string-annotation-element-value
+             (:conc-name primitive-or-string-annotation-element-)
+             (:include annotation-element-value
+                       (finalizer (lambda (self class)
+                                    (let ((value (primitive-or-string-annotation-element-value self)))
+                                      (etypecase value
+                                        (boolean
+                                         (setf (annotation-element-value-tag self)
+                                               (char-code #\B)
+                                               (primitive-or-string-annotation-element-value self)
+                                               (pool-add-int (class-file-constants class) (if value 1 0))))))))
+                       (writer (lambda (self stream)
+                                 (write-u1 (annotation-element-value-tag self) stream)
+                                 (write-u2 (primitive-or-string-annotation-element-value self) stream)))))
+  value)
+
+(defstruct (runtime-visible-annotations-attribute
+             (:include annotations-attribute
+                       (name "RuntimeVisibleAnnotations")
+                       (finalizer #'finalize-annotations)
+                       (writer #'write-annotations)))
+  "4.8.15 The RuntimeVisibleAnnotations attribute
+The RuntimeVisibleAnnotations attribute is a variable length attribute in the
+attributes table of the ClassFile, field_info, and method_info structures. The
+RuntimeVisibleAnnotations attribute records runtime-visible Java program-
+ming language annotations on the corresponding class, method, or field. Each
+ClassFile, field_info, and method_info structure may contain at most one
+RuntimeVisibleAnnotations attribute, which records all the runtime-visible
+Java programming language annotations on the corresponding program element.
+The JVM must make these annotations available so they can be returned by the
+appropriate reflective APIs.")
+
+(defun finalize-annotations (annotations code class)
+  (declare (ignore code))
+  (dolist (ann (annotations-list annotations))
+    (setf (annotation-type ann)
+          (pool-add-class (class-file-constants class)
+                          (if (jvm-class-name-p (annotation-type ann))
+                              (annotation-type ann)
+                              (make-jvm-class-name (annotation-type ann)))))
+    (dolist (elem (annotation-elements ann))
+      (setf (annotation-element-name elem)
+            (pool-add-utf8 (class-file-constants class)
+                           (annotation-element-name elem)))
+      (funcall (annotation-element-value-finalizer (annotation-element-value elem))
+               (annotation-element-value elem) class))))
+
+(defun write-annotations (annotations stream)
+  (write-u2 (length (annotations-list annotations)) stream)
+  (dolist (annotation (reverse (annotations-list annotations)))
+    (write-u2 (annotation-type annotation) stream)
+    (write-u2 (length (annotation-elements annotation)) stream)
+    (dolist (elem (reverse (annotation-elements annotation)))
+      (funcall (annotation-element-value-writer elem) elem stream))))
+
 #|
 

trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp

@@ -1 +1 @@
 (require "COMPILER-PASS2")
+(require "JVM-CLASS-FILE")
 
 (in-package :jvm)
@@ -26 +27 @@
 
    Method definitions are lists of the form
-   (method-name return-type argument-types function modifier*)
+   (method-name return-type argument-types function &key modifiers annotations)
    where method-name is a string, return-type and argument-types are strings or keywords for
    primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
-   (1+ (length argument-types)); the instance (`this') is passed in as the last argument.
+   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
 
    Field definitions are lists of the form
@@ -45 +46 @@
           (mapcar #'make-jvm-class-name interfaces))
     (dolist (m methods)
-      (destructuring-bind (name return-type argument-types function &rest flags) m
-          (let* ((argument-types (mapcar #'make-jvm-class-name argument-types))
-                 (argc (length argument-types))
-                 (return-type (if (keywordp return-type)
-                                  return-type
-                                  (make-jvm-class-name return-type)))
-                 (jmethod (make-jvm-method name return-type argument-types :flags (or flags '(:public))))
-                 (field-name (string (gensym name))))
-            (class-add-method class-file jmethod)
-            (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
-              (class-add-field class-file field)
-              (push (cons field-name function) method-implementation-fields))
-            (with-code-to-method (class-file jmethod)
-              ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
-              (dotimes (i (* 2 (1+ argc)))
-                (allocate-register nil))
-              ;;Box "this" (to be passed as the first argument to the Lisp function)
-              (aload 0)
-              (emit 'iconst_1) ;;true
-              (emit-invokestatic +abcl-java-object+ "getInstance"
-                                             (list +java-object+ :boolean) +lisp-object+)
-              (astore (1+ argc))
-              ;;Box each argument
-              (loop
-                 :for arg-type :in argument-types
-                 :for i :from 1
-                 :do (progn
-                       (cond
-                         ((keywordp arg-type)
-                          (error "Unsupported arg-type: ~A" arg-type))
-                         ((eq arg-type :int) :todo)
-                         (t (aload i)
-                            (emit 'iconst_1) ;;true
-                            (emit-invokestatic +abcl-java-object+ "getInstance"
-                                               (list +java-object+ :boolean) +lisp-object+)))
-                       (astore (+ i (1+ argc)))))
-              ;;Load the Lisp function from its static field
-              (emit-getstatic jvm-class-name field-name +lisp-object+)
-              (if (<= (1+ argc) call-registers-limit)
-                  (progn
-                    ;;Load the boxed this
-                    (aload (1+ argc))
-                    ;;Load each boxed argument
-                    (dotimes (i argc)
-                      (aload (+ argc 2 i))))
-                  (error "execute(LispObject[]) is currently not supported"))
-              (emit-call-execute (1+ (length argument-types)))
-              (cond
-                ((eq return-type :void)
-                 (emit 'pop)
-                 (emit 'return))
-                ((eq return-type :int)
-                 (emit-invokevirtual +lisp-object+ "intValue" nil :int)
-                 (emit 'ireturn))
-                ((keywordp return-type)
-                 (error "Unsupported return type: ~A" return-type))
-                (t
-                 (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
-                 (emit-checkcast return-type)
-                 (emit 'areturn)))))))
+      (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m
+        (let* ((argument-types (mapcar #'make-jvm-class-name argument-types))
+               (argc (length argument-types))
+               (return-type (if (keywordp return-type)
+                                return-type
+                                (make-jvm-class-name return-type)))
+               (jmethod (make-jvm-method name return-type argument-types :flags modifiers))
+               (field-name (string (gensym name))))
+          (class-add-method class-file jmethod)
+          (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
+            (class-add-field class-file field)
+            (push (cons field-name function) method-implementation-fields))
+          (when annotations
+            (method-add-attribute jmethod (make-runtime-visible-annotations-attribute
+                                           :list (mapcar #'parse-annotation annotations))))
+          (with-code-to-method (class-file jmethod)
+            ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
+            (dotimes (i (* 2 (1+ argc)))
+              (allocate-register nil))
+            ;;Box "this" (to be passed as the first argument to the Lisp function)
+            (aload 0)
+            (emit 'iconst_1) ;;true
+            (emit-invokestatic +abcl-java-object+ "getInstance"
+                               (list +java-object+ :boolean) +lisp-object+)
+            (astore (1+ argc))
+            ;;Box each argument
+            (loop
+               :for arg-type :in argument-types
+               :for i :from 1
+               :do (progn
+                     (cond
+                       ((keywordp arg-type)
+                        (error "Unsupported arg-type: ~A" arg-type))
+                       ((eq arg-type :int) :todo)
+                       (t (aload i)
+                          (emit 'iconst_1) ;;true
+                          (emit-invokestatic +abcl-java-object+ "getInstance"
+                                             (list +java-object+ :boolean) +lisp-object+)))
+                     (astore (+ i (1+ argc)))))
+            ;;Load the Lisp function from its static field
+            (emit-getstatic jvm-class-name field-name +lisp-object+)
+            (if (<= (1+ argc) call-registers-limit)
+                (progn
+                  ;;Load the boxed this
+                  (aload (1+ argc))
+                  ;;Load each boxed argument
+                  (dotimes (i argc)
+                    (aload (+ argc 2 i))))
+                (error "execute(LispObject[]) is currently not supported"))
+            (emit-call-execute (1+ (length argument-types)))
+            (cond
+              ((eq return-type :void)
+               (emit 'pop)
+               (emit 'return))
+              ((eq return-type :int)
+               (emit-invokevirtual +lisp-object+ "intValue" nil :int)
+               (emit 'ireturn))
+              ((jvm-class-name-p return-type)
+               (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
+               (emit-checkcast return-type)
+               (emit 'areturn))
+              (t
+               (error "Unsupported return type: ~A" return-type)))))))
     (when (null constructors)
       (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public))))
@@ -125 +129 @@
       jclass)))
 
+(defun parse-annotation (annotation)
+  annotation) ;;TODO
+
 #+example
 (java:jnew-runtime-class
@@ -131 +138 @@
  :methods (list
            (list "foo" :void '("java.lang.Object")
-                 (lambda (this that) (print (list this that))))
+                 (lambda (this that) (print (list this that)))
+                 :annotations (list (make-annotation :type "java.lang.Deprecated")))
            (list "bar" :int '("java.lang.Object")
                  (lambda (this that) (print (list this that)) 23))))