jvm.lisp

(in-package jvm)
(shadow '(return pop type))

(defun read-bytes (stream n)
  ;; (loop for i from (1- n) downto 0
  ;;    sum (* (expt 256 i) (read-byte stream)))
  (loop repeat n
     collect (read-byte stream))
  )

(defun read-integer (stream bytes)
  (loop for i from (1- bytes) downto 0
     sum (* (expt 256 i) (read-byte stream))))

(defun read-short (stream)
  (read-integer stream 2))

(defun read-class-info (stream)
  `(class ,(read-short stream)))

(defun read-ref-info (stream)
  (list (read-short stream)
        (read-short stream)))

(defun read-fieldref-info (stream)
  `(fieldref ,@(read-ref-info stream)))

(defun read-methodref-info (stream)
  `(methodref ,@(read-ref-info stream)))

(defun read-interfacemethodref-info (stream)
  `(interfacemethodref ,@(read-ref-info stream)))

(defun read-string-info (stream)
  `(string ,(read-short stream)))

(defun read-integer-info (stream)
  `(integer ,(read-integer stream 4)))

(defun read-float-info (stream)
  `(float ,(read-bytes stream 4)))

(defun read-long-info (stream)
  `(long ,(read-integer stream 8)))

(defun read-double-info (stream)
  `(double ,(read-bytes stream 4)
           ,(read-bytes stream 4)))

(defun read-nameandtype-info (stream)
  `(nameandtype ,(read-short stream)
                ,(read-short stream)))

;; not correct
(defun read-utf8-info (stream)
  `(utf8 ,(concatenate 'string (mapcar #'code-char (read-bytes stream (read-short stream))))))

(defun read-methodhandle-info (stream)
  `(methodhandle ,(read-bytes stream 1)
                 ,(read-bytes stream 2)))

(defun read-methodtype-info (stream)
  `(methodtype ,(read-bytes stream 1)))

(defun read-invokedynamic-info (stream)
  `(invokedynamic ,(read-short stream)
                  ,(read-short stream)))

(defun read-exception-table (stream)
  (list (read-short stream)
        (read-short stream)
        (read-short stream)
        (read-short stream)))

;; TODO: implement
(defun nan? (x)
  (declare (ignore x))
  nil) 

(defvar *opcode-list*
  '((0 '(nop))
    (1 '(aconst-null))
    (17 `(sipush ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (19 `(ldc-w ,(funcall my-read-byte) ,(funcall my-read-byte)))
    ;; (20 `(ldc2-w ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (25 `(aload ,(funcall my-read-byte)))
    (42 '(aload-0))
    (43 '(aload-1))
    (44 '(aload-2))
    (45 '(aload-3))
    (50 '(aaload))
    (51 '(baload))
    (52 '(caload))
    (53 '(saload))
    (75 '(astore-0))
    (76 '(astore-1))
    (77 '(astore-2))
    (78 '(astore-3))
    (79 '(iastore))
    (80 '(lastore))
    (81 '(fastore))
    (82 '(dastore))
    (83 '(aastore))
    (84 '(bastore))
    (85 '(castore))
    (86 '(sastore))
    (88 '(pop2))
    (89 '(dup))
    (90 '(dup-x1))
    (91 '(dup-x2))
    (92 '(dup2))
    (93 '(dup2-x1))
    (94 '(dup2-x2))
    (95 '(swap))
    (120 '(ishl))
    (121 '(lshl))
    (122 '(ishr))
    (123 '(lshr))
    (124 '(iushr))
    (125 '(lushr))
    (127 '(land))
    (129 '(lor))
    (130 '(ixor))
    (131 '(lxor))
    (132 `(iinc ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (140 '(f2l))
    (141 '(f2d))
    (142 '(d2i))
    (143 '(d2l))
    (144 '(d2f))
    (145 '(i2b))
    (146 '(i2c))
    (147 '(i2s))
    (151 '(dcmpl))
    (152 '(dcmpg))
    (159 `(ificmpeq ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (160 `(ificmpne ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (161 `(ificmplt ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (162 `(ificmpge ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (163 `(ificmpgt ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (164 `(ificmple ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (165 `(ificmpeq ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (166 `(ificmpne ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (167 `(goto ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (168 `(jsr ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (169 `(ret ,(funcall my-read-byte)))
    ;; (170 `(tableswitch))
    ;; (171 `(lookupswitch))
    (176 '(areturn))
    (179 (list 'putstatic (funcall my-read-byte) (funcall my-read-byte)))
    (180 (list 'getfield (funcall my-read-byte) (funcall my-read-byte)))
    (181 `(putfield ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (183 `(invokespecial ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (184 `(invokestatic ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (185 `(invokeinterface ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (186 `(invokedynamic ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte)))
    ;; (187 `(new ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (188 `(newarray ,(funcall my-read-byte)))
    (189 `(anewarray ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (190 `(arraylength))
    (191 `(athrow))
    (192 `(checkcast ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (193 `(instanceof ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (194 `(monitorenter))
    (195 `(monitorexit))
    ;; (196 `(wide))
    (197 `(multianewarray ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (198 `(ifnull ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (199 `(ifnonnull ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (200 `(goto-w ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte)))
    (201 `(jsr-w ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte) ,(funcall my-read-byte)))))

(defmacro define-opcode ((code name) &rest body)
  (let ((item (list code `(list ',name ,@(mapcar #'(lambda (x) (declare (ignore x)) '(funcall my-read-byte)) (cddr (first body)))))))
    `(progn
       (unless (member ,code (mapcar #'first *opcode-list*))
         (push ',item *opcode-list*))
       (defun ,name ,@body))))

(defun current-stack (vm)
  (car (stack vm)))

(defun (setf current-stack) (value vm)
  (setf (car (stack vm)) value))

(defun pop-current-stack (vm)
  (cl:pop (current-stack vm)))

(defun discard-current-stack (vm)
  (cl:pop (stack vm)))

(defun current-pc (vm)
  (car (pc vm))) 

(defun (setf current-pc) (value vm)
  (setf (car (pc vm)) value)) 

(defun current-frame (vm)
  (car (frame vm)))

(defun nth-current-frame (vm n)
  (nth n (current-frame vm)))

(defun (setf nth-current-frame) (value vm n)
  (setf (nth n (current-frame vm)) value))

(define-opcode (18 ldc) (vm constant-pool index)
  (let ((data (nth (1- index) constant-pool)))
    (push (if (eq (first data) 'string)
              (cadadr (resolve-symbol data constant-pool))
              (resolve-symbol data constant-pool)) 
          (current-stack vm))))

(defun flatten-1 (l)
  (loop for i in l append i))

(define-opcode (20 ldc2-w) (vm constant-pool indexbyte1 indexbyte2)
  (let* ((index (2words-int indexbyte1 indexbyte2))
         (data (nth (1- index) constant-pool)))
    ;; (assert (eq (first data) 'long))
    (ccase (first data)
      (long 
       (push (ldb (byte 32 0) (second data)) (current-stack vm))
       (push (ldb (byte 32 32) (second data)) (current-stack vm)))
      (double
       (dolist (a (reverse (->words (->double-float (flatten-1 (cdr data))))))
         (push a (current-stack vm)))))))

(define-opcode (148 lcmp) (vm constant-pool)
  (declare (ignore constant-pool))
  (let ((a (pop-current-stack vm))
        (b (pop-current-stack vm)))
    (push (cond ((< a b) 1)
                ((= a b) 0)
                (t -1))
          (current-stack vm))))

(define-opcode (149 fcmpl) (vm constant-pool)
  (declare (ignore constant-pool))
  (let ((a (pop-current-stack vm))
        (b (pop-current-stack vm)))
    (push (cond ((< a b) 1)
                ((= a b) 0)
                ((> a b) -1)
                ((or (nan? a) (nan? b)) -1)
                (t (error "error in fcmpl")))
          (current-stack vm))))

(define-opcode (150 fcmpg) (vm constant-pool)
  (declare (ignore constant-pool))
  (let ((a (pop-current-stack vm))
        (b (pop-current-stack vm)))
    (push (cond ((< a b) 1)
                ((= a b) 0)
                ((> a b) -1)
                ((or (nan? a) (nan? b)) 1)
                (t (error "error in fcmpg")))
          (current-stack vm))))

(define-opcode (178 getstatic) (vm constant-pool indexbyte1 indexbyte2)
  (let ((index (2words-int indexbyte1 indexbyte2)))
    (push (nth (1- index) constant-pool) (current-stack vm))))

(defun class-from-methodref (l)
  (second l))

(defun nameandtype-from-methodref (l)
  (third l))

(defun method-name-from-methodref (l)
  (second (second (nameandtype-from-methodref l))))

(defun method-type-from-methodref (l)
  (second (third (nameandtype-from-methodref l))))

(defun push-return-value (vm size)
  (let ((data (reverse (loop repeat size collect (pop-current-stack vm)))))
    (discard-current-stack vm)
    (dolist (a data)
      (push a (current-stack vm)))))

(define-opcode (173 lreturn) (vm constant-pool)
  (declare (ignore constant-pool))
  (push-return-value vm 2))

(define-opcode (175 dreturn) (vm constant-pool)
  (declare (ignore constant-pool))
  (push-return-value vm 2))

(define-opcode (184 invokestatic) (vm constant-pool indexbyte1 indexbyte2)
  (let* ((index (2words-int indexbyte1 indexbyte2))
         (method (lookup-method (gethash (class-from-methodref (resolve-symbol (nth (1- index) constant-pool) constant-pool)) (classes vm)) 
                                (method-name-from-methodref (resolve-symbol (nth (1- index) constant-pool) constant-pool))
                                (method-type-from-methodref (resolve-symbol (nth (1- index) constant-pool) constant-pool)))))
    (push (loop repeat (max-locals method) collect (pop-current-stack vm)) (frame vm))
    (push nil (stack vm))
    (exec-method vm constant-pool method)))

;; TODO class loader
(define-opcode (187 new) (vm constant-pool indexbyte1 indexbyte2)
  (let ((index (2words-int indexbyte1 indexbyte2)))
    ;; (print (resolve-symbol (nth (1- index) constant-pool) constant-pool))
    (push (nth (1- index) constant-pool) (current-stack vm))))

(defun create-symbol (format &rest rest)
  (intern (apply #'format `(nil ,format ,@rest))))

(defun create-symbols (format &rest rest)
  (mapcar #'(lambda (x) (create-symbol format x)) rest))

(defun != (x)
  (not (= x)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  #.
  `(progn
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push ,n (current-stack vm)))) 
        '(2 3 4 5 6 7 8) 
        (create-symbols "ICONST-~A" 'm1 0 1 2 3 4 5) 
        '(-1 0 1 2 3 4 5))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push ,n (current-stack vm))
               (push 0 (current-stack vm)))) 
        '(9 10) 
        (create-symbols "LCONST-~A" 0 1) 
        '(0 1))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (dolist (a (reverse (->words ,(coerce n 'single-float))))
                 (push a (current-stack vm))))) 
        '(11 12 13) 
        (create-symbols "FCONST-~A" 0 1) 
        '(0 1 2))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (dolist (a (reverse (->words ,(coerce n 'double-float))))
                 (push a (current-stack vm))))) 
        '(14 15) 
        (create-symbols "DCONST-~A" 0 1) 
        '(0 1))
     ,@(mapcar 
        #'(lambda (code name)
            `(define-opcode (,code ,name) (vm constant-pool index)
               (declare (ignore constant-pool))
               (push (nth-current-frame vm index) (current-stack vm)))) 
        '(21 23) 
        '(iload fload))
     ,@(mapcar 
        #'(lambda (code name)
            `(define-opcode (,code ,name) (vm constant-pool index)
               (declare (ignore constant-pool))
               (setf (nth-current-frame vm index) (pop-current-stack vm)))) 
        '(54 56 58) 
        '(istore fstore astore))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (setf (nth-current-frame vm ,n) (pop-current-stack vm)))) 
        '(59 60 61 62
          67 68 69 70) 
        (append (create-symbols "ISTORE-~D" 0 1 2 3)
                (create-symbols "FSTORE-~D" 0 1 2 3)) 
        '(0 1 2 3
          0 1 2 3))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (setf (nth-current-frame vm ,n) (pop-current-stack vm))
               (setf (nth-current-frame vm ,(1+ n)) (pop-current-stack vm)))) 
        '(63 64 65 66
          71 72 73 74) 
        (append (create-symbols "LSTORE-~D" 0 1 2 3)
                (create-symbols "DSTORE-~D" 0 1 2 3)) 
        '(0 1 2 3
          0 1 2 3))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (nth-current-frame vm ,n) (current-stack vm)))) 
        '(26 27 28 29 
          34 35 36 37) 
        (append (create-symbols "ILOAD-~D" 0 1 2 3)
                (create-symbols "FLOAD-~D" 0 1 2 3))
        '(0 1 2 3 
          0 1 2 3))
     ,@(mapcar 
        #'(lambda (code name n)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (nth-current-frame vm ,(1+ n)) (current-stack vm))
               (push (nth-current-frame vm ,n) (current-stack vm)))) 
        '(30 31 32 33
          38 39 40 41) 
        (append (create-symbols "LLOAD-~D" 0 1 2 3)
                (create-symbols "DLOAD-~D" 0 1 2 3))
        '(0 1 2 3
          0 1 2 3))
     ,@(mapcar  
        #'(lambda (code name op)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (,op (pop-current-stack vm) (pop-current-stack vm)) (current-stack vm))))
        '(96 100 104 108 112 126 128)
        '(iadd isub imul idiv irem iand ior)
        '(+ - * truncate rem logand logior))
     ,@(mapcar  
        #'(lambda (code name op)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (let* ((a (2words-int (pop-current-stack vm) (pop-current-stack vm)))
                      (b (2words-int (pop-current-stack vm) (pop-current-stack vm)))
                      (value (,op a b)))
                 (push (ldb (byte 32 0) value) (current-stack vm))
                 (push (ldb (byte 32 32) value) (current-stack vm)))))
        '(97 101 105 109 113)
        '(ladd lsub lmul ldiv lrem)
        '(+ - * truncate rem))
     ,@(mapcar  
        #'(lambda (code name op)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (float (,op (pop-current-stack vm) (pop-current-stack vm))) (current-stack vm))))
        '(98 102 106 110 114)
        '(fadd fsub fmul fdiv frem)
        '(+ - * / rem))
     ,@(mapcar  
        #'(lambda (code name op)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (dolist (a (reverse (->words (,op (words->double-float (list (pop-current-stack vm) (pop-current-stack vm)))
                                                 (words->double-float (list (pop-current-stack vm) (pop-current-stack vm)))))))
                 (push a (current-stack vm)))))
        '(99 103 107 111 115)
        '(dadd dsub dmul ddiv drem)
        '(+ - * / rem))
     ,@(mapcar
        #'(lambda (code name)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (- (pop-current-stack vm)) (current-stack vm))))
        '(116 117 118 119)
        '(ineg lneg fneg dneg))
     ,@(mapcar
        #'(lambda (code name)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (push (pop-current-stack vm) (current-stack vm))))
        '(133 134 135
          136 137 138)
        '(i2l i2f i2d
          l2i l2f l2d))
     ,@(mapcar
        #'(lambda (code name)
            `(define-opcode (,code ,name) (vm constant-pool)
               (declare (ignore constant-pool))
               (let ((value (pop-current-stack vm)))
                 (discard-current-stack vm)
                 (push value (current-stack vm)))))
        '(172 174)
        '(ireturn freturn))
     ,@(mapcar
        #'(lambda (code name op)
            `(define-opcode (,code ,name) (vm constant-pool branchbyte1 branchbyte2)
               (declare (ignore constant-pool))
               (let ((branch (2words-int branchbyte1 branchbyte2)))
                 (when (,op (pop-current-stack vm) 0)
                   (incf (current-pc vm) branch)))))
        '(153 154 155 156 157 158)
        '(ifeq ifne iflt ifge ifgt ifle)
        '(= != < >= > <=))
     ))

(define-opcode (22 lload) (vm constant-pool index)
  (declare (ignore constant-pool))
  (push (nth-current-frame vm (1+ index)) (current-stack vm))
  (push (nth-current-frame vm index) (current-stack vm)))

(define-opcode (24 dload) (vm constant-pool index)
  (declare (ignore constant-pool))
  (push (nth-current-frame vm (1+ index)) (current-stack vm))
  (push (nth-current-frame vm index) (current-stack vm)))

(define-opcode (55 lstore) (vm constant-pool index)
  (declare (ignore constant-pool))
  (setf (nth-current-frame vm index) (pop-current-stack vm))
  (setf (nth-current-frame vm (1+ index)) (pop-current-stack vm)))

(define-opcode (57 dstore) (vm constant-pool index)
  (declare (ignore constant-pool))
  (setf (nth-current-frame vm index) (pop-current-stack vm))
  (setf (nth-current-frame vm (1+ index)) (pop-current-stack vm)))

(define-opcode (16 bipush) (vm constant-pool byte)  
  (declare (ignore constant-pool))
  (push byte (current-stack vm)))

(define-opcode (87 pop) (vm constant-pool byte)
  (declare (ignore constant-pool))
  (pop-current-stack vm))

(define-opcode (139 f2i) (vm constant-pool)
  (declare (ignore constant-pool))
  (push (truncate (float (pop-current-stack vm))) (current-stack vm)))

(define-opcode (182 invokevirtual) (vm constant-pool indexbyte1 indexbyte2)
  ;; (print (stack vm))
  ;; (print (frame vm))
  (push nil (frame vm))
  (let ((index (2words-int indexbyte1 indexbyte2)))
    (let ((methodref (resolve-symbol (nth (1- index) constant-pool) constant-pool)))
      (cond 
        ((equal methodref '(METHODREF (CLASS (UTF8 "java/io/PrintStream")) (NAMEANDTYPE (UTF8 "println") (UTF8 "(I)V"))))
         (format t "~D~%" (pop-current-stack vm)))
        ((equal methodref '(METHODREF (CLASS (UTF8 "java/io/PrintStream")) (NAMEANDTYPE (UTF8 "println") (UTF8 "(J)V"))))
         (format t "~D~%" (2words-signed-int (pop-current-stack vm) (pop-current-stack vm))))
        ((equal methodref '(METHODREF (CLASS (UTF8 "java/io/PrintStream")) (NAMEANDTYPE (UTF8 "println") (UTF8 "(F)V"))))
         (format t "~D~%" (pop-current-stack vm)))
        ((equal methodref '(METHODREF (CLASS (UTF8 "java/io/PrintStream")) (NAMEANDTYPE (UTF8 "println") (UTF8 "(D)V"))))
         (format t "~D~%" (words->double-float (list (pop-current-stack vm) (pop-current-stack vm)))))
        ((equal methodref '(METHODREF (CLASS (UTF8 "java/io/PrintStream")) (NAMEANDTYPE (UTF8 "println") (UTF8 "(Ljava/lang/String;)V"))))
         (format t "~D~%" (pop-current-stack vm)))
        (t (print methodref)))))
  (cl:pop (frame vm)))

(define-opcode (177 return) (vm constant-pool)
  (declare (ignore constant-pool))
  (discard-current-stack vm))

(defun dispatch-opcode (opcode my-read-byte)
  #.(append '(ccase opcode) *opcode-list*))

(defun read-code (stream length)
  (let ((offset 0))
    (flet ((my-read-byte ()
             (incf offset)
             (read-byte stream)))
      (loop while (< offset length)
         for start = offset
         for opcode = (my-read-byte) 
         for code = (dispatch-opcode opcode #'my-read-byte)
         for end = offset
         collect `(,start ,end ,@code)))))

(defun read-code-attribute (stream constant-pool)
  (let* ((max-stack (read-short stream))
         (max-locals (read-short stream))
         (code (read-code stream (read-integer stream 4)))
         (exception-table (loop repeat (read-short stream) 
                             collect (read-exception-table stream)))
         (attributes (loop repeat (read-short stream) 
                        collect (read-attribute-info stream constant-pool))))
      (list max-stack
            max-locals
            code
            exception-table
            attributes)))

(defun read-linenumbertable-attribute (stream)
  (loop repeat (read-short stream) 
     collect (cons (read-short stream)    ;start_pc
                   (read-short stream)))) ;line_number

(defun read-variable-info (stream)
  (let ((type (read-byte stream)))
    (ccase type
      (0 'top)
      (1 'integer)
      (2 'float)
      (3 'double)
      (4 'long)
      (5 'null)
      (6 'uninitialized-this)
      (7 `(object ,(read-short stream)))
      (8 `(uninitialized ,(read-short stream))))))

(defun read-stack-map-frame (stream)
  (let ((type (read-byte stream)))
    (cond ((and (>= type 0) (<= type 63)) 'same)
          ((and (>= type 64) (<= type 127)) `(same-locals-1-stack-item ,(read-variable-info stream)))
          ((= type 247) `(same-locals-1-stack-item-extended ,(read-short stream) ,(read-variable-info stream)))
          ((= type 255) `(full-frame ,(read-short stream) 
                                     ,(loop repeat (read-short stream) collect (read-variable-info stream))
                                     ,(loop repeat (read-short stream) collect (read-variable-info stream))))
          (t (error "type ~D is not handled in read-stack-map-frame" type)))
    ))

(defun read-stackmaptable-attribute (stream)
  (loop repeat (read-short stream) 
     collect (read-stack-map-frame stream)))

(defun extract-name (l)
  (if (listp (second l))
      (extract-name (second l))
      (second l)))

(defun name-from-constant-pool (index constant-pool)
  ;; (print index)
  ;; (print constant-pool)
  ;; (print (second (nth (1- index) constant-pool)))
  (extract-name (resolve-symbol (nth (1- index) constant-pool) constant-pool)) 
  ;; (second (nth (1- index) constant-pool))
  )

(defun read-attribute-info (stream constant-pool)
  (let ((a (read-short stream)))
;;    (print constant-pool)
;;    (print (resolve-symbol (print (nth (1- a) (print constant-pool))) constant-pool))
    (let ((name (intern (string-upcase (name-from-constant-pool a constant-pool)) (find-package 'jvm)))
          (length (read-integer stream 4)))
      ;;(print name)
      ;; (print length)
      `(,name ,(cond ((eq 'code name) 
                      (read-code-attribute stream constant-pool))
                     ((eq 'StackMapTable name) 
                      (read-stackmaptable-attribute stream))          
                     ((eq 'LineNumberTable name) 
                      (read-linenumbertable-attribute stream))
                     (t (loop repeat length 
                           collect (read-byte stream))))))))

(defclass method-info ()
  ((access-flags :initform nil :initarg :access-flags :reader access-flags)
   (name :initform nil :initarg :name :reader name)
   (type :initform nil :initarg :type :reader type)
   (code :initform nil :initarg :code :reader code)))

(defun read-method-info (stream constant-pool)
  (make-instance 'method-info
                 :access-flags (read-short stream)
                 :name (name-from-constant-pool (read-short stream) constant-pool)
                 :type (name-from-constant-pool (read-short stream) constant-pool) 
                 :code (loop repeat (read-short stream)
                          collect (read-attribute-info stream constant-pool))))

(defun read-field-info (stream constant-pool)
  `(field ,(read-short stream)      ;access flags
          ,(name-from-constant-pool (read-short stream) constant-pool)
          ,(name-from-constant-pool (read-short stream) constant-pool)
          ,(loop repeat (read-short stream)
              collect (read-attribute-info stream constant-pool))))

(defun read-constant-pool (stream count)
  (loop with skip = nil
     repeat (1- count)
     for type = (if skip 
                    (setf skip nil)
                    (read-byte stream)) 
     collect (when type
               (ccase type 
                 (1 (read-utf8-info stream))
                 (3 (read-integer-info stream))
                 (4 (read-float-info stream))
                 (5 (setf skip t) (read-long-info stream)) ; consumes 2 pools
                 (6 (setf skip t) (read-double-info stream)) ; consumes 2 pools
                 (7 (read-class-info stream))
                 (8 (read-string-info stream))
                 (9 (read-fieldref-info stream))
                 (10 (read-methodref-info stream))
                 (11 (read-interfacemethodref-info stream))
                 (12 (read-nameandtype-info stream))
                 (15 (read-methodref-info stream))
                 (16 (read-methodtype-info stream))
                 (18 (read-invokedynamic-info stream))))))

(defclass virtual-machine ()
  ((stack :initform (list nil) :accessor stack)
   (frame :initform nil :accessor frame)
   (classes :initform (make-hash-table :test 'equal) :accessor classes)
   (pc :initform (list nil) :accessor pc)))

(defclass class-file ()
  ((magic :initform nil :initarg :magic :reader magic)
   (minor-version :initform nil :initarg :minor-version :reader minor-version)
   (major-version :initform nil :initarg :major-version :reader major-version)
   (constant-pool :initform nil :initarg :constant-pool :reader constant-pool)
   (access-flags :initform nil :initarg :access-flags :reader access-flags)
   (this-class :initform nil :initarg :this-class :reader this-class)
   (super-class :initform nil :initarg :super-class :reader super-class)
   (interfaces :initform nil :initarg :interfaces :reader interfaces)
   (fields :initform nil :initarg :fields :reader fields)
   (methods :initform nil :initarg :methods :reader methods)
   (attributes :initform nil :initarg :attributes :reader attributes)))

(defun read-class-file (file-path)
  (with-open-file (s file-path :direction :input :element-type '(unsigned-byte 8))
    (let ((magic (read-bytes s 4))
          (minor-version (read-short s))
          (major-version (read-short s))
          (constant-pool (read-constant-pool s (read-short s))))
      (make-instance 'class-file 
                     :magic magic 
                     :minor-version minor-version 
                     :major-version major-version
                     :constant-pool constant-pool
                     :access-flags (read-short s)
                     :this-class (read-short s)
                     :super-class (read-short s)
                     :interfaces (loop repeat (read-short s)
                                    collect (read-short s))
                     :fields (loop repeat (read-short s)
                                collect (read-field-info s constant-pool))
                     :methods (loop repeat (read-short s)
                                 collect (read-method-info s constant-pool))
                     :attributes (loop repeat (read-short s)
                                    collect (read-attribute-info s constant-pool))))))

(defun lookup-method (class-file name type)
  (car (remove-if-not #'(lambda (x) (and (string= name (name x))
                                         (equal type (type x))))
                      (methods class-file))))

(defun code-from-method (method)
  (third (second (first (code method)))))

(defmethod max-stack ((obj method-info))
  (first (second (first (code obj)))))

(defmethod max-locals ((obj method-info))
  (second (second (first (code obj)))))

(defun make-code-offset-hash (l)
  (loop with h = (make-hash-table)
     for item in l
     do (setf (gethash (first item) h) item)
     finally (cl:return h)))

(defun exec-method (vm constant-pool method)
  (push 0 (pc vm))
  (loop with code-offset-hash = (make-code-offset-hash (code-from-method method))
     while (gethash (current-pc vm) code-offset-hash nil)
     for (start . (end . (opcode . args))) = (gethash (current-pc vm) code-offset-hash nil)
     do (setf (current-pc vm) end)
       ;; (print (frame vm))
       ;; (print (stack vm))
       ;; (print `(,opcode ,@args))
       (apply opcode `(,vm ,constant-pool ,@args))
       ;; (print (frame vm))
       ;; (print (stack vm))
       )
  (cl:pop (frame vm))
  (cl:pop (pc vm)))

(defun exec-class-file (file-path)
  (let ((class-file (read-class-file file-path))
        (vm (make-instance 'virtual-machine)))
    (setf (gethash (resolve-symbol (nth (1- (this-class class-file)) (constant-pool class-file)) (constant-pool class-file)) (classes vm))
          class-file)
    ;; (print (methods class-file))
    (let ((method (lookup-method class-file "main" "([Ljava/lang/String;)V")))
      (setf (frame vm) (list (loop repeat (max-locals method) collect nil)))
      (exec-method vm (constant-pool class-file) method))))

(defun resolve-symbol (symbol constant-pool)
  (destructuring-bind (type &rest args)
      symbol
    (cond 
      ((eq type 'class)
       `(class ,(resolve-symbol (nth (1- (first args)) constant-pool) constant-pool)))
      ((eq type 'methodref)
       `(methodref ,(resolve-symbol (nth (1- (first args)) constant-pool) constant-pool) 
                   ,(resolve-symbol (nth (1- (second args)) constant-pool) constant-pool)))
      ((eq type 'fieldref)
       `('fieldref ,(resolve-symbol (nth (1- (first args)) constant-pool) constant-pool) 
                   ,(resolve-symbol (nth (1- (second args)) constant-pool) constant-pool)))
      ((eq type 'nameandtype)
       `(nameandtype ,(resolve-symbol (nth (1- (first args)) constant-pool) constant-pool) 
                     ,(resolve-symbol (nth (1- (second args)) constant-pool) constant-pool)))
      ((eq type 'string)
       `(string ,(resolve-symbol (nth (1- (first args)) constant-pool) constant-pool)))
      ((eq type 'float)
       (->single-float (car args)))
      (t symbol))))