Changeset 13710


Ignore:
Timestamp:
12/27/11 19:50:08 (11 years ago)
Author:
astalla
Message:

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.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
6 edited

Legend:

Unmodified
Added
Removed

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

    r13467 r13710  
    4343    private final HashMap<String, JavaObject> hashtable = new HashMap<String, JavaObject>();
    4444    private final JavaObject boxedThis = new JavaObject(this);
     45    private final String internalNamePrefix;
    4546
    4647    public MemoryClassLoader() {
     48        this("org/armedbear/lisp/");
     49    }
     50
     51    public MemoryClassLoader(String internalNamePrefix) {
     52        this.internalNamePrefix = internalNamePrefix;
    4753    }
    4854
    … …  
    6066         */
    6167        if (hashtable.containsKey(name)) {
    62             String internalName = "org/armedbear/lisp/" + name;
     68            String internalName = internalNamePrefix + name;
    6369            Class<?> c = this.findLoadedClass(internalName);
    6470

  • trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

    r13688 r13710  
    279279(export 'jnew-runtime-class "JAVA")
    280280(autoload 'jnew-runtime-class "runtime-class")
    281 (export 'jredefine-method "JAVA")
    282 (autoload 'jredefine-method "runtime-class")
    283 (export 'jruntime-class-exists-p "JAVA")
    284 (autoload 'jruntime-class-exists-p "runtime-class")
    285281(export 'ensure-java-class "JAVA")
    286282(autoload 'ensure-java-class "java")

  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r13600 r13710  
    244244                           "run-program.lisp"
    245245                           "run-shell-command.lisp"
    246                            ;;"runtime-class.lisp"
     246                           "runtime-class.lisp"
    247247                           "search.lisp"
    248248                           "sequences.lisp"

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

    r13608 r13710  
    289289  (if instance-supplied-p
    290290      (jfield class-ref-or-field field-or-instance instance newvalue)
    291       (jfield class-ref-or-field field-or-instance newvalue)))
     291      (jfield class-ref-or-field field-or-instance nil newvalue)))
    292292
    293293(defun jclass-methods (class &key declared public)

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

    r13535 r13710  
    234234(define-opcode freturn 174 1 nil nil)
    235235(define-opcode dreturn 175 1 nil nil)
     236(define-opcode ireturn 172 1 -1 nil)
    236237(define-opcode areturn 176 1 -1 nil)
    237238(define-opcode return 177 1 0 nil)
    … …  
    569570                 166 ; if_acmpne
    570571                 167 ; goto
     572                 172 ; ireturn
    571573                 176 ; areturn
    572574                 177 ; return
    … …  
    722724                                    in ~A at index ~D: ~
    723725                                    found ~S, expected ~S."
    724                                    (compiland-name *current-compiland*)
     726                                   (if *current-compiland*
     727                                       (compiland-name *current-compiland*)
     728                                       "<unknown>")
    725729                                   i instruction-depth
    726730                                   (+ depth instruction-stack)))
    … …  
    733737                                    in ~A at index ~D: ~
    734738                                    negative depth ~S."
    735                                    (compiland-name *current-compiland*)
     739                                   (if *current-compiland*
     740                                       (compiland-name *current-compiland*)
     741                                       "<unknown>")
    736742                                   i depth))
    737743        (when (branch-p opcode)

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

    r11391 r13710  
    1 ;;; runtime-class.lisp
    2 ;;;
    3 ;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id$
    5 ;;;
    6 ;;; This program is free software; you can redistribute it and/or
    7 ;;; modify it under the terms of the GNU General Public License
    8 ;;; as published by the Free Software Foundation; either version 2
    9 ;;; of the License, or (at your option) any later version.
    10 ;;;
    11 ;;; This program is distributed in the hope that it will be useful,
    12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14 ;;; GNU General Public License for more details.
    15 ;;;
    16 ;;; You should have received a copy of the GNU General Public License
    17 ;;; along with this program; if not, write to the Free Software
    18 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    19 ;;;
    20 ;;; As a special exception, the copyright holders of this library give you
    21 ;;; permission to link this library with independent modules to produce an
    22 ;;; executable, regardless of the license terms of these independent
    23 ;;; modules, and to copy and distribute the resulting executable under
    24 ;;; terms of your choice, provided that you also meet, for each linked
    25 ;;; independent module, the terms and conditions of the license of that
    26 ;;; module.  An independent module is a module which is not derived from
    27 ;;; or based on this library.  If you modify this library, you may extend
    28 ;;; this exception to your version of the library, but you are not
    29 ;;; obligated to do so.  If you do not wish to do so, delete this
    30 ;;; exception statement from your version.
     1(require "COMPILER-PASS2")
    312
    32 (in-package :java)
     3(in-package :jvm)
    334
    34 (require :format)
     5(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject"))
    356
    36 ;; jparse generated definitions, somewhat simplified
    37 
    38 (defclass java-class nil ((java-instance :initarg :java-instance :reader java-instance)))
    39 (defclass jboolean (java-class) nil)
    40 (defmethod initialize-instance :after ((b jboolean) &key &allow-other-keys)
    41   (setf (slot-value b 'java-instance) (make-immediate-object (java-instance b) :boolean)))
    42 (defclass jarray (java-class) nil)
    43 (defclass |java.lang.Object| (java-class) nil)
    44 (defclass output-stream (java-class) nil)
    45 (defclass file-output-stream (output-stream java-class) nil)
    46 (defclass class-visitor (java-class) nil)
    47 (defclass class-writer (class-visitor java-class) nil)
    48 (defclass code-visitor (java-class) nil)
    49 (defclass code-writer (code-visitor java-class) nil)
    50 (defclass attribute (java-class) nil)
    51 (defclass constants (java-class) nil)
    52 (defclass label (java-class) nil)
    53 (defmethod make-file-output-stream-1 ((v1 string))
    54   (make-instance 'file-output-stream :java-instance
    55                  (jnew (jconstructor "java.io.FileOutputStream" "java.lang.String") v1)))
    56 (defmethod write-1 ((instance file-output-stream) (v1 jarray))
    57   (jcall (jmethod "java.io.FileOutputStream" "write" "[B") (java-instance instance) (java-instance v1)))
    58 (defmethod close-0 ((instance file-output-stream))
    59   (jcall (jmethod "java.io.FileOutputStream" "close") (java-instance instance)))
    60 (defmethod make-class-writer-1 ((v1 jboolean))
    61   (make-instance 'class-writer :java-instance
    62                  (jnew (jconstructor "org.objectweb.asm.ClassWriter" "boolean") (java-instance v1))))
    63 (defmethod visit-end-0 ((instance class-writer))
    64   (jcall (jmethod "org.objectweb.asm.ClassWriter" "visitEnd") (java-instance instance)))
    65 (defmethod to-byte-array-0 ((instance class-writer))
    66   (make-instance 'jarray :java-instance
    67                  (jcall (jmethod "org.objectweb.asm.ClassWriter" "toByteArray") (java-instance instance))))
    68 (defmethod visit-insn-1 ((instance code-visitor) (v1 fixnum))
    69   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitInsn" "int") (java-instance instance) v1))
    70 (defmethod visit-int-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum))
    71   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitIntInsn" "int" "int") (java-instance instance) v1
    72          v2))
    73 (defmethod visit-var-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum))
    74   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitVarInsn" "int" "int") (java-instance instance) v1
    75          v2))
    76 (defmethod visit-type-insn-2 ((instance code-visitor) (v1 fixnum) (v2 string))
    77   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTypeInsn" "int" "java.lang.String")
    78          (java-instance instance) v1 v2))
    79 (defmethod visit-field-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string))
    80   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitFieldInsn" "int" "java.lang.String"
    81                   "java.lang.String" "java.lang.String")
    82          (java-instance instance) v1 v2 v3 v4))
    83 (defmethod visit-method-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string))
    84   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMethodInsn" "int" "java.lang.String"
    85                   "java.lang.String" "java.lang.String")
    86          (java-instance instance) v1 v2 v3 v4))
    87 (defmethod visit-jump-insn-2 ((instance code-visitor) (v1 fixnum) (v2 label))
    88   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitJumpInsn" "int" "org.objectweb.asm.Label")
    89          (java-instance instance) v1 (java-instance v2)))
    90 (defmethod visit-label-1 ((instance code-visitor) (v1 label))
    91   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLabel" "org.objectweb.asm.Label")
    92          (java-instance instance) (java-instance v1)))
    93 (defmethod visit-ldc-insn-1 ((instance code-visitor) (v1 |java.lang.Object|))
    94   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLdcInsn" "java.lang.Object")
    95          (java-instance instance) (java-instance v1)))
    96 (defmethod visit-try-catch-block-4 ((instance code-visitor) (v1 label) (v2 label) (v3 label) (v4 string))
    97   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTryCatchBlock" "org.objectweb.asm.Label"
    98                   "org.objectweb.asm.Label" "org.objectweb.asm.Label" "java.lang.String")
    99          (java-instance instance) (java-instance v1) (java-instance v2) (java-instance v3) v4))
    100 (defmethod visit-maxs-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum))
    101   (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMaxs" "int" "int") (java-instance instance) v1 v2))
    102 (defconstant constants.ifnonnull (jfield "org.objectweb.asm.Constants" "IFNONNULL"))
    103 (defconstant constants.ifnull (jfield "org.objectweb.asm.Constants" "IFNULL"))
    104 (defconstant constants.multianewarray (jfield "org.objectweb.asm.Constants" "MULTIANEWARRAY"))
    105 (defconstant constants.monitorexit (jfield "org.objectweb.asm.Constants" "MONITOREXIT"))
    106 (defconstant constants.monitorenter (jfield "org.objectweb.asm.Constants" "MONITORENTER"))
    107 (defconstant constants.instanceof (jfield "org.objectweb.asm.Constants" "INSTANCEOF"))
    108 (defconstant constants.checkcast (jfield "org.objectweb.asm.Constants" "CHECKCAST"))
    109 (defconstant constants.athrow (jfield "org.objectweb.asm.Constants" "ATHROW"))
    110 (defconstant constants.arraylength (jfield "org.objectweb.asm.Constants" "ARRAYLENGTH"))
    111 (defconstant constants.anewarray (jfield "org.objectweb.asm.Constants" "ANEWARRAY"))
    112 (defconstant constants.newarray (jfield "org.objectweb.asm.Constants" "NEWARRAY"))
    113 (defconstant constants.new (jfield "org.objectweb.asm.Constants" "NEW"))
    114 (defconstant constants.invokeinterface (jfield "org.objectweb.asm.Constants" "INVOKEINTERFACE"))
    115 (defconstant constants.invokestatic (jfield "org.objectweb.asm.Constants" "INVOKESTATIC"))
    116 (defconstant constants.invokespecial (jfield "org.objectweb.asm.Constants" "INVOKESPECIAL"))
    117 (defconstant constants.invokevirtual (jfield "org.objectweb.asm.Constants" "INVOKEVIRTUAL"))
    118 (defconstant constants.putfield (jfield "org.objectweb.asm.Constants" "PUTFIELD"))
    119 (defconstant constants.getfield (jfield "org.objectweb.asm.Constants" "GETFIELD"))
    120 (defconstant constants.putstatic (jfield "org.objectweb.asm.Constants" "PUTSTATIC"))
    121 (defconstant constants.getstatic (jfield "org.objectweb.asm.Constants" "GETSTATIC"))
    122 (defconstant constants.return (jfield "org.objectweb.asm.Constants" "RETURN"))
    123 (defconstant constants.areturn (jfield "org.objectweb.asm.Constants" "ARETURN"))
    124 (defconstant constants.dreturn (jfield "org.objectweb.asm.Constants" "DRETURN"))
    125 (defconstant constants.freturn (jfield "org.objectweb.asm.Constants" "FRETURN"))
    126 (defconstant constants.lreturn (jfield "org.objectweb.asm.Constants" "LRETURN"))
    127 (defconstant constants.ireturn (jfield "org.objectweb.asm.Constants" "IRETURN"))
    128 (defconstant constants.lookupswitch (jfield "org.objectweb.asm.Constants" "LOOKUPSWITCH"))
    129 (defconstant constants.tableswitch (jfield "org.objectweb.asm.Constants" "TABLESWITCH"))
    130 (defconstant constants.ret (jfield "org.objectweb.asm.Constants" "RET"))
    131 (defconstant constants.jsr (jfield "org.objectweb.asm.Constants" "JSR"))
    132 (defconstant constants.goto (jfield "org.objectweb.asm.Constants" "GOTO"))
    133 (defconstant constants.if-acmpne (jfield "org.objectweb.asm.Constants" "IF_ACMPNE"))
    134 (defconstant constants.if-acmpeq (jfield "org.objectweb.asm.Constants" "IF_ACMPEQ"))
    135 (defconstant constants.if-icmple (jfield "org.objectweb.asm.Constants" "IF_ICMPLE"))
    136 (defconstant constants.if-icmpgt (jfield "org.objectweb.asm.Constants" "IF_ICMPGT"))
    137 (defconstant constants.if-icmpge (jfield "org.objectweb.asm.Constants" "IF_ICMPGE"))
    138 (defconstant constants.if-icmplt (jfield "org.objectweb.asm.Constants" "IF_ICMPLT"))
    139 (defconstant constants.if-icmpne (jfield "org.objectweb.asm.Constants" "IF_ICMPNE"))
    140 (defconstant constants.if-icmpeq (jfield "org.objectweb.asm.Constants" "IF_ICMPEQ"))
    141 (defconstant constants.ifle (jfield "org.objectweb.asm.Constants" "IFLE"))
    142 (defconstant constants.ifgt (jfield "org.objectweb.asm.Constants" "IFGT"))
    143 (defconstant constants.ifge (jfield "org.objectweb.asm.Constants" "IFGE"))
    144 (defconstant constants.iflt (jfield "org.objectweb.asm.Constants" "IFLT"))
    145 (defconstant constants.ifne (jfield "org.objectweb.asm.Constants" "IFNE"))
    146 (defconstant constants.ifeq (jfield "org.objectweb.asm.Constants" "IFEQ"))
    147 (defconstant constants.dcmpg (jfield "org.objectweb.asm.Constants" "DCMPG"))
    148 (defconstant constants.dcmpl (jfield "org.objectweb.asm.Constants" "DCMPL"))
    149 (defconstant constants.fcmpg (jfield "org.objectweb.asm.Constants" "FCMPG"))
    150 (defconstant constants.fcmpl (jfield "org.objectweb.asm.Constants" "FCMPL"))
    151 (defconstant constants.lcmp (jfield "org.objectweb.asm.Constants" "LCMP"))
    152 (defconstant constants.i2s (jfield "org.objectweb.asm.Constants" "I2S"))
    153 (defconstant constants.i2c (jfield "org.objectweb.asm.Constants" "I2C"))
    154 (defconstant constants.i2b (jfield "org.objectweb.asm.Constants" "I2B"))
    155 (defconstant constants.d2f (jfield "org.objectweb.asm.Constants" "D2F"))
    156 (defconstant constants.d2l (jfield "org.objectweb.asm.Constants" "D2L"))
    157 (defconstant constants.d2i (jfield "org.objectweb.asm.Constants" "D2I"))
    158 (defconstant constants.f2d (jfield "org.objectweb.asm.Constants" "F2D"))
    159 (defconstant constants.f2l (jfield "org.objectweb.asm.Constants" "F2L"))
    160 (defconstant constants.f2i (jfield "org.objectweb.asm.Constants" "F2I"))
    161 (defconstant constants.l2d (jfield "org.objectweb.asm.Constants" "L2D"))
    162 (defconstant constants.l2f (jfield "org.objectweb.asm.Constants" "L2F"))
    163 (defconstant constants.l2i (jfield "org.objectweb.asm.Constants" "L2I"))
    164 (defconstant constants.i2d (jfield "org.objectweb.asm.Constants" "I2D"))
    165 (defconstant constants.i2f (jfield "org.objectweb.asm.Constants" "I2F"))
    166 (defconstant constants.i2l (jfield "org.objectweb.asm.Constants" "I2L"))
    167 (defconstant constants.iinc (jfield "org.objectweb.asm.Constants" "IINC"))
    168 (defconstant constants.lxor (jfield "org.objectweb.asm.Constants" "LXOR"))
    169 (defconstant constants.ixor (jfield "org.objectweb.asm.Constants" "IXOR"))
    170 (defconstant constants.lor (jfield "org.objectweb.asm.Constants" "LOR"))
    171 (defconstant constants.ior (jfield "org.objectweb.asm.Constants" "IOR"))
    172 (defconstant constants.land (jfield "org.objectweb.asm.Constants" "LAND"))
    173 (defconstant constants.iand (jfield "org.objectweb.asm.Constants" "IAND"))
    174 (defconstant constants.lushr (jfield "org.objectweb.asm.Constants" "LUSHR"))
    175 (defconstant constants.iushr (jfield "org.objectweb.asm.Constants" "IUSHR"))
    176 (defconstant constants.lshr (jfield "org.objectweb.asm.Constants" "LSHR"))
    177 (defconstant constants.ishr (jfield "org.objectweb.asm.Constants" "ISHR"))
    178 (defconstant constants.lshl (jfield "org.objectweb.asm.Constants" "LSHL"))
    179 (defconstant constants.ishl (jfield "org.objectweb.asm.Constants" "ISHL"))
    180 (defconstant constants.dneg (jfield "org.objectweb.asm.Constants" "DNEG"))
    181 (defconstant constants.fneg (jfield "org.objectweb.asm.Constants" "FNEG"))
    182 (defconstant constants.lneg (jfield "org.objectweb.asm.Constants" "LNEG"))
    183 (defconstant constants.ineg (jfield "org.objectweb.asm.Constants" "INEG"))
    184 (defconstant constants.drem (jfield "org.objectweb.asm.Constants" "DREM"))
    185 (defconstant constants.frem (jfield "org.objectweb.asm.Constants" "FREM"))
    186 (defconstant constants.lrem (jfield "org.objectweb.asm.Constants" "LREM"))
    187 (defconstant constants.irem (jfield "org.objectweb.asm.Constants" "IREM"))
    188 (defconstant constants.ddiv (jfield "org.objectweb.asm.Constants" "DDIV"))
    189 (defconstant constants.fdiv (jfield "org.objectweb.asm.Constants" "FDIV"))
    190 (defconstant constants.ldiv (jfield "org.objectweb.asm.Constants" "LDIV"))
    191 (defconstant constants.idiv (jfield "org.objectweb.asm.Constants" "IDIV"))
    192 (defconstant constants.dmul (jfield "org.objectweb.asm.Constants" "DMUL"))
    193 (defconstant constants.fmul (jfield "org.objectweb.asm.Constants" "FMUL"))
    194 (defconstant constants.lmul (jfield "org.objectweb.asm.Constants" "LMUL"))
    195 (defconstant constants.imul (jfield "org.objectweb.asm.Constants" "IMUL"))
    196 (defconstant constants.dsub (jfield "org.objectweb.asm.Constants" "DSUB"))
    197 (defconstant constants.fsub (jfield "org.objectweb.asm.Constants" "FSUB"))
    198 (defconstant constants.lsub (jfield "org.objectweb.asm.Constants" "LSUB"))
    199 (defconstant constants.isub (jfield "org.objectweb.asm.Constants" "ISUB"))
    200 (defconstant constants.dadd (jfield "org.objectweb.asm.Constants" "DADD"))
    201 (defconstant constants.fadd (jfield "org.objectweb.asm.Constants" "FADD"))
    202 (defconstant constants.ladd (jfield "org.objectweb.asm.Constants" "LADD"))
    203 (defconstant constants.iadd (jfield "org.objectweb.asm.Constants" "IADD"))
    204 (defconstant constants.swap (jfield "org.objectweb.asm.Constants" "SWAP"))
    205 (defconstant constants.dup2_x2 (jfield "org.objectweb.asm.Constants" "DUP2_X2"))
    206 (defconstant constants.dup2_x1 (jfield "org.objectweb.asm.Constants" "DUP2_X1"))
    207 (defconstant constants.dup2 (jfield "org.objectweb.asm.Constants" "DUP2"))
    208 (defconstant constants.dup_x2 (jfield "org.objectweb.asm.Constants" "DUP_X2"))
    209 (defconstant constants.dup_x1 (jfield "org.objectweb.asm.Constants" "DUP_X1"))
    210 (defconstant constants.dup (jfield "org.objectweb.asm.Constants" "DUP"))
    211 (defconstant constants.pop2 (jfield "org.objectweb.asm.Constants" "POP2"))
    212 (defconstant constants.pop (jfield "org.objectweb.asm.Constants" "POP"))
    213 (defconstant constants.sastore (jfield "org.objectweb.asm.Constants" "SASTORE"))
    214 (defconstant constants.castore (jfield "org.objectweb.asm.Constants" "CASTORE"))
    215 (defconstant constants.bastore (jfield "org.objectweb.asm.Constants" "BASTORE"))
    216 (defconstant constants.aastore (jfield "org.objectweb.asm.Constants" "AASTORE"))
    217 (defconstant constants.dastore (jfield "org.objectweb.asm.Constants" "DASTORE"))
    218 (defconstant constants.fastore (jfield "org.objectweb.asm.Constants" "FASTORE"))
    219 (defconstant constants.lastore (jfield "org.objectweb.asm.Constants" "LASTORE"))
    220 (defconstant constants.iastore (jfield "org.objectweb.asm.Constants" "IASTORE"))
    221 (defconstant constants.astore (jfield "org.objectweb.asm.Constants" "ASTORE"))
    222 (defconstant constants.dstore (jfield "org.objectweb.asm.Constants" "DSTORE"))
    223 (defconstant constants.fstore (jfield "org.objectweb.asm.Constants" "FSTORE"))
    224 (defconstant constants.lstore (jfield "org.objectweb.asm.Constants" "LSTORE"))
    225 (defconstant constants.istore (jfield "org.objectweb.asm.Constants" "ISTORE"))
    226 (defconstant constants.saload (jfield "org.objectweb.asm.Constants" "SALOAD"))
    227 (defconstant constants.caload (jfield "org.objectweb.asm.Constants" "CALOAD"))
    228 (defconstant constants.baload (jfield "org.objectweb.asm.Constants" "BALOAD"))
    229 (defconstant constants.aaload (jfield "org.objectweb.asm.Constants" "AALOAD"))
    230 (defconstant constants.daload (jfield "org.objectweb.asm.Constants" "DALOAD"))
    231 (defconstant constants.faload (jfield "org.objectweb.asm.Constants" "FALOAD"))
    232 (defconstant constants.laload (jfield "org.objectweb.asm.Constants" "LALOAD"))
    233 (defconstant constants.iaload (jfield "org.objectweb.asm.Constants" "IALOAD"))
    234 (defconstant constants.aload (jfield "org.objectweb.asm.Constants" "ALOAD"))
    235 (defconstant constants.dload (jfield "org.objectweb.asm.Constants" "DLOAD"))
    236 (defconstant constants.fload (jfield "org.objectweb.asm.Constants" "FLOAD"))
    237 (defconstant constants.lload (jfield "org.objectweb.asm.Constants" "LLOAD"))
    238 (defconstant constants.iload (jfield "org.objectweb.asm.Constants" "ILOAD"))
    239 (defconstant constants.ldc (jfield "org.objectweb.asm.Constants" "LDC"))
    240 (defconstant constants.sipush (jfield "org.objectweb.asm.Constants" "SIPUSH"))
    241 (defconstant constants.bipush (jfield "org.objectweb.asm.Constants" "BIPUSH"))
    242 (defconstant constants.dconst_1 (jfield "org.objectweb.asm.Constants" "DCONST_1"))
    243 (defconstant constants.dconst_0 (jfield "org.objectweb.asm.Constants" "DCONST_0"))
    244 (defconstant constants.fconst_2 (jfield "org.objectweb.asm.Constants" "FCONST_2"))
    245 (defconstant constants.fconst_1 (jfield "org.objectweb.asm.Constants" "FCONST_1"))
    246 (defconstant constants.fconst_0 (jfield "org.objectweb.asm.Constants" "FCONST_0"))
    247 (defconstant constants.lconst_1 (jfield "org.objectweb.asm.Constants" "LCONST_1"))
    248 (defconstant constants.lconst_0 (jfield "org.objectweb.asm.Constants" "LCONST_0"))
    249 (defconstant constants.iconst_5 (jfield "org.objectweb.asm.Constants" "ICONST_5"))
    250 (defconstant constants.iconst_4 (jfield "org.objectweb.asm.Constants" "ICONST_4"))
    251 (defconstant constants.iconst_3 (jfield "org.objectweb.asm.Constants" "ICONST_3"))
    252 (defconstant constants.iconst_2 (jfield "org.objectweb.asm.Constants" "ICONST_2"))
    253 (defconstant constants.iconst_1 (jfield "org.objectweb.asm.Constants" "ICONST_1"))
    254 (defconstant constants.iconst_0 (jfield "org.objectweb.asm.Constants" "ICONST_0"))
    255 (defconstant constants.iconst_m1 (jfield "org.objectweb.asm.Constants" "ICONST_M1"))
    256 (defconstant constants.aconst-null (jfield "org.objectweb.asm.Constants" "ACONST_NULL"))
    257 (defconstant constants.nop (jfield "org.objectweb.asm.Constants" "NOP"))
    258 (defconstant constants.t-long (jfield "org.objectweb.asm.Constants" "T_LONG"))
    259 (defconstant constants.t-int (jfield "org.objectweb.asm.Constants" "T_INT"))
    260 (defconstant constants.t-short (jfield "org.objectweb.asm.Constants" "T_SHORT"))
    261 (defconstant constants.t-byte (jfield "org.objectweb.asm.Constants" "T_BYTE"))
    262 (defconstant constants.t-double (jfield "org.objectweb.asm.Constants" "T_DOUBLE"))
    263 (defconstant constants.t-float (jfield "org.objectweb.asm.Constants" "T_FLOAT"))
    264 (defconstant constants.t-char (jfield "org.objectweb.asm.Constants" "T_CHAR"))
    265 (defconstant constants.t-boolean (jfield "org.objectweb.asm.Constants" "T_BOOLEAN"))
    266 (defconstant constants.acc-deprecated (jfield "org.objectweb.asm.Constants" "ACC_DEPRECATED"))
    267 (defconstant constants.acc-synthetic (jfield "org.objectweb.asm.Constants" "ACC_SYNTHETIC"))
    268 (defconstant constants.acc-super (jfield "org.objectweb.asm.Constants" "ACC_SUPER"))
    269 (defconstant constants.acc-strict (jfield "org.objectweb.asm.Constants" "ACC_STRICT"))
    270 (defconstant constants.acc-abstract (jfield "org.objectweb.asm.Constants" "ACC_ABSTRACT"))
    271 (defconstant constants.acc-interface (jfield "org.objectweb.asm.Constants" "ACC_INTERFACE"))
    272 (defconstant constants.acc-enum (jfield "org.objectweb.asm.Constants" "ACC_ENUM"))
    273 (defconstant constants.acc-native (jfield "org.objectweb.asm.Constants" "ACC_NATIVE"))
    274 (defconstant constants.acc-transient (jfield "org.objectweb.asm.Constants" "ACC_TRANSIENT"))
    275 (defconstant constants.acc-varargs (jfield "org.objectweb.asm.Constants" "ACC_VARARGS"))
    276 (defconstant constants.acc-bridge (jfield "org.objectweb.asm.Constants" "ACC_BRIDGE"))
    277 (defconstant constants.acc-volatile (jfield "org.objectweb.asm.Constants" "ACC_VOLATILE"))
    278 (defconstant constants.acc-synchronized (jfield "org.objectweb.asm.Constants" "ACC_SYNCHRONIZED"))
    279 (defconstant constants.acc-final (jfield "org.objectweb.asm.Constants" "ACC_FINAL"))
    280 (defconstant constants.acc-static (jfield "org.objectweb.asm.Constants" "ACC_STATIC"))
    281 (defconstant constants.acc-protected (jfield "org.objectweb.asm.Constants" "ACC_PROTECTED"))
    282 (defconstant constants.acc-private (jfield "org.objectweb.asm.Constants" "ACC_PRIVATE"))
    283 (defconstant constants.acc-public (jfield "org.objectweb.asm.Constants" "ACC_PUBLIC"))
    284 (defconstant constants.v1-1 (jfield "org.objectweb.asm.Constants" "V1_1"))
    285 (defmethod make-label-0 nil
    286   (make-instance 'label :java-instance (jnew (jconstructor "org.objectweb.asm.Label"))))
    287 
    288 ;;end of jparse generated definitions
    289 
    290 
    291 (defmethod visit-4 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string) v4)
    292   (jcall
    293    (jmethod "org.objectweb.asm.ClassWriter" "visit" "int" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "java.lang.String")
    294    (java-instance instance) constants.v1-1 v1 v2 v3 v4 nil))
    295 
    296 (defmethod visit-field-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string))
    297   (jcall
    298    (jmethod "org.objectweb.asm.ClassWriter" "visitField" "int" "java.lang.String" "java.lang.String" "java.lang.Object" "org.objectweb.asm.Attribute")
    299    (java-instance instance) v1 v2 v3 nil nil))
    300 
    301 (defmethod visit-method-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string))
    302   (make-instance 'code-visitor :java-instance
    303                  (jcall
    304                   (jmethod "org.objectweb.asm.ClassWriter" "visitMethod" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "org.objectweb.asm.Attribute")
    305                   (java-instance instance) v1 v2 v3 nil nil)))
    306 
    307 (defun make-java-string (string)
    308   (make-instance '|java.lang.Object|
    309                  :java-instance (jnew (jconstructor "java.lang.String" "[C") (jnew-array-from-array "char" string))))
    310 
    311 (defparameter *primitive-types*
    312   (acons
    313    "void" (list "V" (list "" "" "") -1 constants.return -1)
    314    (acons
    315     "byte"
    316     (list "B" (list "org/armedbear/lisp/Fixnum" "java/lang/Byte" "byteValue")
    317           constants.iload constants.ireturn constants.iconst_0)
    318     (acons
    319      "short"
    320      (list "S" (list "org/armedbear/lisp/Fixnum" "java/lang/Short" "shortValue")
    321            constants.iload constants.ireturn constants.iconst_0)
    322      (acons
    323       "int"
    324       (list "I" (list "org/armedbear/lisp/Fixnum" "java/lang/Integer" "intValue")
    325             constants.iload constants.ireturn constants.iconst_0)
    326       (acons
    327        "long"
    328        (list "J" (list "org/armedbear/lisp/Fixnum" "java/lang/Long" "longValue")
    329              constants.lload constants.lreturn constants.lconst_0)
    330        (acons
    331         "float"
    332         (list "F" (list "org/armedbear/lisp/SingleFloat" "java/lang/Float" "floatValue")
    333               constants.fload constants.freturn constants.fconst_0)
    334         (acons
    335          "double"
    336          (list "D" (list "org/armedbear/lisp/DoubleFloat" "java/lang/Double" "doubleValue")
    337                constants.dload constants.dreturn constants.dconst_0)
    338          (acons
    339           "char"
    340           (list "C" (list "org/armedbear/lisp/LispCharacter" "java/lang/Character" "charValue")
    341                 constants.iload constants.ireturn constants.iconst_0)
    342           (acons
    343            "boolean"
    344            (list "Z" (list "org/armedbear/lisp/LispObject" "" "")
    345                  constants.iload constants.ireturn constants.iconst_0)
    346            nil))))))))))
    347 
    348 (defun primitive-type-p (type)
    349   (assoc type *primitive-types* :test #'string=))
    350 
    351 (defun type-name (type)
    352   (let* ((dim (count #\[ type :test #'char=))
    353          (prefix (make-string dim :initial-element #\[))
    354          (base-type (string-right-trim "[ ]" type))
    355          (base-name (assoc base-type *primitive-types* :test #'string=)))
    356     (concatenate 'string prefix
    357                  (if base-name (cadr base-name)
    358                      (substitute #\/ #\.
    359                                  (if (zerop dim) base-type (decorate-type-name base-type)))))))
    360 
    361 
    362 (defun decorate-type-name (type)
    363   (if (char= (char type 0) #\[) type
    364       (format nil "L~a;" type)))
    365 
    366 (defun decorated-type-name (type)
    367   (let ((name (type-name type)))
    368     (if (primitive-type-p type) name (decorate-type-name name))))
    369 
    370 (defun arg-type-for-make-lisp-object (type)
    371   (if (primitive-type-p type)
    372       (decorated-type-name type)
    373       "Ljava/lang/Object;"))
    374 
    375 (defun return-type-for-make-lisp-object (type)
    376   (let ((name (assoc type *primitive-types* :test #'string=)))
    377     (if name (caaddr name) "org/armedbear/lisp/LispObject")))
    378 
    379 (defun cast-type (type)
    380   (let ((name (assoc type *primitive-types* :test #'string=)))
    381     (if name (cadr (caddr name)) (type-name type))))
    382 
    383 (defun converter-for-primitive-return-type (type)
    384   (assert (and (primitive-type-p type)
    385                (not (or (string= type "void")(string= type "boolean")))))
    386   (caddr (caddr (assoc type *primitive-types* :test #'string=))))
    387 
    388 (defun load-instruction (type)
    389   (let ((name (assoc type *primitive-types* :test #'string=)))
    390     (if name (cadddr name) constants.aload)))
    391 
    392 (defun return-instruction (type)
    393   (let ((name (assoc type *primitive-types* :test #'string=)))
    394     (if name (car (cddddr name)) constants.areturn)))
    395 
    396 (defun error-constant (type)
    397   (let ((name (assoc type *primitive-types* :test #'string=)))
    398     (if name (cadr (cddddr name)) constants.aconst-null)))
    399 
    400 
    401 (defun size (type)
    402   (if (or (string= type "long") (string= type "double")) 2 1))
    403 
    404 (defun modifier (m)
    405   (cond ((string= "public" m) constants.acc-public)
    406         ((string= "protected" m) constants.acc-protected)
    407         ((string= "private" m) constants.acc-private)
    408         ((string= "static" m) constants.acc-static)
    409         ((string= "abstract" m) constants.acc-abstract)
    410         ((string= "final" m) constants.acc-final)
    411         ((string= "transient" m) constants.acc-transient)
    412         ((string= "volatile" m) constants.acc-volatile)
    413         ((string= "synchronized" m) constants.acc-synchronized)
    414         (t (error "Invalid modifier ~s." m))))
    415 
    416 
    417 (defun write-method
    418   (class-writer class-name class-type-name method-name unique-method-name modifiers result-type arg-types &optional super-invocation)
    419 
    420   (let* ((args-size (reduce #'+ arg-types :key #'size))
    421          (index (+ 2 args-size))
    422          (cv (visit-method-3
    423               class-writer
    424               (reduce #'+ modifiers :key #'modifier)
    425               method-name
    426               (format nil "(~{~a~})~a"
    427                       (mapcar #'decorated-type-name arg-types) (decorated-type-name result-type)))))
    428 
    429     (when super-invocation
    430       (visit-var-insn-2 cv constants.aload 0)
    431       (loop for arg-number in (cdr super-invocation)
    432         with super-arg-types = (make-string-output-stream)
    433         do
    434         (visit-var-insn-2 cv
    435                           (load-instruction (nth (1- arg-number) arg-types))
    436                           (reduce #'+ arg-types :end (1- arg-number) :key #'size :initial-value 1))
    437         (write-string (decorated-type-name (nth (1- arg-number) arg-types)) super-arg-types)
    438         finally
    439         (visit-method-insn-4 cv constants.invokespecial
    440                              (type-name (car super-invocation)) "<init>"
    441                              (format nil "(~a)~a"
    442                                      (get-output-stream-string super-arg-types) "V"))))
    443     (visit-ldc-insn-1 cv (make-java-string class-name))
    444     (visit-method-insn-4 cv constants.invokestatic
    445                          "org/armedbear/lisp/RuntimeClass"
    446                          "getRuntimeClass"
    447                          "(Ljava/lang/String;)Lorg/armedbear/lisp/RuntimeClass;")
    448     (visit-field-insn-4 cv constants.putstatic
    449                         class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;")
    450     (visit-field-insn-4 cv constants.getstatic
    451                         class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;")
    452     (visit-ldc-insn-1 cv (make-java-string unique-method-name))
    453     (visit-method-insn-4 cv constants.invokevirtual
    454                          "org/armedbear/lisp/RuntimeClass"
    455                          "getLispMethod"
    456                          "(Ljava/lang/String;)Lorg/armedbear/lisp/Function;")
    457     (visit-var-insn-2 cv constants.astore (1+ args-size))
    458     (visit-field-insn-4 cv constants.getstatic
    459                         "org/armedbear/lisp/Lisp" "NIL" "Lorg/armedbear/lisp/LispObject;")
    460     (visit-var-insn-2 cv constants.astore (+ 2 args-size))
    461 
    462 
    463     (let ((l0 (make-label-0))(l1 (make-label-0))(l2 (make-label-0))(l3 (make-label-0)))
    464       (visit-label-1 cv l0)
    465 
    466       (visit-var-insn-2 cv constants.aload index)
    467       (visit-var-insn-2 cv constants.aload 0) ; (visit-var-insn-2 cv constants.aload 0)
    468       (visit-method-insn-4 cv constants.invokestatic
    469                            "org/armedbear/lisp/RuntimeClass" "makeLispObject"
    470                            (format nil "(~a)~a"
    471                                    (arg-type-for-make-lisp-object "java.lang.Object")
    472                                    (decorate-type-name (return-type-for-make-lisp-object "java.lang.Object"))))
    473       (visit-method-insn-4 cv constants.invokevirtual
    474                            "org/armedbear/lisp/LispObject"
    475                            "push"
    476                            "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
    477       (visit-var-insn-2 cv constants.astore (+ 2 args-size))
    478 
    479       (loop for arg-type in (reverse arg-types) and j = args-size then (- j (size arg-type))
    480         do
    481         (visit-var-insn-2 cv constants.aload index)
    482 
    483         (visit-var-insn-2 cv (load-instruction arg-type) j)
    484         (visit-method-insn-4 cv constants.invokestatic
    485                              "org/armedbear/lisp/RuntimeClass" "makeLispObject"
    486                              (format nil "(~a)~a"
    487                                      (arg-type-for-make-lisp-object arg-type)
    488                                      (decorate-type-name (return-type-for-make-lisp-object arg-type))))
    489         (visit-method-insn-4 cv constants.invokevirtual
    490                            "org/armedbear/lisp/LispObject"
    491                            "push"
    492                            "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") ;uj
    493         (visit-var-insn-2 cv constants.astore (+ 2 args-size)))
    494      
    495      
    496       (visit-var-insn-2 cv constants.aload (1- index))
    497       (visit-var-insn-2 cv constants.aload index)
    498 
    499       (visit-type-insn-2 cv constants.new "org/armedbear/lisp/Environment")
    500       (visit-insn-1 cv constants.dup)
    501       (visit-method-insn-4 cv constants.invokespecial "org/armedbear/lisp/Environment" "<init>" "()V")
    502       (visit-method-insn-4 cv constants.invokestatic
    503                            "org/armedbear/lisp/LispThread"
    504                            "currentThread"
    505                            "()Lorg/armedbear/lisp/LispThread;")
    506       (visit-method-insn-4 cv constants.invokestatic
    507                            "org/armedbear/lisp/RuntimeClass"
    508                            "evalC"
    509                            "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;")
    510       (cond
    511        ((string= "void" result-type)
    512         (visit-insn-1 cv constants.pop))
    513        ((string= "boolean" result-type)
    514         (visit-method-insn-4 cv constants.invokevirtual
    515                              (return-type-for-make-lisp-object result-type)
    516                              "getBooleanValue"
    517                              (concatenate 'string "()" (type-name result-type))))
    518        ((primitive-type-p result-type)
    519         (visit-method-insn-4 cv constants.invokevirtual
    520                              "org/armedbear/lisp/LispObject"
    521                              "javaInstance"
    522                              "()Ljava/lang/Object;")
    523         (visit-type-insn-2 cv constants.checkcast (cast-type result-type))
    524         (visit-method-insn-4 cv constants.invokevirtual
    525                              (cast-type result-type)
    526                              (converter-for-primitive-return-type result-type)
    527                              (concatenate 'string "()" (type-name result-type))
    528                              ))
    529        (t
    530         (visit-method-insn-4 cv constants.invokevirtual
    531                              "org/armedbear/lisp/LispObject" "javaInstance" "()Ljava/lang/Object;")
    532         (visit-type-insn-2 cv constants.checkcast (cast-type result-type))))
    533 
    534 
    535       (visit-label-1 cv l1)
    536       (if (string= "void" result-type)
    537           (visit-jump-insn-2 cv constants.goto l3)
    538           (visit-insn-1 cv (return-instruction result-type)))
    539       (visit-label-1 cv l2)
    540       (visit-var-insn-2 cv constants.astore (1+ index))
    541       (visit-var-insn-2 cv constants.aload (1+ index))
    542       (visit-method-insn-4 cv constants.invokevirtual
    543                            "org/armedbear/lisp/ConditionThrowable" "printStackTrace" "()V")
    544 
    545       (if (string= "void" result-type)
    546           (progn (visit-insn-1 cv (return-instruction result-type))(visit-label-1 cv l3) )
    547           (visit-insn-1 cv (error-constant result-type)))
    548 
    549       (visit-insn-1 cv (return-instruction result-type))
    550       (visit-try-catch-block-4 cv l0 l1 l2 "org/armedbear/lisp/ConditionThrowable")
    551 
    552       (visit-maxs-2 cv 0 0))))
    553 
    554 
    555 
    556 (defun jnew-runtime-class (class-name super-name interfaces constructors methods fields &optional filename)
     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)))
    55710  "Creates and loads a Java class with methods calling Lisp closures
    55811   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
    … …  
    57427   Method definitions are lists of the form
    57528   (method-name return-type argument-types function modifier*)
    576    where method-name and return-type are strings, argument-types is a list of strings and function
    577    is a lisp function of (1+ (length argument-types)) arguments; the instance (`this') is
    578    passed in as the last argument.
     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.
    57932
    58033   Field definitions are lists of the form
    … …  
    58235
    58336   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)))
    584126
    585   (let ((cw (make-class-writer-1 (make-instance 'jboolean :java-instance t)))
    586         (class-type-name (type-name class-name))
    587         (super-type-name (type-name super-name))
    588         (interface-type-names
    589          (when interfaces
    590            (let* ((no-of-interfaces (length interfaces))
    591                   (ifarray (jnew-array "java.lang.String" no-of-interfaces)))
    592              (dotimes (i no-of-interfaces ifarray)
    593                (setf (jarray-ref ifarray i) (type-name (nth i interfaces)))))))
    594         (args-for-%jnew))
    595     (visit-4 cw (+ constants.acc-public constants.acc-super)
    596              class-type-name super-type-name interface-type-names)
    597     (visit-field-3 cw (+ constants.acc-private constants.acc-static)
    598                    "rc" "Lorg/armedbear/lisp/RuntimeClass;")
     127#+example
     128(java:jnew-runtime-class
     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))))
    599136
    600     (dolist (field-def fields)
    601       (visit-field-3 cw
    602                      (reduce #'+ (cddr field-def) :key #'modifier)
    603                      (car field-def)
    604                      (decorated-type-name (cadr field-def))))
    605 
    606 
    607     (if constructors
    608         (loop for (arg-types constr-def super-invocation-args) in constructors
    609           for unique-method-name = (apply #'concatenate 'string "<init>|" arg-types)
    610           then (apply #'concatenate 'string "<init>|" arg-types)
    611           collect unique-method-name into args
    612           collect (coerce constr-def 'function) into args
    613           do
    614           (write-method
    615            cw class-name class-type-name "<init>" unique-method-name '("public") "void" arg-types
    616            (cons super-type-name super-invocation-args))
    617           finally
    618           (setf args-for-%jnew (append args-for-%jnew args)))
    619         (let ((cv (visit-method-3 cw constants.acc-public "<init>" "()V")))
    620           (visit-var-insn-2 cv constants.aload 0)
    621           (visit-method-insn-4 cv constants.invokespecial super-type-name "<init>" "()V")
    622           (visit-insn-1 cv constants.return)
    623           (visit-maxs-2 cv 1 1)))
    624 
    625     (loop for (method-name ret-type arg-types method-def . modifiers) in methods
    626       for unique-method-name = (apply #'concatenate 'string method-name "|" arg-types)
    627       then (apply #'concatenate 'string method-name "|" arg-types)
    628       collect unique-method-name into args
    629       collect (coerce method-def 'function) into args
    630       do
    631       (write-method
    632        cw class-name class-type-name method-name unique-method-name modifiers ret-type arg-types)
    633       finally
    634       (apply #'java::%jnew-runtime-class class-name (append args-for-%jnew args)))
    635 
    636     (visit-end-0 cw)
    637 
    638     (when filename
    639       (let ((os (make-file-output-stream-1 filename)))
    640         (write-1 os (to-byte-array-0 cw))
    641         (close-0 os)))
    642 
    643     (java::%load-java-class-from-byte-array class-name (java-instance (to-byte-array-0 cw)))))
    644 
    645 (defun jredefine-method (class-name method-name arg-types method-def)
    646   "Replace the definition of the method named METHDO-NAME (or
    647    constructor, if METHD-NAME is nil) of argument types ARG-TYPES of the
    648    class named CLASS-NAME defined with JNEW-RUNTIME-CLASS with
    649    METHOD-DEF. See the documentation of JNEW-RUNTIME-CLASS."
    650   (assert (jruntime-class-exists-p class-name) (class-name)
    651           "Can't redefine methods of undefined runtime class ~a" class-name)
    652   (let ((unique-method-name
    653          (apply #'concatenate 'string (if method-name method-name "<init>") "|" arg-types)))
    654     (java::%jredefine-method class-name unique-method-name  (compile nil method-def))))
    655 
    656 (defun jruntime-class-exists-p (class-name)
    657   "Returns true if a class named CLASS-NAME has been created and loaded by JNEW-RUNTIME-CLASS.
    658    Needed because Java classes cannot be reloaded."
    659   (when
    660     (jstatic (jmethod "org.armedbear.lisp.RuntimeClass" "getRuntimeClass" "java.lang.String")
    661              "org.armedbear.lisp.RuntimeClass"
    662              class-name)
    663     t))
     137(provide "RUNTIME-CLASS")
Note: See TracChangeset for help on using the changeset viewer.