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

Last change on this file since 13710 was 13710, checked in by astalla, 12 years ago

First stab at restoring runtime-class.
Supported: extending a Java class, implementing interfaces, defining methods
of up to 7 non-primitive arguments returning void or a non-primitive object.
Unsupported: everything else, including fields, constructors, annotations,
primitive arguments and return values, and the LispObject[] call convention
for functions with more than 8 arguments.

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