source: branches/0.22.x/abcl/src/org/armedbear/lisp/runtime-class.lisp

Last change on this file was 11391, checked in by vvoutilainen, 16 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
​http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 38.0 KB
Line 
1;;; runtime-class.lisp
2;;;
3;;; Copyright (C) 2004 Peter Graves
4;;; $Id: runtime-class.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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.
31
32(in-package :java)
33
34(require :format)
35
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)
557  "Creates and loads a Java class with methods calling Lisp closures
558   as given in METHODS.  CLASS-NAME and SUPER-NAME are strings,
559   INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are
560   lists of constructor, method and field definitions.
561
562   Constructor definitions are lists of the form
563   (argument-types function &optional super-invocation-arguments)
564   where argument-types is a list of strings and function is a lisp function of
565   (1+ (length argument-types)) arguments; the instance (`this') is passed in as
566   the last argument. The optional super-invocation-arguments is a list of numbers
567   between 1 and (length argument-types), where the number k stands for the kth argument
568   to the just defined constructor. If present, the constructor of the superclass
569   will be called with the appropriate arguments. E.g., if the constructor definition is
570   ((\"java.lang.String\" \"int\") #'(lambda (string i this) ...) (2 1))
571   then the constructor of the superclass with argument types (int, java.lang.String) will
572   be called with the second and first arguments.
573
574   Method definitions are lists of the form
575   (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.
579
580   Field definitions are lists of the form
581   (field-name type modifier*)
582
583   If FILE-NAME is given, a .class file will be written; this is useful for debugging only."
584
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;")
599
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))
Note: See TracBrowser for help on using the repository browser.