[armedbear-cvs] r13727 - trunk/abcl/src/org/armedbear/lisp
astalla at common-lisp.net
astalla at common-lisp.net
Sat Jan 7 23:09:32 UTC 2012
Author: astalla
Date: Sat Jan 7 15:09:30 2012
New Revision: 13727
Log:
Class writer: basic support for annotations (only without parameters)
Runtime-class: annotations on methods only, with no syntax sugar yet
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 Fri Jan 6 14:45:48 2012 (r13726)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jan 7 15:09:30 2012 (r13727)
@@ -1321,6 +1321,92 @@
(write-u2 (local-descriptor local-variable) stream)
(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))))
+
#|
;; this is the minimal sequence we need to support:
Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Fri Jan 6 14:45:48 2012 (r13726)
+++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Sat Jan 7 15:09:30 2012 (r13727)
@@ -1,4 +1,5 @@
(require "COMPILER-PASS2")
+(require "JVM-CLASS-FILE")
(in-package :jvm)
@@ -25,10 +26,10 @@
be called with the second and first arguments.
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
(field-name type modifier*)
@@ -44,66 +45,69 @@
(setf (class-file-interfaces class-file)
(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))))
(class-add-method class-file ctor)
@@ -124,13 +128,17 @@
(setf (java:jfield jclass (car method)) (cdr method)))
jclass)))
+(defun parse-annotation (annotation)
+ annotation) ;;TODO
+
#+example
(java:jnew-runtime-class
"Foo"
:interfaces (list "java.lang.Comparable")
: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))))
More information about the armedbear-cvs
mailing list