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

Last change on this file since 13727 was 13727, checked in by astalla, 9 years ago

Class writer: basic support for annotations (only without parameters)
Runtime-class: annotations on methods only, with no syntax sugar yet

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.2 KB
Line 
1(require "COMPILER-PASS2")
2(require "JVM-CLASS-FILE")
3
4(in-package :jvm)
5
6(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
7
8(defun java:jnew-runtime-class
9    (class-name &key (superclass (make-jvm-class-name "java.lang.Object"))
10     interfaces constructors methods fields (access-flags '(:public)))
11  "Creates and loads a Java class with methods calling Lisp closures
12   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
13   INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are
14   lists of constructor, method and field definitions.
15
16   Constructor definitions are lists of the form
17   (argument-types function &optional super-invocation-arguments)
18   where argument-types is a list of strings and function is a lisp function of
19   (1+ (length argument-types)) arguments; the instance (`this') is passed in as
20   the last argument. The optional super-invocation-arguments is a list of numbers
21   between 1 and (length argument-types), where the number k stands for the kth argument
22   to the just defined constructor. If present, the constructor of the superclass
23   will be called with the appropriate arguments. E.g., if the constructor definition is
24   ((\"java.lang.String\" \"int\") #'(lambda (string i this) ...) (2 1))
25   then the constructor of the superclass with argument types (int, java.lang.String) will
26   be called with the second and first arguments.
27
28   Method definitions are lists of the form
29   (method-name return-type argument-types function &key modifiers annotations)
30   where method-name is a string, return-type and argument-types are strings or keywords for
31   primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity
32   (1+ (length argument-types)); the instance (`this') is passed in as the first argument.
33
34   Field definitions are lists of the form
35   (field-name type modifier*)
36
37   If FILE-NAME is given, a .class file will be written; this is useful for debugging only."
38  (declare (ignorable constructors fields))
39  (let* ((jvm-class-name (make-jvm-class-name class-name))
40         (class-file (make-class-file jvm-class-name superclass access-flags))
41         (stream (sys::%make-byte-array-output-stream))
42         ;;TODO provide constructor in MemoryClassLoader
43         (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" ""))
44         method-implementation-fields)
45    (setf (class-file-interfaces class-file)
46          (mapcar #'make-jvm-class-name interfaces))
47    (dolist (m methods)
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)))))))
111    (when (null constructors)
112      (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public))))
113        (class-add-method class-file ctor)
114        (with-code-to-method (class-file ctor)
115          (aload 0)
116          (emit-invokespecial-init (class-file-superclass class-file) nil)
117          (emit 'return))))
118    (finalize-class-file class-file)
119    (write-class-file class-file stream)
120    (finish-output stream)
121    #+test-record-generated-class-file
122    (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8))
123      (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f))
124    (sys::put-memory-function memory-class-loader
125                              class-name (sys::%get-output-stream-bytes stream))
126    (let ((jclass (java:jcall "loadClass" memory-class-loader class-name)))
127      (dolist (method method-implementation-fields)
128        (setf (java:jfield jclass (car method)) (cdr method)))
129      jclass)))
130
131(defun parse-annotation (annotation)
132  annotation) ;;TODO
133
134#+example
135(java:jnew-runtime-class
136 "Foo"
137 :interfaces (list "java.lang.Comparable")
138 :methods (list
139           (list "foo" :void '("java.lang.Object")
140                 (lambda (this that) (print (list this that)))
141                 :annotations (list (make-annotation :type "java.lang.Deprecated")))
142           (list "bar" :int '("java.lang.Object")
143                 (lambda (this that) (print (list this that)) 23))))
144
145(provide "RUNTIME-CLASS")
Note: See TracBrowser for help on using the repository browser.