Changeset 13727


Ignore:
Timestamp:
01/07/12 23:09:30 (10 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:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r13535 r13727  
    13221322    (write-u2 (local-index local-variable) stream)))
    13231323
     1324;;Annotations
     1325
     1326(defstruct (annotations-attribute
     1327             (:conc-name annotations-)
     1328             (:include attribute
     1329                       ;;Name is to be provided by subtypes
     1330                       (finalizer #'finalize-annotations)
     1331                       (writer #'write-annotations)))
     1332  "An attribute of a class, method or field, containing a list of annotations.
     1333This structure serves as the abstract supertype of concrete annotations types."
     1334  list ;; a list of annotation structures, in reverse order
     1335  )
     1336
     1337(defstruct annotation
     1338  "Each value of the annotations table represents a single runtime-visible annotation on a program element.
     1339   The annotation structure has the following format:
     1340     annotation {
     1341       u2 type_index;
     1342       u2 num_element_value_pairs;
     1343       {
     1344         u2 element_name_index;
     1345         element_value value;
     1346       } element_value_pairs[num_element_value_pairs]
     1347     }"
     1348  type
     1349  elements)
     1350
     1351(defstruct annotation-element name value)
     1352
     1353(defstruct annotation-element-value tag finalizer writer)
     1354
     1355(defstruct (primitive-or-string-annotation-element-value
     1356             (:conc-name primitive-or-string-annotation-element-)
     1357             (:include annotation-element-value
     1358                       (finalizer (lambda (self class)
     1359                                    (let ((value (primitive-or-string-annotation-element-value self)))
     1360                                      (etypecase value
     1361                                        (boolean
     1362                                         (setf (annotation-element-value-tag self)
     1363                                               (char-code #\B)
     1364                                               (primitive-or-string-annotation-element-value self)
     1365                                               (pool-add-int (class-file-constants class) (if value 1 0))))))))
     1366                       (writer (lambda (self stream)
     1367                                 (write-u1 (annotation-element-value-tag self) stream)
     1368                                 (write-u2 (primitive-or-string-annotation-element-value self) stream)))))
     1369  value)
     1370
     1371(defstruct (runtime-visible-annotations-attribute
     1372             (:include annotations-attribute
     1373                       (name "RuntimeVisibleAnnotations")
     1374                       (finalizer #'finalize-annotations)
     1375                       (writer #'write-annotations)))
     1376  "4.8.15 The RuntimeVisibleAnnotations attribute
     1377The RuntimeVisibleAnnotations attribute is a variable length attribute in the
     1378attributes table of the ClassFile, field_info, and method_info structures. The
     1379RuntimeVisibleAnnotations attribute records runtime-visible Java program-
     1380ming language annotations on the corresponding class, method, or field. Each
     1381ClassFile, field_info, and method_info structure may contain at most one
     1382RuntimeVisibleAnnotations attribute, which records all the runtime-visible
     1383Java programming language annotations on the corresponding program element.
     1384The JVM must make these annotations available so they can be returned by the
     1385appropriate reflective APIs.")
     1386
     1387(defun finalize-annotations (annotations code class)
     1388  (declare (ignore code))
     1389  (dolist (ann (annotations-list annotations))
     1390    (setf (annotation-type ann)
     1391          (pool-add-class (class-file-constants class)
     1392                          (if (jvm-class-name-p (annotation-type ann))
     1393                              (annotation-type ann)
     1394                              (make-jvm-class-name (annotation-type ann)))))
     1395    (dolist (elem (annotation-elements ann))
     1396      (setf (annotation-element-name elem)
     1397            (pool-add-utf8 (class-file-constants class)
     1398                           (annotation-element-name elem)))
     1399      (funcall (annotation-element-value-finalizer (annotation-element-value elem))
     1400               (annotation-element-value elem) class))))
     1401
     1402(defun write-annotations (annotations stream)
     1403  (write-u2 (length (annotations-list annotations)) stream)
     1404  (dolist (annotation (reverse (annotations-list annotations)))
     1405    (write-u2 (annotation-type annotation) stream)
     1406    (write-u2 (length (annotation-elements annotation)) stream)
     1407    (dolist (elem (reverse (annotation-elements annotation)))
     1408      (funcall (annotation-element-value-writer elem) elem stream))))
     1409
    13241410#|
    13251411
  • trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp

    r13710 r13727  
    11(require "COMPILER-PASS2")
     2(require "JVM-CLASS-FILE")
    23
    34(in-package :jvm)
     
    2627
    2728   Method definitions are lists of the form
    28    (method-name return-type argument-types function modifier*)
     29   (method-name return-type argument-types function &key modifiers annotations)
    2930   where method-name is a string, return-type and argument-types are strings or keywords for
    3031   primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
    31    (1+ (length argument-types)); the instance (`this') is passed in as the last argument.
     32   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
    3233
    3334   Field definitions are lists of the form
     
    4546          (mapcar #'make-jvm-class-name interfaces))
    4647    (dolist (m methods)
    47       (destructuring-bind (name return-type argument-types function &rest flags) m
    48           (let* ((argument-types (mapcar #'make-jvm-class-name argument-types))
    49                  (argc (length argument-types))
    50                  (return-type (if (keywordp return-type)
    51                                   return-type
    52                                   (make-jvm-class-name return-type)))
    53                  (jmethod (make-jvm-method name return-type argument-types :flags (or flags '(:public))))
    54                  (field-name (string (gensym name))))
    55             (class-add-method class-file jmethod)
    56             (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
    57               (class-add-field class-file field)
    58               (push (cons field-name function) method-implementation-fields))
    59             (with-code-to-method (class-file jmethod)
    60               ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
    61               (dotimes (i (* 2 (1+ argc)))
    62                 (allocate-register nil))
    63               ;;Box "this" (to be passed as the first argument to the Lisp function)
    64               (aload 0)
    65               (emit 'iconst_1) ;;true
    66               (emit-invokestatic +abcl-java-object+ "getInstance"
    67                                              (list +java-object+ :boolean) +lisp-object+)
    68               (astore (1+ argc))
    69               ;;Box each argument
    70               (loop
    71                  :for arg-type :in argument-types
    72                  :for i :from 1
    73                  :do (progn
    74                        (cond
    75                          ((keywordp arg-type)
    76                           (error "Unsupported arg-type: ~A" arg-type))
    77                          ((eq arg-type :int) :todo)
    78                          (t (aload i)
    79                             (emit 'iconst_1) ;;true
    80                             (emit-invokestatic +abcl-java-object+ "getInstance"
    81                                                (list +java-object+ :boolean) +lisp-object+)))
    82                        (astore (+ i (1+ argc)))))
    83               ;;Load the Lisp function from its static field
    84               (emit-getstatic jvm-class-name field-name +lisp-object+)
    85               (if (<= (1+ argc) call-registers-limit)
    86                   (progn
    87                     ;;Load the boxed this
    88                     (aload (1+ argc))
    89                     ;;Load each boxed argument
    90                     (dotimes (i argc)
    91                       (aload (+ argc 2 i))))
    92                   (error "execute(LispObject[]) is currently not supported"))
    93               (emit-call-execute (1+ (length argument-types)))
    94               (cond
    95                 ((eq return-type :void)
    96                  (emit 'pop)
    97                  (emit 'return))
    98                 ((eq return-type :int)
    99                  (emit-invokevirtual +lisp-object+ "intValue" nil :int)
    100                  (emit 'ireturn))
    101                 ((keywordp return-type)
    102                  (error "Unsupported return type: ~A" return-type))
    103                 (t
    104                  (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
    105                  (emit-checkcast return-type)
    106                  (emit 'areturn)))))))
     48      (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m
     49        (let* ((argument-types (mapcar #'make-jvm-class-name argument-types))
     50               (argc (length argument-types))
     51               (return-type (if (keywordp return-type)
     52                                return-type
     53                                (make-jvm-class-name return-type)))
     54               (jmethod (make-jvm-method name return-type argument-types :flags modifiers))
     55               (field-name (string (gensym name))))
     56          (class-add-method class-file jmethod)
     57          (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
     58            (class-add-field class-file field)
     59            (push (cons field-name function) method-implementation-fields))
     60          (when annotations
     61            (method-add-attribute jmethod (make-runtime-visible-annotations-attribute
     62                                           :list (mapcar #'parse-annotation annotations))))
     63          (with-code-to-method (class-file jmethod)
     64            ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
     65            (dotimes (i (* 2 (1+ argc)))
     66              (allocate-register nil))
     67            ;;Box "this" (to be passed as the first argument to the Lisp function)
     68            (aload 0)
     69            (emit 'iconst_1) ;;true
     70            (emit-invokestatic +abcl-java-object+ "getInstance"
     71                               (list +java-object+ :boolean) +lisp-object+)
     72            (astore (1+ argc))
     73            ;;Box each argument
     74            (loop
     75               :for arg-type :in argument-types
     76               :for i :from 1
     77               :do (progn
     78                     (cond
     79                       ((keywordp arg-type)
     80                        (error "Unsupported arg-type: ~A" arg-type))
     81                       ((eq arg-type :int) :todo)
     82                       (t (aload i)
     83                          (emit 'iconst_1) ;;true
     84                          (emit-invokestatic +abcl-java-object+ "getInstance"
     85                                             (list +java-object+ :boolean) +lisp-object+)))
     86                     (astore (+ i (1+ argc)))))
     87            ;;Load the Lisp function from its static field
     88            (emit-getstatic jvm-class-name field-name +lisp-object+)
     89            (if (<= (1+ argc) call-registers-limit)
     90                (progn
     91                  ;;Load the boxed this
     92                  (aload (1+ argc))
     93                  ;;Load each boxed argument
     94                  (dotimes (i argc)
     95                    (aload (+ argc 2 i))))
     96                (error "execute(LispObject[]) is currently not supported"))
     97            (emit-call-execute (1+ (length argument-types)))
     98            (cond
     99              ((eq return-type :void)
     100               (emit 'pop)
     101               (emit 'return))
     102              ((eq return-type :int)
     103               (emit-invokevirtual +lisp-object+ "intValue" nil :int)
     104               (emit 'ireturn))
     105              ((jvm-class-name-p return-type)
     106               (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
     107               (emit-checkcast return-type)
     108               (emit 'areturn))
     109              (t
     110               (error "Unsupported return type: ~A" return-type)))))))
    107111    (when (null constructors)
    108112      (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public))))
     
    125129      jclass)))
    126130
     131(defun parse-annotation (annotation)
     132  annotation) ;;TODO
     133
    127134#+example
    128135(java:jnew-runtime-class
     
    131138 :methods (list
    132139           (list "foo" :void '("java.lang.Object")
    133                  (lambda (this that) (print (list this that))))
     140                 (lambda (this that) (print (list this that)))
     141                 :annotations (list (make-annotation :type "java.lang.Deprecated")))
    134142           (list "bar" :int '("java.lang.Object")
    135143                 (lambda (this that) (print (list this that)) 23))))
Note: See TracChangeset for help on using the changeset viewer.