Changeset 14903


Ignore:
Timestamp:
10/15/16 12:41:27 (7 years ago)
Author:
Mark Evenson
Message:

[PATCH 4/5] Runtime class improvements (ferada)

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?

<​http://abcl.org/trac/timeline/14903>

vc:reverts <​http://abcl.org/trac/changeset/14882> ;
vc:restores <​http://abcl.org/trac/changeset/14858> .

Location:
trunk/abcl
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/CHANGES

    r14902 r14903  
    99-----
    1010
    11 * CL:OPEN
     11* JNEW-RUNTIME-CLASS
     12
     13* Fix CL:OPEN for :DIRECTION :INPUT (pipping)
    1214
    1315Version 1.4.0

  • trunk/abcl/src/org/armedbear/lisp/LispObject.java

    r14882 r14903  
    129129  public Object javaInstance(Class<?> c)
    130130  {
    131       if (c.isAssignableFrom(getClass()))
    132     return this;
    133       return error(new LispError("The value " + princToString() +
     131    if (c.isAssignableFrom(getClass())) {
     132      return this;
     133    }
     134
     135    String cn = c.getName();
     136    if (cn != null) {
     137      if (cn.equals("java.lang.Boolean") || cn.equals("boolean")) {
     138        return Boolean.TRUE;
     139      }
     140    }
     141
     142    return error(new LispError("The value " + princToString() +
    134143         " is not of class " + c.getName()));
    135144  }

  • trunk/abcl/src/org/armedbear/lisp/Nil.java

    r14882 r14903  
    4545        pkg.addSymbol(this);
    4646        initializeConstant(this);
     47    }
     48
     49    @Override
     50    public Object javaInstance()
     51    {
     52        return null;
     53    }
     54
     55    @Override
     56    public Object javaInstance(Class c)
     57    {
     58      String cn = c.getName();
     59      if (cn != null) {
     60        if (cn.equals("java.lang.Boolean") || cn.equals("boolean")) {
     61          return Boolean.FALSE;
     62        }
     63      }
     64      return javaInstance();
    4765    }
    4866

  • trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r14882 r14903  
    462462    (t (emit 'astore index))))
    463463
     464(defknown iload (fixnum) t)
     465(defun iload (index)
     466  (case index
     467    (0 (emit 'iload_0))
     468    (1 (emit 'iload_1))
     469    (2 (emit 'iload_2))
     470    (3 (emit 'iload_3))
     471    (t (emit 'iload index))))
     472
     473(defknown istore (fixnum) t)
     474(defun istore (index)
     475  (case index
     476    (0 (emit 'istore_0))
     477    (1 (emit 'istore_1))
     478    (2 (emit 'istore_2))
     479    (3 (emit 'istore_3))
     480    (t (emit 'istore index))))
     481
    464482(declaim (ftype (function (t) t) branch-p)
    465483         (inline branch-p))
    … …  
    572590                 14 ; dconst_0
    573591                 15 ; dconst_1
     592                 26 ; iload_0
     593                 27 ; iload_1
     594                 28 ; iload_2
     595                 29 ; iload_3
    574596                 42 ; aload_0
    575597                 43 ; aload_1
    … …  
    581603                 49 ; daload
    582604                 50 ; aaload
     605                 54 ; istore
     606                 59 ; istore_0
     607                 60 ; istore_1
     608                 61 ; istore_2
     609                 62 ; istore_3
    583610                 75 ; astore_0
    584611                 76 ; astore_1

  • trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp

    r14882 r14903  
    88(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
    99
     10(defun java::make-memory-class-loader (&optional (parent (java:get-current-classloader)))
     11  (java:jnew "org.armedbear.lisp.MemoryClassLoader" parent))
     12
    1013(defun java:jnew-runtime-class
    1114    (class-name &rest args &key (superclass "java.lang.Object")
    12      interfaces constructors methods fields (access-flags '(:public)) annotations)
     15     interfaces constructors methods fields (access-flags '(:public)) annotations
     16     (class-loader (java::make-memory-class-loader)))
    1317  "Creates and loads a Java class with methods calling Lisp closures
    1418   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
    … …  
    3236     (METHOD-NAME RETURN-TYPE ARGUMENT-TYPES FUNCTION &key MODIFIERS ANNOTATIONS)
    3337
    34    where 
    35       METHOD-NAME is a string 
     38   where
     39      METHOD-NAME is a string
    3640      RETURN-TYPE denotes the type of the object returned by the method
    3741      ARGUMENT-TYPES is a list of parameters to the method
    38      
    39         The types are either strings naming fully qualified java classes or Lisp keywords referring to 
     42
     43        The types are either strings naming fully qualified java classes or Lisp keywords referring to
    4044        primitive types (:void, :int, etc.).
    4145
    … …  
    4650   Field definitions are lists of the form (field-name type &key modifiers annotations)."
    4751  (declare (ignorable superclass interfaces constructors methods fields access-flags annotations))
    48   (let* ((stream (sys::%make-byte-array-output-stream))
    49         (current-class-loader (java:get-current-classloader))
    50         (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" current-class-loader)))
     52  (let ((stream (sys::%make-byte-array-output-stream)))
    5153    (multiple-value-bind (class-file method-implementation-fields)
    52         (apply #'java::%jnew-runtime-class class-name stream args)
    53       (sys::put-memory-function memory-class-loader
     54        (apply #'java::%jnew-runtime-class class-name stream :allow-other-keys T args)
     55      (sys::put-memory-function class-loader
    5456                                class-name (sys::%get-output-stream-bytes stream))
    55       (let ((jclass (java:jcall "loadClass" memory-class-loader class-name)))
     57      (let ((jclass (java:jcall "loadClass" class-loader class-name)))
    5658        (dolist (method method-implementation-fields)
    5759          (setf (java:jfield jclass (car method)) (cdr method)))
    5860        jclass))))
     61
     62(defconstant +abcl-lisp-integer-object+ (make-jvm-class-name "org.armedbear.lisp.LispInteger"))
     63
     64(defun box-arguments (argument-types offset all-argc)
     65  ;;Box each argument
     66  (loop
     67    :for arg-type :in argument-types
     68    :for i :from offset
     69    :do (progn
     70          (cond
     71            ((eq arg-type :int)
     72             (iload i)
     73             (emit-invokestatic +abcl-lisp-integer-object+ "getInstance"
     74                                (list :int) +abcl-lisp-integer-object+))
     75            ((keywordp arg-type)
     76             (error "Unsupported arg-type: ~A" arg-type))
     77            (t (aload i)
     78               (emit 'iconst_1) ;;true
     79               (emit-invokestatic +abcl-java-object+ "getInstance"
     80                                  (list +java-object+ :boolean) +lisp-object+)))
     81          (astore (+ i all-argc)))))
    5982
    6083(defun java::%jnew-runtime-class
    … …  
    79102          (emit-invokespecial-init (class-file-superclass class-file) nil)
    80103          (emit 'return)))
    81       (error "constructors not supported"))
     104      (dolist (constructor constructors)
     105        (destructuring-bind (argument-types function
     106                             &key (modifiers '(:public)))
     107            constructor
     108          (let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
     109                 (argc (length argument-types))
     110                 (ctor (make-jvm-method :constructor :void argument-types :flags modifiers))
     111                 (field-name (string (gensym "CONSTRUCTOR")))
     112                 (all-argc (1+ argc)))
     113            (class-add-method class-file ctor)
     114            (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
     115              (class-add-field class-file field))
     116            (push (cons field-name function) method-implementation-fields)
     117            (with-code-to-method (class-file ctor)
     118              (dotimes (i (* 2 all-argc))
     119                (allocate-register nil))
     120
     121              (aload 0)
     122              (emit-invokespecial-init (class-file-superclass class-file) nil)
     123
     124              (aload 0)
     125              (emit 'iconst_1) ;;true
     126              (emit-invokestatic +abcl-java-object+ "getInstance"
     127                                 (list +java-object+ :boolean) +lisp-object+)
     128              (astore all-argc)
     129
     130              (box-arguments argument-types 1 all-argc)
     131
     132              ;;Load the Lisp function from its static field
     133              (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
     134              (if (<= all-argc call-registers-limit)
     135                  (progn
     136                    ;;Load the boxed this
     137                    (aload all-argc)
     138                    ;;Load each boxed argument
     139                    (dotimes (i argc)
     140                      (aload (+ i 1 all-argc))))
     141                  (error "execute(LispObject[]) is currently not supported"))
     142              (emit-call-execute all-argc)
     143
     144              (emit 'return))))))
    82145    (finalize-class-file class-file)
    83146    (write-class-file class-file stream)
    … …  
    123186     (emit 'ireturn))
    124187    ((jvm-class-name-p return-type)
    125      (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+)
     188     (emit 'ldc_w (pool-class return-type))
     189     (emit-invokevirtual +lisp-object+ "javaInstance" (list +java-class+) +java-object+)
    126190     (emit-checkcast return-type)
    127191     (emit 'areturn))
    … …  
    131195(defun java::runtime-class-add-methods (class-file methods)
    132196  (let (method-implementation-fields)
    133     (dolist (m methods)
     197    (dolist (method methods)
    134198      (destructuring-bind (name return-type argument-types function
    135                            &key (modifiers '(:public)) annotations override) m
     199                           &key (modifiers '(:public)) annotations override)
     200          method
    136201        (let* ((argument-types (mapcar #'java::canonicalize-java-type argument-types))
    137202               (argc (length argument-types))
    138203               (return-type (java::canonicalize-java-type return-type))
    139204               (jmethod (make-jvm-method name return-type argument-types :flags modifiers))
    140                (field-name (string (gensym name))))
     205               (field-name (string (gensym name)))
     206               (staticp (member :static modifiers))
     207               (offset (if staticp 0 1))
     208               (all-argc (+ argc offset)))
    141209          (class-add-method class-file jmethod)
    142210          (let ((field (make-field field-name +lisp-object+ :flags '(:public :static))))
    … …  
    148216          (with-code-to-method (class-file jmethod)
    149217            ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this")
    150             (dotimes (i (* 2 (1+ argc)))
     218            (dotimes (i (* 2 all-argc))
    151219              (allocate-register nil))
    152             ;;Box "this" (to be passed as the first argument to the Lisp function)
    153             (aload 0)
    154             (emit 'iconst_1) ;;true
    155             (emit-invokestatic +abcl-java-object+ "getInstance"
    156                                (list +java-object+ :boolean) +lisp-object+)
    157             (astore (1+ argc))
    158             ;;Box each argument
    159             (loop
    160                :for arg-type :in argument-types
    161                :for i :from 1
    162                :do (progn
    163                      (cond
    164                        ((keywordp arg-type)
    165                         (error "Unsupported arg-type: ~A" arg-type))
    166                        ((eq arg-type :int) :todo)
    167                        (t (aload i)
    168                           (emit 'iconst_1) ;;true
    169                           (emit-invokestatic +abcl-java-object+ "getInstance"
    170                                              (list +java-object+ :boolean) +lisp-object+)))
    171                      (astore (+ i (1+ argc)))))
     220            (unless staticp
     221              ;;Box "this" (to be passed as the first argument to the Lisp function)
     222              (aload 0)
     223              (emit 'iconst_1) ;;true
     224              (emit-invokestatic +abcl-java-object+ "getInstance"
     225                                 (list +java-object+ :boolean) +lisp-object+)
     226              (astore all-argc))
     227            (box-arguments argument-types offset all-argc)
    172228            ;;Load the Lisp function from its static field
    173229            (emit-getstatic (class-file-class class-file) field-name +lisp-object+)
    174             (if (<= (1+ argc) call-registers-limit)
     230            (if (<= all-argc call-registers-limit)
    175231                (progn
    176232                  ;;Load the boxed this
    177                   (aload (1+ argc))
     233                  (unless staticp
     234                    (aload all-argc))
    178235                  ;;Load each boxed argument
    179236                  (dotimes (i argc)
    180                     (aload (+ argc 2 i))))
     237                    (aload (+ i 1 all-argc))))
    181238                (error "execute(LispObject[]) is currently not supported"))
    182             (emit-call-execute (1+ (length argument-types)))
     239            (emit-call-execute all-argc)
    183240            (java::emit-unbox-and-return return-type))
    184241          (cond

  • trunk/abcl/test/lisp/abcl/runtime-class.lisp

    r14882 r14903  
    11(in-package :abcl.test.lisp)
    2 
    32
    43;; method with no arguments
    54(deftest runtime-class.1
    6     (java:jnew-runtime-class
    7      "Actor"
    8      :fields `(("name" "java.lang.String"))
    9      :methods `(("getName" "java.lang.String" nil
    10                            (lambda (this)
    11                              (java:jfield this "name")))))
    12   t)
     5    (java:jclass-name
     6     (java:jnew-runtime-class
     7      "Actor"
     8      :fields '(("name" "java.lang.String" :getter NIL))
     9      :methods '(("getName" "java.lang.String" NIL
     10                  (lambda (this)
     11                    (java:jfield "name" this))))))
     12  "Actor")
    1313
    1414;; method with primitive type
    1515(deftest runtime-class.2
    16     (java:jnew-runtime-class
    17      "Actor"
    18      :fields `(("name" "java.lang.String"))
    19      :methods `(("getName" "java.lang.String" (:int)
    20                            (lambda (this)
    21                              (java:jfield this "name")))))
    22   t)
     16    (java:jclass-name
     17     (java:jnew-runtime-class
     18      "Actor"
     19      :fields '(("name" "java.lang.String" :getter NIL))
     20      :methods '(("getName" "java.lang.String" (:int)
     21                  (lambda (this x)
     22                    (declare (ignore x))
     23                    (java:jfield "name" this))))))
     24  "Actor")
    2325
    24 ;; inheritance of type
    25 
     26;; inheritance of type
    2627(deftest runtime-class.3
    27     (progn
    28       (java:jnew-runtime-class 
     28    (let ((class-loader (java::make-memory-class-loader)))
     29      (java:jnew-runtime-class
    2930       "foo.Actor"
    30        :fields `(("name" "java.lang.String")))
    31       (java:jnew-runtime-class
    32        "foo.StageActor"
    33        :superclass "foo.Actor"
    34        :fields (list '("givenName" "java.lang.String"))))
    35   t)
    36 
    37 
    38 #|
    39 // Simple constructor test
    40 public class Actor {
    41   String name;
    42  
    43   public Actor(String name) {
    44     this.name = name;
    45   }
    46 
    47   public String getName() {
    48     return name;
    49   }
    50  
    51 }
    52 |#
     31       :fields '(("name" "java.lang.String"))
     32       :class-loader class-loader)
     33      (java:jclass-name
     34       (java:jnew-runtime-class
     35        "foo.StageActor"
     36        :superclass "foo.Actor"
     37        :fields '(("givenName" "java.lang.String"))
     38        :class-loader class-loader)))
     39  "foo.StageActor")
    5340
    5441;; constructor
    5542(deftest runtime-class.4
    56     (java:jnew-runtime-class
    57      "Actor"
    58      :constructors `(("java.lang.String")
    59                      (lambda (name)
    60                        (setf (jfield this "name")
    61                              name)))
    62      :methods `(("getName" "java.lang.String" ("java.lang.String")  ;; no-arg methods not working
    63                            (lambda (this dummy)
    64                              (declare (ignore dummy))
    65                              (java:jfield this "name"))))
    66      :fields `(("name" "java.lang.String")))
    67   t)
    68 
    69 
    70    
     43    (java:jcall "getName"
     44                (java:jnew
     45                 (java:jnew-runtime-class
     46                  "Actor"
     47                  :constructors '((("java.lang.String")
     48                                   (lambda (this name)
     49                                     (setf (java:jfield "name" this) name))))
     50                  :methods '(("getName" "java.lang.String" NIL
     51                              (lambda (this)
     52                                (java:jfield "name" this))))
     53                  :fields '(("name" "java.lang.String" :getter NIL)))
     54                 "Someone"))
     55  "Someone")
Note: See TracChangeset for help on using the changeset viewer.