(in-package :cl-forth)

(defparameter *operations* (make-hash-table :test 'equal))

(eval-always
  (defun normalize-op-list (asm-list)
    (cons 'list
          (mapcar (lambda (el) (cond ((stringp el) el)
                                ((listp el) `(format nil ,@el))))
                  asm-list)))

  (defun defop-format (str space-num asm-list)
    (format str
            (format nil "~~{~a~~a~~%~~}" 
                    (make-string space-num :initial-element #\Space))
            asm-list))

  (defun replace-write (out-stream indent forms)
    (if (consp forms)
        (if (eq :write (car forms))
            `(defop-format ,out-stream ,indent
               ,(normalize-op-list (cdr forms)))
            (cons (replace-write out-stream indent (car forms))
                  (replace-write out-stream indent (cdr forms))))
        forms)))

(defmacro defop (op-name+args (&key (indent 4)) &body body)
  (with-gensyms (out-stream)
    (destructuring-bind (op-name . args) (mklist op-name+args)
      `(setf (gethash ,(string op-name) *operations*)
             (lambda (,out-stream ,@args)
               ,(if (or (stringp (car body)) (stringp (caar body)))
                    `(defop-format ,out-stream ,indent
                              ,(normalize-op-list body))
                    (replace-write out-stream indent (car body))))))))

;;; TODO: Turn stack operation comments to DEFOP option,
;;;       which then can be used by the user as a documentation
;;; TODO: Better yet, generate the asm code directly from
;;;       the stack op documentation (this seems easily doable)

;; ( -- a)
(defop (push a) ()
  ("push ~d" a))

;; (rbx rax -- (rbx + rax))
(defop + ()
  "pop rax"
  "pop rbx"
  "add rax, rbx"
  "push rax")

;; (rbx rax -- (rbx - rax))
(defop - ()
  "pop rax"
  "pop rbx"
  "sub rbx, rax"
  "push rbx")

(defop dump ()
  "pop rdi"
  "call dump")

(defop = ()
  "mov rcx, 0"
  "mov rdx, 1"
  "pop rax"
  "pop rbx"
  "cmp rax, rbx"
  "cmove rcx, rdx"
  "push rcx")

(defop (exit code) ()
  "mov rax, 60"
  ("mov rdi, ~a" code)
  "syscall")

(defop (ise label-num) ()
  "pop rax"
  "test rax, rax"
  ("jz et_~a" label-num))

(defop (yoksa yap-num ise-num) (:indent 0)
  ("    jmp et_~a" yap-num)
  ("et_~a:" ise-num))

(defop (yap label-num &optional döngü-num) (:indent 0)
  (if (null döngü-num)
      (:write ("et_~a:" label-num))
      (:write ("    jmp et_~a" döngü-num)
              ("et_~a:" label-num))))

;; (rax -- rax rax)
(defop eş ()
  "pop rax"
  "push rax"
  "push rax")

;; (rax -- )
(defop düş ()
  "pop rax")

(defop (iken label-num) ()
  "pop rax"
  "test rax, rax"
  ("jz et_~a" label-num))

(defop (döngü label-num) (:indent 0)
  ("et_~a:" label-num))

(defop < ()
  "mov rcx, 0"
  "mov rdx, 1"
  "pop rbx"
  "pop rax"
  "cmp rax, rbx"
  "cmovl rcx, rdx"
  "push rcx")

(defop > ()
  "mov rcx, 0"
  "mov rdx, 1"
  "pop rbx"
  "pop rax"
  "cmp rax, rbx"
  "cmovg rcx, rdx"
  "push rcx")

(defop bel ()
  "push bel")

(defop oku ()
  "pop rax"
  "xor rbx, rbx"
  "mov bl, [rax]"
  "push rbx")

(defop yaz ()
  "pop rbx"
  "pop rax"
  "mov [rax], bl")

(defop (syscall num) ()
  (iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9"))
        (initially (:write "pop rax"))
        (for i from (- num 1) downto 0)
        (:write ("pop ~a" (aref call-regs i)))
        (finally (:write "syscall"))))

;;; (rbx rax -- rbx rax rbx)
(defop üst ()
  "pop rax"
  "pop rbx"
  "push rbx"
  "push rax"
  "push rbx")

;;; (rcx rbx rax -- rbx rax rcx)
(defop rot ()
  "pop rax"
  "pop rbx"
  "pop rcx"
  "push rbx"
  "push rax"
  "push rcx")

;;; (rbx rax -- rax rbx)
(defop değiş ()
  "pop rax"
  "pop rbx"
  "push rax"
  "push rbx")

;;; (rbx rcx -- (:shl rbx cl))
(defop << ()
  "pop rcx"
  "pop rbx"
  "shl rbx, cl"
  "push rbx")

;;; (rbx rcx -- (:shr rbx cl))
(defop >> ()
  "pop rcx"
  "pop rbx"
  "shr rbx, cl"
  "push rbx")

;;; (rbx rcx -- (:or rbx cl))
(defop "|" ()
  "pop rax"
  "pop rbx"
  "or rbx, rax"
  "push rbx")

;;; (rbx rcx -- (:and rbx cl))
(defop & ()
  "pop rax"
  "pop rbx"
  "and rbx, rax"
  "push rbx")

(defun gen-header (op str)
  (format str "    ;; -- ~s --~%" op))

(defun gen-code (op str)
  (let ((op-fn (gethash (string (car op)) *operations*)))
    (if (null op-fn)
        (error "~s is not a valid op" op)
        (apply op-fn str (cdr op)))))

(defun gen-dump (str)
  (format str "~{~a~%~}"
          '("dump:"
            "    mov     r9, -3689348814741910323"
            "    sub     rsp, 40"
            "    mov     BYTE [rsp+31], 10"
            "    lea     rcx, [rsp+30]"
            ".L2:"
            "    mov     rax, rdi"
            "    lea     r8, [rsp+32]"
            "    mul     r9"
            "    mov     rax, rdi"
            "    sub     r8, rcx"
            "    shr     rdx, 3"
            "    lea     rsi, [rdx+rdx*4]"
            "    add     rsi, rsi"
            "    sub     rax, rsi"
            "    add     eax, 48"
            "    mov     BYTE [rcx], al"
            "    mov     rax, rdi"
            "    mov     rdi, rdx"
            "    mov     rdx, rcx"
            "    sub     rcx, 1"
            "    cmp     rax, 9"
            "    ja      .L2"
            "    lea     rax, [rsp+32]"
            "    mov     edi, 1"
            "    sub     rdx, rax"
            "    xor     eax, eax"
            "    lea     rsi, [rsp+32+rdx]"
            "    mov     rdx, r8"
            "    mov     rax, 1"
            "    syscall"
            "    add     rsp, 40"
            "    ret")))