[armedbear-cvs] r13739 - trunk/abcl/src/org/armedbear/lisp
astalla at common-lisp.net
astalla at common-lisp.net
Mon Jan 9 22:55:38 UTC 2012
Author: astalla
Date: Mon Jan 9 14:55:37 2012
New Revision: 13739
Log:
Annotations in class-file:
- support for enum-value elements;
- rectified boolean valued elements (Z instead of B which is Byte)
Modified:
trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Jan 9 03:31:38 2012 (r13738)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Jan 9 14:55:37 2012 (r13739)
@@ -81,7 +81,7 @@
|#
(defstruct (jvm-class-name (:conc-name class-)
- (:constructor %make-jvm-class-name))
+ (:constructor %make-jvm-class-name))
"Used for class identification.
The caller should instantiate only one `class-name' per class, as they are
@@ -373,15 +373,19 @@
(defun pool-add-class (pool class)
"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)
"Returns the index of the constant-pool item which denotes a reference
@@ -1348,7 +1352,7 @@
type
elements)
-(defstruct annotation-element name value)
+(defstruct annotation-element (name "value") value)
(defstruct annotation-element-value tag finalizer writer)
@@ -1360,19 +1364,46 @@
(etypecase value
(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))))
+ (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-int (class-file-constants class) (if value 1 0))))))))
+ (pool-add-utf8 (class-file-constants class) value)))))))
(writer (lambda (self stream)
(write-u1 (annotation-element-value-tag self) stream)
(write-u2 (primitive-or-string-annotation-element-value self) stream)))))
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
attributes table of the ClassFile, field_info, and method_info structures. The
@@ -1388,10 +1419,7 @@
(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)))))
+ (pool-add-class (class-file-constants class) (annotation-type ann)))
(dolist (elem (annotation-elements ann))
(setf (annotation-element-name elem)
(pool-add-utf8 (class-file-constants class)
@@ -1405,7 +1433,9 @@
(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))))
+ (write-u2 (annotation-element-name elem) stream)
+ (funcall (annotation-element-value-writer (annotation-element-value elem))
+ (annotation-element-value elem) stream))))
#|
Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 9 03:31:38 2012 (r13738)
+++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 9 14:55:37 2012 (r13739)
@@ -1,6 +1,9 @@
(require "COMPILER-PASS2")
(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)
(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
@@ -138,7 +141,16 @@
:methods (list
(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))))
More information about the armedbear-cvs
mailing list