(in-package #:user-side-compiler)

(defgeneric check-arguments (instruction))

(defclass instruction ()
  ((%mnemonic :allocation :class :reader mnemonic :initarg :mnemonic)
   (%operand :accessor operand :initarg :operand)
   (%next :accessor next :accessor normal-next :initarg :next)
   (%source :accessor source :initarg :source :initform nil)))

(defmethod print-object ((object instruction) stream)
  (cond ((some (lambda (type)
                 (typep object type))
               '(immediate-mixin accumulator-mixin zero-page-mixin absolute-mixin))
         (format stream "#<~A ~A~A~A>"
                 (mnemonic object)
                 (typecase object
                   (immediate-mixin "#")
                   ((member indirect-y-mixin indirect-x-mixin) "(")
                   (t ""))
                 (typecase object
                   (accumulator-mixin "A")
                   (t (operand object)))
                 (typecase object
                   (indirect-x-mixin ", X)")
                   (indirect-y-mixin "),Y")
                   (t ""))))
        (t
         (format stream "#<~A~A>" (mnemonic object)
                 (if (or (typep object 'implied-mixin)
                         (typep object 'accumulator-mixin))
                     ""
                     (format nil " ~S" (operand object)))))))

(defclass complete-instruction-mixin ()
  ((%opcode :allocation :class :reader opcode :initarg :opcode)))

(defmethod bytesquash ((object complete-instruction-mixin))
  (append (list (opcode object))
          (when (> (instruction-length object) 1)
            (bytesquash (operand object)))))

(defclass immediate-mixin () ())
(defclass implied-mixin () ())
(defclass accumulator-mixin () ())
(defclass zero-page-mixin () ())

(defmethod shared-initialize :after ((instance zero-page-mixin) slot-names &rest initargs &key &allow-other-keys)
  (declare (ignore slot-names initargs))
  (when (numberp (operand instance))
    (assert (< (operand instance) #x100))))

(defclass zero-page-x-mixin (zero-page-mixin) ())
(defclass absolute-mixin () ())
(defclass absolute-x-mixin (absolute-mixin) ())
(defclass absolute-y-mixin (absolute-mixin) ())
(defclass indirect-x-mixin (zero-page-mixin) ())
(defclass indirect-y-mixin (zero-page-mixin) ())

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun addressing-mode-to-class-name (mode-keyword)
    (cadr (assoc mode-keyword
                 '((:implied implied-mixin)
                   (:immediate immediate-mixin)
                   (:accumulator accumulator-mixin)
                   (:zero-page zero-page-mixin)
                   (:zero-page-x zero-page-x-mixin)
                   (:zero-page-y zero-page-y-mixin)
                   (:relative relative-mixin)
                   (:absolute absolute-mixin)
                   (:absolute-x absolute-x-mixin)
                   (:absolute-y absolute-y-mixin)
                   (:indirect-x indirect-x-mixin)
                   (:indirect-y indirect-y-mixin))))))

(defgeneric instruction-length (object)
  (:method ((obj immediate-mixin)) 2)
  (:method ((obj implied-mixin)) 1)
  (:method ((obj accumulator-mixin)) 1)
  (:method ((obj zero-page-mixin)) 2)
  (:method ((obj relative-mixin)) 2)
  (:method ((obj absolute-mixin)) 3))

(defclass branching-mixin ()
  ((%branch-next :accessor branch-next :initarg :branch-next)))

(defmacro define-instruction (mnemonic branching-p &rest modes-and-codes)
  (let* ((name (string-upcase mnemonic))
         (base-name (intern (format nil "INST-~A" name))))
    `(progn
       (defclass ,base-name (instruction)
         ((%mnemonic :allocation :class :initform ',mnemonic)))
       (setf (slot-value (make-instance ',base-name) '%mnemonic) ',mnemonic)
       ,@(loop :for (mode code) :in modes-and-codes
               :for class-name := (intern (format nil "INST-~A-~A" name mode))
               :collect `(progn
                           (defclass ,class-name
                               ,(append
                                 `(,base-name
                                   ,(addressing-mode-to-class-name mode)
                                   complete-instruction-mixin)
                                 (when branching-p
                                   '(branching-mixin)))
                             ((%opcode :allocation :class :initform ,code)))
                           (setf (slot-value (allocate-instance (find-class ',class-name)) '%opcode) ,code))))))

(defun fix-label-addresses-in-instruction-list (instruction-list origin)
  (loop :with address := origin
        :with cell := instruction-list
        :for obj :in instruction-list
        :if (typep obj 'label)
          :do (setf (address obj) address)
        :else
          :do (when (typep obj 'instruction)
                (incf address (instruction-length obj)))
        :unless (null (rest cell))
          :do (setf cell (rest cell))
        :finally (setf (cdr cell)
                       (list (make-label :name "PROGRAM_END" :address address)))))

(defun bytesquash-instruction-list (instruction-list origin)
  (let* ((end-label (find "PROGRAM_END" (remove-if-not #'labelp instruction-list)
                          :key #'name :test #'equalp))
         (byte-vector (make-array (- (address end-label) origin)
                                  :element-type '(unsigned-byte 8)
                                  :fill-pointer 0)))
    (loop :for thing :in instruction-list
          :when (typep thing 'instruction)
            :do (dolist (byte (bytesquash thing))
                  (vector-push byte byte-vector)))
    byte-vector))

;;; Testing

(define-instruction "TXA" nil (:implied #x8a))
(define-instruction "PHA" nil (:implied #x48))
(define-instruction "PLA" nil (:implied #x68))
(define-instruction "TAX" nil (:implied #xaa))
(define-instruction "DEX" nil (:implied #xca))
(define-instruction "BNE" t (:relative #xd0))
(define-instruction "LDA" nil
  (:immediate #xa9)
  (:zero-page #xa5)
  (:absolute #xad)
  (:absolute-y #xb9))
(define-instruction "LDY" nil
  (:immediate #xa0)
  (:absolute #xac))
(define-instruction "STA" nil
  (:absolute #x8d)
  (:absolute-y #x99))
(define-instruction "JSR" nil
  (:absolute #x20))