(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))))))))

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

(defop + ()
  "pop rax"
  "pop rbx"
  "add rax, rbx"
  "push 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))))

(defop eş ()
  "pop rax"
  "push rax"
  "push 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"))))

(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")))