>From faceaa2be78d92b6a6c43f5925fae926f9607bce Mon Sep 17 00:00:00 2001 From: Olof-Joachim Frahm Date: Sat, 28 Nov 2015 01:32:20 +0000 Subject: [PATCH 4/5] Runtime class improvements. 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(-) diff --git a/src/org/armedbear/lisp/LispObject.java b/src/org/armedbear/lisp/LispObject.java index ed92a5a..e12e82a 100644 --- a/src/org/armedbear/lisp/LispObject.java +++ b/src/org/armedbear/lisp/LispObject.java @@ -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() + diff --git a/src/org/armedbear/lisp/Nil.java b/src/org/armedbear/lisp/Nil.java index 17f6787..eb9d21a 100644 --- a/src/org/armedbear/lisp/Nil.java +++ b/src/org/armedbear/lisp/Nil.java @@ -47,6 +47,21 @@ public final class Nil extends Symbol } @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() { return Symbol.NULL; diff --git a/src/org/armedbear/lisp/jvm-instructions.lisp b/src/org/armedbear/lisp/jvm-instructions.lisp index 75d0014..e985d55 100644 --- a/src/org/armedbear/lisp/jvm-instructions.lisp +++ b/src/org/armedbear/lisp/jvm-instructions.lisp @@ -461,6 +461,24 @@ (defun astore (index) (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 @@ (defun initialize-resolvers () 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 @@ (defun initialize-resolvers () 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 diff --git a/src/org/armedbear/lisp/runtime-class.lisp b/src/org/armedbear/lisp/runtime-class.lisp index 8010701..e1bffe4 100644 --- a/src/org/armedbear/lisp/runtime-class.lisp +++ b/src/org/armedbear/lisp/runtime-class.lisp @@ -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 @@ (defun java:jnew-runtime-class (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 @@ (defun java:jnew-runtime-class 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 @@ (defun java::%jnew-runtime-class (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 @@ (defun java::emit-unbox-and-return (return-type) (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::emit-unbox-and-return (return-type) (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 @@ (defun java::runtime-class-add-methods (class-file methods) :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) diff --git a/test/lisp/abcl/runtime-class.lisp b/test/lisp/abcl/runtime-class.lisp index 675bec6..8527494 100644 --- a/test/lisp/abcl/runtime-class.lisp +++ b/test/lisp/abcl/runtime-class.lisp @@ -1,70 +1,55 @@ (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") -- 2.8.1