Changeset 13739

Timestamp:

01/09/12 22:55:37 (11 years ago)

Author:

astalla

Message:

Annotations in class-file:

• support for enum-value elements;
• rectified boolean valued elements (Z instead of B which is Byte)

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• jvm-class-file.lisp (modified) (7 diffs)
• runtime-class.lisp (modified) (2 diffs)

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

@@ -82 +82 @@
 
 (defstruct (jvm-class-name (:conc-name class-)
-         (:constructor %make-jvm-class-name))
+                           (:constructor %make-jvm-class-name))
   "Used for class identification.
 
@@ -374 +374 @@
   "Returns the index of the constant-pool class item for `class'.
 
-`class' must be an instance of `class-name'."
-  (let ((entry (gethash class (pool-entries pool))))
-    (unless entry
-      (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
-        (setf entry
-              (make-constant-class (incf (pool-index pool)) utf8)
-              (gethash class (pool-entries pool)) entry))
-      (push entry (pool-entries-list pool)))
-    (constant-index entry)))
+`class' must be an instance of `class-name' or a string (which will be converted
+to a `class-name')."
+  (let ((class (if (jvm-class-name-p class)
+                   class
+                   (make-jvm-class-name class))))
+    (let ((entry (gethash class (pool-entries pool))))
+      (unless entry
+        (let ((utf8 (pool-add-utf8 pool (class-name-internal class))))
+          (setf entry
+                (make-constant-class (incf (pool-index pool)) utf8)
+                (gethash class (pool-entries pool)) entry))
+        (push entry (pool-entries-list pool)))
+      (constant-index entry))))
 
 (defun pool-add-field-ref (pool class name type)
@@ -1349 +1353 @@
   elements)
 
-(defstruct annotation-element name value)
+(defstruct annotation-element (name "value") value)
 
 (defstruct annotation-element-value tag finalizer writer)
@@ -1361 +1365 @@
                                         (boolean
                                          (setf (annotation-element-value-tag self)
-                                               (char-code #\B)
+                                               (char-code #\Z)
                                                (primitive-or-string-annotation-element-value self)
-                                               (pool-add-int (class-file-constants class) (if value 1 0))))))))
+                                               (pool-add-int (class-file-constants class) (if value 1 0))))
+                                        (fixnum
+                                         (setf (annotation-element-value-tag self)
+                                               (char-code #\I)
+                                               (primitive-or-string-annotation-element-value self)
+                                               (pool-add-int (class-file-constants class) value)))
+                                        (string
+                                         (setf (annotation-element-value-tag self)
+                                               (char-code #\s)
+                                               (primitive-or-string-annotation-element-value self)
+                                               (pool-add-utf8 (class-file-constants class) value)))))))
                        (writer (lambda (self stream)
                                  (write-u1 (annotation-element-value-tag self) stream)
@@ -1369 +1383 @@
   value)
 
+(defstruct (enum-value-annotation-element-value
+             (:conc-name enum-value-annotation-element-)
+             (:include annotation-element-value
+                       (finalizer (lambda (self class)
+                                    (setf (annotation-element-value-tag self)
+                                          (char-code #\e)
+                                          (enum-value-annotation-element-type self)
+                                          (pool-add-utf8 (class-file-constants class)
+                                                         (enum-value-annotation-element-type self)) ;;Binary name as string
+                                          (enum-value-annotation-element-name self)
+                                          (pool-add-utf8 (class-file-constants class)
+                                                         (enum-value-annotation-element-name self)))))
+                       (writer (lambda (self stream)
+                                 (write-u1 (annotation-element-value-tag self) stream)
+                                 (write-u2 (enum-value-annotation-element-type self) stream)
+                                 (write-u2 (enum-value-annotation-element-name self) stream)))))
+  type
+  name)
+
 (defstruct (runtime-visible-annotations-attribute
              (:include annotations-attribute
-                       (name "RuntimeVisibleAnnotations")
-                       (finalizer #'finalize-annotations)
-                       (writer #'write-annotations)))
+                       (name "RuntimeVisibleAnnotations")))
   "4.8.15 The RuntimeVisibleAnnotations attribute
 The RuntimeVisibleAnnotations attribute is a variable length attribute in the
@@ -1389 +1420 @@
   (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)))))
+          (pool-add-class (class-file-constants class) (annotation-type ann)))
     (dolist (elem (annotation-elements ann))
       (setf (annotation-element-name elem)
@@ -1406 +1434 @@
     (write-u2 (length (annotation-elements annotation)) stream)
     (dolist (elem (reverse (annotation-elements annotation)))
-      (funcall (annotation-element-value-writer elem) elem stream))))
+      (write-u2 (annotation-element-name elem) stream)
+      (funcall (annotation-element-value-writer (annotation-element-value elem))
+               (annotation-element-value elem) stream))))
 
 #|

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

@@ -2 +2 @@
 (require "JVM-CLASS-FILE")
 
+;;The package is set to :jvm for convenience, since most of the symbols used
+;;here come from that package. However, the functions we're definining belong
+;;to the :java package.
 (in-package :jvm)
 
@@ -139 +142 @@
            (list "foo" :void '("java.lang.Object")
                  (lambda (this that) (print (list this that)))
-                 :annotations (list (make-annotation :type "java.lang.Deprecated")))
+                 :annotations (list (make-annotation :type "java.lang.Deprecated")
+                                    (make-annotation :type "java.lang.annotation.Retention"
+                                                     :elements (list (make-annotation-element
+                                                                      :value (make-enum-value-annotation-element-value
+                                                                              :type "java.lang.annotation.RetentionPolicy"
+                                                                              :name "RUNTIME"))))
+                                    (make-annotation :type "javax.xml.bind.annotation.XmlAttribute"
+                                                     :elements (list (make-annotation-element
+                                                                      :name "required"
+                                                                      :value (make-primitive-or-string-annotation-element-value :value t))))))
            (list "bar" :int '("java.lang.Object")
                  (lambda (this that) (print (list this that)) 23))))