source: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp @ 13764

Last change on this file since 13764 was 13764, checked in by astalla, 11 years ago

More value types for primitive annotation elements.
Syntax sugar for annotations in runtime-class.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.0 KB
1(require "COMPILER-PASS2")
2(require "JVM-CLASS-FILE")
4;;The package is set to :jvm for convenience, since most of the symbols used
5;;here come from that package. However, the functions we're definining belong
6;;to the :java package.
7(in-package :jvm)
9(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
11(defun java:jnew-runtime-class
12    (class-name &key (superclass (make-jvm-class-name "java.lang.Object"))
13     interfaces constructors methods fields (access-flags '(:public)))
14  "Creates and loads a Java class with methods calling Lisp closures
15   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
16   INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are
17   lists of constructor, method and field definitions.
19   Constructor definitions are lists of the form
20   (argument-types function &optional super-invocation-arguments)
21   where argument-types is a list of strings and function is a lisp function of
22   (1+ (length argument-types)) arguments; the instance (`this') is passed in as
23   the last argument. The optional super-invocation-arguments is a list of numbers
24   between 1 and (length argument-types), where the number k stands for the kth argument
25   to the just defined constructor. If present, the constructor of the superclass
26   will be called with the appropriate arguments. E.g., if the constructor definition is
27   ((\"java.lang.String\" \"int\") #'(lambda (string i this) ...) (2 1))
28   then the constructor of the superclass with argument types (int, java.lang.String) will
29   be called with the second and first arguments.
31   Method definitions are lists of the form
32   (method-name return-type argument-types function &key modifiers annotations)
33   where method-name is a string, return-type and argument-types are strings or keywords for
34   primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
35   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
37   Field definitions are lists of the form
38   (field-name type modifier*)
40   If FILE-NAME is given, a .class file will be written; this is useful for debugging only."
41  (declare (ignorable constructors fields))
42  (let* ((jvm-class-name (make-jvm-class-name class-name))
43         (class-file (make-class-file jvm-class-name superclass access-flags))
44         (stream (sys::%make-byte-array-output-stream))
45         ;;TODO provide constructor in MemoryClassLoader
46         (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" ""))
47         method-implementation-fields)
48    (setf (class-file-interfaces class-file)
49          (mapcar #'make-jvm-class-name interfaces))
50    (dolist (m methods)
51      (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m
52        (let* ((argument-types (mapcar #'make-jvm-class-name argument-types))
53               (argc (length argument-types))
54               (return-type (if (keywordp return-type)
55                                return-type
56                                (make-jvm-class-name return-type)))
57               (jmethod (make-jvm-method name return-type argument-types :flags modifiers))
58               (field-name (string (gensym name))))
59          (class-add-method class-file jmethod)
60          (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
61            (class-add-field class-file field)
62            (push (cons field-name function) method-implementation-fields))
63          (when annotations
64            (method-add-attribute jmethod (make-runtime-visible-annotations-attribute
65                                           :list (mapcar #'parse-annotation annotations))))
66          (with-code-to-method (class-file jmethod)
67            ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
68            (dotimes (i (* 2 (1+ argc)))
69              (allocate-register nil))
70            ;;Box "this" (to be passed as the first argument to the Lisp function)
71            (aload 0)
72            (emit 'iconst_1) ;;true
73            (emit-invokestatic +abcl-java-object+ "getInstance"
74                               (list +java-object+ :boolean) +lisp-object+)
75            (astore (1+ argc))
76            ;;Box each argument
77            (loop
78               :for arg-type :in argument-types
79               :for i :from 1
80               :do (progn
81                     (cond
82                       ((keywordp arg-type)
83                        (error "Unsupported arg-type: ~A" arg-type))
84                       ((eq arg-type :int) :todo)
85                       (t (aload i)
86                          (emit 'iconst_1) ;;true
87                          (emit-invokestatic +abcl-java-object+ "getInstance"
88                                             (list +java-object+ :boolean) +lisp-object+)))
89                     (astore (+ i (1+ argc)))))
90            ;;Load the Lisp function from its static field
91            (emit-getstatic jvm-class-name field-name +lisp-object+)
92            (if (<= (1+ argc) call-registers-limit)
93                (progn
94                  ;;Load the boxed this
95                  (aload (1+ argc))
96                  ;;Load each boxed argument
97                  (dotimes (i argc)
98                    (aload (+ argc 2 i))))
99                (error "execute(LispObject[]) is currently not supported"))
100            (emit-call-execute (1+ (length argument-types)))
101            (cond
102              ((eq return-type :void)
103               (emit 'pop)
104               (emit 'return))
105              ((eq return-type :int)
106               (emit-invokevirtual +lisp-object+ "intValue" nil :int)
107               (emit 'ireturn))
108              ((jvm-class-name-p return-type)
109               (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
110               (emit-checkcast return-type)
111               (emit 'areturn))
112              (t
113               (error "Unsupported return type: ~A" return-type)))))))
114    (when (null constructors)
115      (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public))))
116        (class-add-method class-file ctor)
117        (with-code-to-method (class-file ctor)
118          (aload 0)
119          (emit-invokespecial-init (class-file-superclass class-file) nil)
120          (emit 'return))))
121    (finalize-class-file class-file)
122    (write-class-file class-file stream)
123    (finish-output stream)
124    #+test-record-generated-class-file
125    (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8))
126      (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f))
127    (sys::put-memory-function memory-class-loader
128                              class-name (sys::%get-output-stream-bytes stream))
129    (let ((jclass (java:jcall "loadClass" memory-class-loader class-name)))
130      (dolist (method method-implementation-fields)
131        (setf (java:jfield jclass (car method)) (cdr method)))
132      jclass)))
134(defun parse-annotation (annotation)
135  (when (annotation-p annotation)
136    (return-from parse-annotation annotation))
137  (destructuring-bind (class &rest elements) (if (listp annotation) annotation (list annotation))
138    (let (actual-elements)
139      (dolist (elem elements)
140        (push (parse-annotation-element elem) actual-elements))
141      (make-annotation :type class :elements (nreverse actual-elements)))))
143(defun parse-annotation-element (elem)
144  (cond
145    ((annotation-element-p elem) elem)
146    ((atom elem) (make-primitive-or-string-annotation-element :name nil :value elem))
147    ((keywordp (car elem)) (parse-annotation-element `("value" ,@elem)))
148    (t
149     (destructuring-bind (name &key value enum annotation) elem
150       (cond
151         (enum (make-enum-value-annotation-element :name name :type enum :value value))
152         (annotation
153          (make-annotation-value-annotation-element :name name :value (parse-annotation annotation)))
154         ((listp value)
155          (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value)))
156         (t (make-primitive-or-string-annotation-element :name name :value value)))))))
160 "Foo"
161 :interfaces (list "java.lang.Comparable")
162 :methods (list
163           (list "foo" :void '("java.lang.Object")
164                 (lambda (this that) (print (list this that)))
165                 :annotations (list "java.lang.Deprecated"
166                                    '("java.lang.annotation.Retention"
167                                      (:enum "java.lang.annotation.RetentionPolicy" :value "RUNTIME"))
168                                    '("javax.xml.bind.annotation.XmlAttribute" ("required" :value t))
169                                    '("com.manydesigns.portofino.system.model.users.annotations.RequiresPermissions"
170                                      ("level"
171                                       :enum "com.manydesigns.portofino.model.pages.AccessLevel"
172                                       :value "EDIT")
173                                      ("permissions" :value ("foo" "bar")))))
174           (list "bar" :int '("java.lang.Object")
175                 (lambda (this that) (print (list this that)) 23))))
177(provide "RUNTIME-CLASS")
Note: See TracBrowser for help on using the repository browser.