[PATCH 4/5] Runtime class improvements.

From faceaa2be78d92b6a6c43f5925fae926f9607bce Mon Sep 17 00:00:00 2001
Work in progress to get to a more functioning runtime class support.

- Make static functions and :int parameters work.
- Fix return conversion for null.
- Ensure that the same classloader is used.

  Because otherwise the name of the superclass couldn't be found as it's
  not cached anywhere.

  It would probably make sense to make the normal classloader a caching
  one, so that custom classes can be found by other parts of the (Java)
  system?
---
 src/org/armedbear/lisp/LispObject.java       |   3 +
 src/org/armedbear/lisp/Nil.java              |  15 +++
 src/org/armedbear/lisp/jvm-instructions.lisp |  27 ++++++
 src/org/armedbear/lisp/runtime-class.lisp    | 139 +++++++++++++++++++--------
 test/lisp/abcl/runtime-class.lisp            | 101 +++++++++----------
 5 files changed, 186 insertions(+), 99 deletions(-)
parent 11e463d2
......@@ -128,6 +128,9 @@ public class LispObject //extends Lisp
public Object javaInstance(Class<?> c)
{
String cn = c.getName();
if (cn.equals("java.lang.Boolean") || cn.equals("boolean"))
return Boolean.TRUE;
if (c.isAssignableFrom(getClass()))
return this;
return error(new LispError("The value " + princToString() +
......
......@@ -46,6 +46,21 @@ public final class Nil extends Symbol
initializeConstant(this);
}
@Override
public Object javaInstance()
{
return null;
}
@Override
public Object javaInstance(Class c)
{
String cn = c.getName();
if (cn.equals("java.lang.Boolean") || cn.equals("boolean"))
return Boolean.FALSE;
return javaInstance();
}
@Override
public LispObject typeOf()
{
......
......@@ -461,6 +461,24 @@
(3 (emit 'astore_3))
(t (emit 'astore index))))
(defknown iload (fixnum) t)
(defun iload (index)
(case index
(0 (emit 'iload_0))
(1 (emit 'iload_1))
(2 (emit 'iload_2))
(3 (emit 'iload_3))
(t (emit 'iload index))))
(defknown istore (fixnum) t)
(defun istore (index)
(case index
(0 (emit 'istore_0))
(1 (emit 'istore_1))
(2 (emit 'istore_2))
(3 (emit 'istore_3))
(t (emit 'istore index))))
(declaim (ftype (function (t) t) branch-p)
(inline branch-p))
(defun branch-p (opcode)
......@@ -571,6 +589,10 @@
13 ; fconst_2
14 ; dconst_0
15 ; dconst_1
26 ; iload_0
27 ; iload_1
28 ; iload_2
29 ; iload_3
42 ; aload_0
43 ; aload_1
44 ; aload_2
......@@ -580,6 +602,11 @@
48 ; faload
49 ; daload
50 ; aaload
54 ; istore
59 ; istore_0
60 ; istore_1
61 ; istore_2
62 ; istore_3
75 ; astore_0
76 ; astore_1
77 ; astore_2
......
......@@ -7,9 +7,13 @@
(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
(defun java::make-memory-class-loader (&optional (parent (java:get-current-classloader)))
(java:jnew "org.armedbear.lisp.MemoryClassLoader" parent))
(defun java:jnew-runtime-class
(class-name &rest args &key (superclass "java.lang.Object")
interfaces constructors methods fields (access-flags '(:public)) annotations)
interfaces constructors methods fields (access-flags '(:public)) annotations
(class-loader (java::make-memory-class-loader)))
"Creates and loads a Java class with methods calling Lisp closures
as given in METHODS. CLASS-NAME and SUPER-NAME are strings,
INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are
......@@ -31,12 +35,12 @@
(METHOD-NAME RETURN-TYPE ARGUMENT-TYPES FUNCTION &key MODIFIERS ANNOTATIONS)
where
METHOD-NAME is a string
where
METHOD-NAME is a string
RETURN-TYPE denotes the type of the object returned by the method
ARGUMENT-TYPES is a list of parameters to the method
The types are either strings naming fully qualified java classes or Lisp keywords referring to
The types are either strings naming fully qualified java classes or Lisp keywords referring to
primitive types (:void, :int, etc.).
FUNCTION is a Lisp function of minimum arity (1+ (length
......@@ -45,18 +49,37 @@
Field definitions are lists of the form (field-name type &key modifiers annotations)."
(declare (ignorable superclass interfaces constructors methods fields access-flags annotations))
(let* ((stream (sys::%make-byte-array-output-stream))
(current-class-loader (java:get-current-classloader))
(memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" current-class-loader)))
(let ((stream (sys::%make-byte-array-output-stream)))
(multiple-value-bind (class-file method-implementation-fields)
(apply #'java::%jnew-runtime-class class-name stream args)
(sys::put-memory-function memory-class-loader
(apply #'java::%jnew-runtime-class class-name stream :allow-other-keys T args)
(sys::put-memory-function class-loader
class-name (sys::%get-output-stream-bytes stream))
(let ((jclass (java:jcall "loadClass" memory-class-loader class-name)))
(let ((jclass (java:jcall "loadClass" class-loader class-name)))
(dolist (method method-implementation-fields)
(setf (java:jfield jclass (car method)) (cdr method)))
jclass))))
(defconstant +abcl-lisp-integer-object+ (make-jvm-class-name "org.armedbear.lisp.LispInteger"))
(defun box-arguments (argument-types offset all-argc)
;;Box each argument
(loop
:for arg-type :in argument-types
:for i :from offset
:do (progn
(cond
((eq arg-type :int)
(iload i)
(emit-invokestatic +abcl-lisp-integer-object+ "getInstance"
(list :int) +abcl-lisp-integer-object+))
((keywordp arg-type)
(error "Unsupported arg-type: ~A" arg-type))
(t (aload i)
(emit 'iconst_1) ;;true
(emit-invokestatic +abcl-java-object+ "getInstance"
(list +java-object+ :boolean) +lisp-object+)))
(astore (+ i all-argc)))))
(defun java::%jnew-runtime-class
(class-name stream &key (superclass "java.lang.Object")
interfaces constructors methods fields (access-flags '(:public)) annotations)
......@@ -78,7 +101,47 @@
(aload 0)
(emit-invokespecial-init (class-file-superclass class-file) nil)
(emit 'return)))
(error "constructors not supported"))
(dolist (constructor constructors)
(destructuring-bind (argument-types function
&key (modifiers '(:public)))
constructor
(let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
(argc (length argument-types))
(ctor (make-jvm-method :constructor :void argument-types :flags modifiers))
(field-name (string (gensym "CONSTRUCTOR")))
(all-argc (1+ argc)))
(class-add-method class-file ctor)
(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 ctor)
(dotimes (i (* 2 all-argc))
(allocate-register nil))
(aload 0)
(emit-invokespecial-init (class-file-superclass class-file) nil)
(aload 0)
(emit 'iconst_1) ;;true
(emit-invokestatic +abcl-java-object+ "getInstance"
(list +java-object+ :boolean) +lisp-object+)
(astore all-argc)
(box-arguments argument-types 1 all-argc)
;;Load the Lisp function from its static field
(emit-getstatic (class-file-class class-file) field-name +lisp-object+)
(if (<= all-argc call-registers-limit)
(progn
;;Load the boxed this
(aload all-argc)
;;Load each boxed argument
(dotimes (i argc)
(aload (+ i 1 all-argc))))
(error "execute(LispObject[]) is currently not supported"))
(emit-call-execute all-argc)
(emit 'return))))))
(finalize-class-file class-file)
(write-class-file class-file stream)
(finish-output stream)
......@@ -122,7 +185,8 @@
(emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean)
(emit 'ireturn))
((jvm-class-name-p return-type)
(emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
(emit 'ldc_w (pool-class return-type))
(emit-invokevirtual +lisp-object+ "javaInstance" (list +java-class+) +java-object+)
(emit-checkcast return-type)
(emit 'areturn))
(t
......@@ -130,14 +194,18 @@
(defun java::runtime-class-add-methods (class-file methods)
(let (method-implementation-fields)
(dolist (m methods)
(dolist (method methods)
(destructuring-bind (name return-type argument-types function
&key (modifiers '(:public)) annotations override) m
&key (modifiers '(:public)) annotations override)
method
(let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
(argc (length argument-types))
(return-type (java::canonicalize-java-type return-type))
(jmethod (make-jvm-method name return-type argument-types :flags modifiers))
(field-name (string (gensym name))))
(field-name (string (gensym name)))
(staticp (member :static modifiers))
(offset (if staticp 0 1))
(all-argc (+ argc offset)))
(class-add-method class-file jmethod)
(let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
(class-add-field class-file field)
......@@ -147,39 +215,28 @@
: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)))
(dotimes (i (* 2 all-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)))))
(unless staticp
;;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 all-argc))
(box-arguments argument-types offset all-argc)
;;Load the Lisp function from its static field
(emit-getstatic (class-file-class class-file) field-name +lisp-object+)
(if (<= (1+ argc) call-registers-limit)
(if (<= all-argc call-registers-limit)
(progn
;;Load the boxed this
(aload (1+ argc))
(unless staticp
(aload all-argc))
;;Load each boxed argument
(dotimes (i argc)
(aload (+ argc 2 i))))
(aload (+ i 1 all-argc))))
(error "execute(LispObject[]) is currently not supported"))
(emit-call-execute (1+ (length argument-types)))
(emit-call-execute all-argc)
(java::emit-unbox-and-return return-type))
(cond
((eq override t)
......
(in-package :abcl.test.lisp)
;; method with no arguments
(deftest runtime-class.1
(java:jnew-runtime-class
"Actor"
:fields `(("name" "java.lang.String"))
:methods `(("getName" "java.lang.String" nil
(lambda (this)
(java:jfield this "name")))))
t)
(java:jclass-name
(java:jnew-runtime-class
"Actor"
:fields '(("name" "java.lang.String" :getter NIL))
:methods '(("getName" "java.lang.String" NIL
(lambda (this)
(java:jfield "name" this))))))
"Actor")
;; method with primitive type
(deftest runtime-class.2
(java:jnew-runtime-class
"Actor"
:fields `(("name" "java.lang.String"))
:methods `(("getName" "java.lang.String" (:int)
(lambda (this)
(java:jfield this "name")))))
t)
;; inheritance of type
(java:jclass-name
(java:jnew-runtime-class
"Actor"
:fields '(("name" "java.lang.String" :getter NIL))
:methods '(("getName" "java.lang.String" (:int)
(lambda (this x)
(declare (ignore x))
(java:jfield "name" this))))))
"Actor")
;; inheritance of type
(deftest runtime-class.3
(progn
(java:jnew-runtime-class
(let ((class-loader (java::make-memory-class-loader)))
(java:jnew-runtime-class
"foo.Actor"
:fields `(("name" "java.lang.String")))
(java:jnew-runtime-class
"foo.StageActor"
:superclass "foo.Actor"
:fields (list '("givenName" "java.lang.String"))))
t)
#|
// Simple constructor test
public class Actor {
String name;
public Actor(String name) {
this.name = name;
}
public String getName() {
return name;
}
}
|#
:fields '(("name" "java.lang.String"))
:class-loader class-loader)
(java:jclass-name
(java:jnew-runtime-class
"foo.StageActor"
:superclass "foo.Actor"
:fields '(("givenName" "java.lang.String"))
:class-loader class-loader)))
"foo.StageActor")
;; constructor
(deftest runtime-class.4
(java:jnew-runtime-class
"Actor"
:constructors `(("java.lang.String")
(lambda (name)
(setf (jfield this "name")
name)))
:methods `(("getName" "java.lang.String" ("java.lang.String") ;; no-arg methods not working
(lambda (this dummy)
(declare (ignore dummy))
(java:jfield this "name"))))
:fields `(("name" "java.lang.String")))
t)
(java:jcall "getName"
(java:jnew
(java:jnew-runtime-class
"Actor"
:constructors '((("java.lang.String")
(lambda (this name)
(setf (java:jfield "name" this) name))))
:methods '(("getName" "java.lang.String" NIL
(lambda (this)
(java:jfield "name" this))))
:fields '(("name" "java.lang.String" :getter NIL)))
"Someone"))
"Someone")
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment