(in-package :cl-uxn)

(defmacro define-instruction (name args &body body)
  `(defun ,name (instance opcode)
     (with-uxn (instance)
       (let* ((mode-short (mode-short-p opcode))
              (mode-return (mode-return-p opcode))
              (mode-keep (mode-keep-p opcode))
              (stack (if mode-return return-stack work-stack))
              (start-pointer (uxn-stack-index stack)))
         (declare (ignorable mode-short))
         (macrolet ((get-value (&optional size)
                      (case size
                        (byte '(stack-pop stack nil))
                        (short '(stack-pop stack t))
                        (t '(stack-pop stack mode-short))))
                    (put-value (value &optional size)
                      (case size
                        (byte `(stack-push stack ,value nil))
                        (short `(stack-push stack ,value t))
                        (t `(stack-push stack ,value mode-short))))
                    (memory-get (address chop &optional size)
                      (case size
                        (byte `(memory-read memory ,address ,chop nil))
                        (short `(memory-read memory ,address ,chop t))
                        (t `(memory-read memory ,address ,chop mode-short))))
                    (memory-put (address value chop &optional size)
                      (case size
                        (byte `(memory-write memory ,address ,value ,chop nil))
                        (short `(memory-write memory ,address ,value ,chop t))
                        (t `(memory-write memory ,address ,value ,chop mode-short)))))
           (let* ,(parse-define-instruction-args args)
             (declare (ignorable ,@(symbol-or-first args)))
             (when mode-keep
               (setf (uxn-stack-index stack) start-pointer))
             ,@body))))))

(define-instruction op-null ())
(define-instruction op-jci ((c byte))
  (let ((addr (memory-get program-counter #x10000 short)))
    (unless (zerop c)
      (setf-16 program-counter (+ program-counter addr))))
  (setf-16 program-counter (+ program-counter 2)))
(define-instruction op-jmi ()
  (let ((addr (memory-get program-counter #x10000 short)))
    (setf-16 program-counter (+ program-counter addr 2))))
(define-instruction op-jsi ()
  (stack-push return-stack (+ program-counter 2) 'short)
  (let ((addr (memory-get program-counter #x10000 short)))
    (setf-16 program-counter (+ program-counter addr 2))))
(define-instruction op-lit ()
  (put-value (aref memory program-counter) byte)
  (setf-16 program-counter (1+ program-counter))
  (when mode-short
    (put-value (aref memory program-counter) byte)
    (setf-16 program-counter (1+ program-counter))))
(define-instruction op-inc (a)
  (put-value (1+ a)))
(define-instruction op-pop (x))
(define-instruction op-nip (a x)
  (put-value a))
(define-instruction op-swp (a b)
  (put-value a) (put-value b))
(define-instruction op-rot (a b c)
  (put-value b) (put-value a) (put-value c))
(define-instruction op-dup (a)
  (put-value a) (put-value a))
(define-instruction op-ovr (a b)
  (put-value b) (put-value a) (put-value b))
(define-instruction op-equ (a b)
  (put-value (if (= b a) 1 0)
             byte))
(define-instruction op-neq (a b)
  (put-value (if (/= b a) 1 0)
             byte))
(define-instruction op-gth (a b)
  (put-value (if (> b a) 1 0)
             byte))
(define-instruction op-lth (a b)
  (put-value (if (< b a) 1 0)
             byte))
(define-instruction op-jmp (addr)
  (setf-16 program-counter
           (if mode-short
               addr
               (+ program-counter (signify addr)))))
(define-instruction op-jcn (addr (c byte))
  (unless (zerop c)
    (setf-16 program-counter
             (if mode-short
                 addr
                 (+ program-counter (signify addr))))))
(define-instruction op-jsr (addr)
  (stack-push (if mode-return work-stack return-stack) program-counter t)
  (setf-16 program-counter
           (if mode-short
               addr
               (+ program-counter (signify addr)))))
(define-instruction op-sth (a)
  (stack-push (if mode-return work-stack return-stack) a mode-short))
(define-instruction op-ldz ((addr byte))
  (put-value (memory-get addr #x100)))
(define-instruction op-stz ((addr byte) val)
  (memory-put addr val #x100))
(define-instruction op-ldr ((addr byte))
  (put-value (memory-get (+ program-counter (signify addr)) #x10000)))
(define-instruction op-str ((addr byte) val)
  (memory-put (+ program-counter (signify addr)) val #x10000))
(define-instruction op-lda ((addr short))
  (put-value (memory-get addr #x10000)))
(define-instruction op-sta ((addr short) val)
  (memory-put addr val #x10000))
(define-instruction op-dei ((addr byte))
  (let ((val (funcall *device-input* addr)))
    (when mode-short
      (setf val
            (ash val 8))
      (setf (ldb (byte 8 0) val)
            (funcall *device-input* (mod (1+ addr) #x100))))
    (put-value val)))
(define-instruction op-deo ((addr byte) val)
  (cond (mode-short (funcall *device-output*
                             addr
                             (ldb (byte 8 8) val))
                    (funcall *device-output*
                             (mod (1+ addr) #x100)
                             (ldb (byte 8 0) val)))
        (t (funcall *device-output* addr val))))
(define-instruction op-add (a b)
  (put-value (+ b a)))
(define-instruction op-sub (a b)
  (put-value (- b a)))
(define-instruction op-mul (a b)
  (put-value (* b a)))
(define-instruction op-div (a b)
  (put-value (if (zerop a) 0 (floor b a))))
(define-instruction op-and (a b)
  (put-value (logand b a)))
(define-instruction op-ora (a b)
  (put-value (logior b a)))
(define-instruction op-eor (a b)
  (put-value (logxor b a)))
(define-instruction op-sft ((a byte) b)
  (put-value (ash (ash b
                       (- (ldb (byte 4 0) a)))
                  (ldb (byte 4 4) a))))

(defmacro register-op-family (&rest args)
  (list*
   'setf
   (mapcan
    (lambda (i)
      (let ((family (first i))
            (function (second i)))
        `((aref *opcode-dispatch-table* (logior ,family #x00)) #',function
          (aref *opcode-dispatch-table* (logior ,family #x20)) #',function
          (aref *opcode-dispatch-table* (logior ,family #x40)) #',function
          (aref *opcode-dispatch-table* (logior ,family #x60)) #',function
          (aref *opcode-dispatch-table* (logior ,family #x80)) #',function
          (aref *opcode-dispatch-table* (logior ,family #xa0)) #',function
          (aref *opcode-dispatch-table* (logior ,family #xc0)) #',function
          (aref *opcode-dispatch-table* (logior ,family #xe0)) #',function)))
    args)))

(register-op-family (+inc+ op-inc)
                    (+pop+ op-pop)
                    (+nip+ op-nip)
                    (+swp+ op-swp)
                    (+rot+ op-rot)
                    (+dup+ op-dup)
                    (+ovr+ op-ovr)
                    (+equ+ op-equ)
                    (+neq+ op-neq)
                    (+gth+ op-gth)
                    (+lth+ op-lth)
                    (+jmp+ op-jmp)
                    (+jcn+ op-jcn)
                    (+jsr+ op-jsr)
                    (+sth+ op-sth)
                    (+ldz+ op-ldz)
                    (+stz+ op-stz)
                    (+ldr+ op-ldr)
                    (+str+ op-str)
                    (+lda+ op-lda)
                    (+sta+ op-sta)
                    (+dei+ op-dei)
                    (+deo+ op-deo)
                    (+add+ op-add)
                    (+sub+ op-sub)
                    (+mul+ op-mul)
                    (+div+ op-div)
                    (+and+ op-and)
                    (+ora+ op-ora)
                    (+eor+ op-eor)
                    (+sft+ op-sft))
(setf (aref *opcode-dispatch-table* +brk+) #'op-null
      (aref *opcode-dispatch-table* +jci+) #'op-jci
      (aref *opcode-dispatch-table* +jmi+) #'op-jmi
      (aref *opcode-dispatch-table* +jsi+) #'op-jsi
      (aref *opcode-dispatch-table* +lit+) #'op-lit
      (aref *opcode-dispatch-table* #xa0) #'op-lit
      (aref *opcode-dispatch-table* #xc0) #'op-lit
      (aref *opcode-dispatch-table* #xe0) #'op-lit)