[armedbear-cvs] r13755 - trunk/abcl/src/org/armedbear/lisp
astalla at common-lisp.net
astalla at common-lisp.net
Tue Jan 10 23:07:59 UTC 2012
Author: astalla
Date: Tue Jan 10 15:07:58 2012
New Revision: 13755
Log:
[jvm-class-file]
Coalesce annotation-element and annotation-element-value into a single struct for simplicity.
Array- and annotation-valued elements.
Small refactor of annotation finalizers and writers.
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 Tue Jan 10 13:06:39 2012 (r13754)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jan 10 15:07:58 2012 (r13755)
@@ -1352,54 +1352,72 @@
type
elements)
-(defstruct annotation-element (name "value") value)
+(defstruct annotation-element (name "value") tag finalizer writer)
-(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
+(defstruct (primitive-or-string-annotation-element
+ (:include annotation-element
(finalizer (lambda (self class)
(let ((value (primitive-or-string-annotation-element-value self)))
(etypecase value
(boolean
- (setf (annotation-element-value-tag self)
+ (setf (annotation-element-tag self)
(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)
+ (setf (annotation-element-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)
+ (setf (annotation-element-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)
+ (write-u1 (annotation-element-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
+(defstruct (enum-value-annotation-element
+ (:include annotation-element
+ (tag (char-code #\e))
(finalizer (lambda (self class)
- (setf (annotation-element-value-tag self)
- (char-code #\e)
- (enum-value-annotation-element-type self)
+ (setf (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)
+ (enum-value-annotation-element-value self)
(pool-add-utf8 (class-file-constants class)
- (enum-value-annotation-element-name self)))))
+ (enum-value-annotation-element-value self)))))
(writer (lambda (self stream)
- (write-u1 (annotation-element-value-tag self) stream)
+ (write-u1 (annotation-element-tag self) stream)
(write-u2 (enum-value-annotation-element-type self) stream)
- (write-u2 (enum-value-annotation-element-name self) stream)))))
+ (write-u2 (enum-value-annotation-element-value self) stream)))))
type
- name)
+ value)
+
+(defstruct (annotation-value-annotation-element
+ (:include annotation-element
+ (tag (char-code #\@))
+ (finalizer (lambda (self class)
+ (finalize-annotation (annotation-value-annotation-element-value self) class)))
+ (writer (lambda (self stream)
+ (write-u1 (annotation-element-tag self) stream)
+ (write-annotation (annotation-value-annotation-element-value self) stream)))))
+ value)
+
+(defstruct (array-annotation-element
+ (:include annotation-element
+ (tag (char-code #\[))
+ (finalizer (lambda (self class)
+ (dolist (elem (array-annotation-element-values self))
+ (finalize-annotation-element elem class))))
+ (writer (lambda (self stream)
+ (write-u1 (annotation-element-tag self) stream)
+ (write-u2 (length (array-annotation-element-values self)) stream)
+ (dolist (elem (array-annotation-element-values self))
+ (write-annotation-element elem stream))))))
+ values) ;;In proper order
(defstruct (runtime-visible-annotations-attribute
(:include annotations-attribute
@@ -1418,24 +1436,38 @@
(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) (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))))
+ (finalize-annotation ann class)))
+
+(defun finalize-annotation (ann class)
+ (setf (annotation-type ann)
+ (pool-add-class (class-file-constants class) (annotation-type ann)))
+ (dolist (elem (annotation-elements ann))
+ (finalize-annotation-element elem class)))
+
+(defun finalize-annotation-element (elem class)
+ (when (annotation-element-name elem)
+ (setf (annotation-element-name elem)
+ (pool-add-utf8 (class-file-constants class)
+ (annotation-element-name elem))))
+ (funcall (annotation-element-finalizer elem)
+ 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)))
- (write-u2 (annotation-element-name elem) stream)
- (funcall (annotation-element-value-writer (annotation-element-value elem))
- (annotation-element-value elem) stream))))
+ (write-annotation annotation stream)))
+
+(defun write-annotation (annotation stream)
+ (write-u2 (annotation-type annotation) stream)
+ (write-u2 (length (annotation-elements annotation)) stream)
+ (dolist (elem (reverse (annotation-elements annotation)))
+ (write-annotation-element elem stream)))
+
+(defun write-annotation-element (elem stream)
+ (when (annotation-element-name elem)
+ (write-u2 (annotation-element-name elem) stream))
+ (funcall (annotation-element-writer elem)
+ elem stream))
#|
Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 10 13:06:39 2012 (r13754)
+++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 10 15:07:58 2012 (r13755)
@@ -143,14 +143,13 @@
(lambda (this that) (print (list this that)))
: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"))))
+ :elements (list (make-enum-value-annotation-element
+ :type "java.lang.annotation.RetentionPolicy"
+ :value "RUNTIME")))
(make-annotation :type "javax.xml.bind.annotation.XmlAttribute"
- :elements (list (make-annotation-element
+ :elements (list (make-primitive-or-string-annotation-element
:name "required"
- :value (make-primitive-or-string-annotation-element-value :value t))))))
+ :value t)))))
(list "bar" :int '("java.lang.Object")
(lambda (this that) (print (list this that)) 23))))
More information about the armedbear-cvs
mailing list