diff --git a/src/org/armedbear/lisp/jvm-instructions.lisp b/src/org/armedbear/lisp/jvm-instructions.lisp index 8626ab979..335140739 100644 --- a/src/org/armedbear/lisp/jvm-instructions.lisp +++ b/src/org/armedbear/lisp/jvm-instructions.lisp @@ -143,8 +143,8 @@ (define-opcode ldc2_w 20 3 2 nil "P") (define-opcode iload 21 2 1 t) (define-opcode lload 22 2 2 t) -(define-opcode fload 23 2 nil t) -(define-opcode dload 24 2 nil t) +(define-opcode fload 23 2 1 t) +(define-opcode dload 24 2 2 t) (define-opcode aload 25 2 1 t) (define-opcode iload_0 26 1 1 0) (define-opcode iload_1 27 1 1 1) @@ -154,14 +154,14 @@ (define-opcode lload_1 31 1 2 1) (define-opcode lload_2 32 1 2 2) (define-opcode lload_3 33 1 2 3) -(define-opcode fload_0 34 1 nil 0) -(define-opcode fload_1 35 1 nil 1) -(define-opcode fload_2 36 1 nil 2) -(define-opcode fload_3 37 1 nil 3) -(define-opcode dload_0 38 1 nil 0) -(define-opcode dload_1 39 1 nil 1) -(define-opcode dload_2 40 1 nil 2) -(define-opcode dload_3 41 1 nil 3) +(define-opcode fload_0 34 1 1 0) +(define-opcode fload_1 35 1 1 1) +(define-opcode fload_2 36 1 1 2) +(define-opcode fload_3 37 1 1 3) +(define-opcode dload_0 38 1 2 0) +(define-opcode dload_1 39 1 2 1) +(define-opcode dload_2 40 1 2 2) +(define-opcode dload_3 41 1 2 3) (define-opcode aload_0 42 1 1 0) (define-opcode aload_1 43 1 1 1) (define-opcode aload_2 44 1 1 2) @@ -176,8 +176,8 @@ (define-opcode saload 53 1 nil nil) (define-opcode istore 54 2 -1 t) (define-opcode lstore 55 2 -2 t) -(define-opcode fstore 56 2 nil t) -(define-opcode dstore 57 2 nil t) +(define-opcode fstore 56 2 -1 t) +(define-opcode dstore 57 2 -2 t) (define-opcode astore 58 2 -1 t) (define-opcode istore_0 59 1 -1 0) (define-opcode istore_1 60 1 -1 1) @@ -187,14 +187,14 @@ (define-opcode lstore_1 64 1 -2 1) (define-opcode lstore_2 65 1 -2 2) (define-opcode lstore_3 66 1 -2 3) -(define-opcode fstore_0 67 1 nil 0) -(define-opcode fstore_1 68 1 nil 1) -(define-opcode fstore_2 69 1 nil 2) -(define-opcode fstore_3 70 1 nil 3) -(define-opcode dstore_0 71 1 nil 0) -(define-opcode dstore_1 72 1 nil 1) -(define-opcode dstore_2 73 1 nil 2) -(define-opcode dstore_3 74 1 nil 3) +(define-opcode fstore_0 67 1 -1 0) +(define-opcode fstore_1 68 1 -1 1) +(define-opcode fstore_2 69 1 -1 2) +(define-opcode fstore_3 70 1 -1 3) +(define-opcode dstore_0 71 1 -2 0) +(define-opcode dstore_1 72 1 -2 1) +(define-opcode dstore_2 73 1 -2 2) +(define-opcode dstore_3 74 1 -2 3) (define-opcode astore_0 75 1 -1 0) (define-opcode astore_1 76 1 -1 1) (define-opcode astore_2 77 1 -1 2) @@ -292,11 +292,10 @@ ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors (define-opcode tableswitch 170 0 nil nil) (define-opcode lookupswitch 171 0 nil nil) -(define-opcode ireturn 172 1 nil nil) -(define-opcode lreturn 173 1 nil nil) -(define-opcode freturn 174 1 nil nil) -(define-opcode dreturn 175 1 nil nil) (define-opcode ireturn 172 1 -1 nil) +(define-opcode lreturn 173 1 -2 nil) +(define-opcode freturn 174 1 -1 nil) +(define-opcode dreturn 175 1 -2 nil) (define-opcode areturn 176 1 -1 nil) (define-opcode return 177 1 0 nil) (define-opcode getstatic 178 3 1 nil "P") @@ -479,6 +478,60 @@ (3 (emit 'istore_3)) (t (emit 'istore index)))) +(defknown lload (fixnum) t) +(defun lload (index) + (case index + (0 (emit 'lload_0)) + (1 (emit 'lload_1)) + (2 (emit 'lload_2)) + (3 (emit 'lload_3)) + (t (emit 'lload index)))) + +(defknown lstore (fixnum) t) +(defun lstore (index) + (case index + (0 (emit 'lstore_0)) + (1 (emit 'lstore_1)) + (2 (emit 'lstore_2)) + (3 (emit 'lstore_3)) + (t (emit 'lstore index)))) + +(defknown fload (fixnum) t) +(defun fload (index) + (case index + (0 (emit 'fload_0)) + (1 (emit 'fload_1)) + (2 (emit 'fload_2)) + (3 (emit 'fload_3)) + (t (emit 'fload index)))) + +(defknown fstore (fixnum) t) +(defun fstore (index) + (case index + (0 (emit 'fstore_0)) + (1 (emit 'fstore_1)) + (2 (emit 'fstore_2)) + (3 (emit 'fstore_3)) + (t (emit 'fstore index)))) + +(defknown dload (fixnum) t) +(defun dload (index) + (case index + (0 (emit 'dload_0)) + (1 (emit 'dload_1)) + (2 (emit 'dload_2)) + (3 (emit 'dload_3)) + (t (emit 'dload index)))) + +(defknown dstore (fixnum) t) +(defun dstore (index) + (case index + (0 (emit 'dstore_0)) + (1 (emit 'dstore_1)) + (2 (emit 'dstore_2)) + (3 (emit 'dstore_3)) + (t (emit 'dstore index)))) + (declaim (ftype (function (t) t) branch-p) (inline branch-p)) (defun branch-p (opcode) @@ -621,6 +674,18 @@ 27 ; iload_1 28 ; iload_2 29 ; iload_3 + 30 ; lload_0 + 31 ; lload_1 + 32 ; lload_2 + 33 ; lload_3 + 34 ; fload_0 + 35 ; fload_1 + 36 ; fload_2 + 37 ; fload_3 + 38 ; dload_0 + 39 ; dload_1 + 40 ; dload_2 + 41 ; dload_3 42 ; aload_0 43 ; aload_1 44 ; aload_2 @@ -635,6 +700,18 @@ 60 ; istore_1 61 ; istore_2 62 ; istore_3 + 63 ; lstore_0 + 64 ; lstore_1 + 65 ; lstore_2 + 66 ; lstore_3 + 67 ; fstore_0 + 68 ; fstore_1 + 69 ; fstore_2 + 70 ; fstore_3 + 71 ; dstore_0 + 72 ; dstore_1 + 73 ; dstore_2 + 74 ; dstore_3 75 ; astore_0 76 ; astore_1 77 ; astore_2 @@ -708,6 +785,9 @@ 166 ; if_acmpne 167 ; goto 172 ; ireturn + 173 ; lreturn + 174 ; freturn + 175 ; dreturn 176 ; areturn 177 ; return 189 ; anewarray @@ -769,6 +849,22 @@ (define-resolver 55 (instruction) (load/store-resolver instruction 63 55 "LSTORE unsupported case")) +;; fload +(define-resolver 23 (instruction) + (load/store-resolver instruction 34 23 "FLOAD unsupported case")) + +;; fstore +(define-resolver 56 (instruction) + (load/store-resolver instruction 67 56 "FSTORE unsupported case")) + +;; dload +(define-resolver 24 (instruction) + (load/store-resolver instruction 38 24 "DLOAD unsupported case")) + +;; dstore +(define-resolver 57 (instruction) + (load/store-resolver instruction 71 57 "DSTORE unsupported case")) + ;; bipush, sipush (define-resolver (16 17) (instruction) (let* ((args (instruction-args instruction)) diff --git a/src/org/armedbear/lisp/runtime-class.lisp b/src/org/armedbear/lisp/runtime-class.lisp index e1bffe4a8..78295906e 100644 --- a/src/org/armedbear/lisp/runtime-class.lisp +++ b/src/org/armedbear/lisp/runtime-class.lisp @@ -60,6 +60,10 @@ jclass)))) (defconstant +abcl-lisp-integer-object+ (make-jvm-class-name "org.armedbear.lisp.LispInteger")) +(defconstant +abcl-lisp-object-object+ (make-jvm-class-name "org.armedbear.lisp.LispObject")) +(defconstant +abcl-single-float-object+ (make-jvm-class-name "org.armedbear.lisp.SingleFloat")) +(defconstant +abcl-double-float-object+ (make-jvm-class-name "org.armedbear.lisp.DoubleFloat")) +(defconstant +abcl-lisp-character-object+ (make-jvm-class-name "org.armedbear.lisp.LispCharacter")) (defun box-arguments (argument-types offset all-argc) ;;Box each argument @@ -68,10 +72,30 @@ :for i :from offset :do (progn (cond - ((eq arg-type :int) + ((member arg-type '(:int :short :byte)) (iload i) (emit-invokestatic +abcl-lisp-integer-object+ "getInstance" (list :int) +abcl-lisp-integer-object+)) + ((eq arg-type :long) + (lload i) + (emit-invokestatic +abcl-lisp-integer-object+ "getInstance" + (list :long) +abcl-lisp-integer-object+)) + ((eq arg-type :float) + (fload i) + (emit-invokestatic +abcl-single-float-object+ "getInstance" + (list :float) +abcl-single-float-object+)) + ((eq arg-type :double) + (dload i) + (emit-invokestatic +abcl-double-float-object+ "getInstance" + (list :double) +abcl-double-float-object+)) + ((eq arg-type :boolean) + (iload i) + (emit-invokestatic +abcl-lisp-object-object+ "getInstance" + (list :boolean) +abcl-lisp-object-object+)) + ((eq arg-type :char) + (iload i) + (emit-invokestatic +abcl-lisp-character-object+ "getInstance" + (list :char) +abcl-lisp-character-object+)) ((keywordp arg-type) (error "Unsupported arg-type: ~A" arg-type)) (t (aload i) @@ -178,12 +202,27 @@ ((eq return-type :void) (emit 'pop) (emit 'return)) - ((eq return-type :int) + ((member return-type '(:int :short :byte)) (emit-invokevirtual +lisp-object+ "intValue" nil :int) (emit 'ireturn)) + ((eq return-type :long) + (emit-invokevirtual +lisp-object+ "longValue" nil :long) + (emit 'lreturn)) + ((eq return-type :float) + (emit-invokevirtual +lisp-object+ "floatValue" nil :float) + (emit 'freturn)) + ((eq return-type :double) + (emit-invokevirtual +lisp-object+ "doubleValue" nil :double) + (emit 'dreturn)) ((eq return-type :boolean) (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean) (emit 'ireturn)) + ((eq return-type :char) + ;; FIXME: how does this call not work? + ;; (emit-invokevirtual +lisp-character+ "getValue" nil :char) + (emit-invokestatic +lisp-character+ "getValue" + (list +lisp-object+) :char) + (emit 'ireturn)) ((jvm-class-name-p return-type) (emit 'ldc_w (pool-class return-type)) (emit-invokevirtual +lisp-object+ "javaInstance" (list +java-class+) +java-object+)