(in-package :cl-forth)

(defparameter *operations* (make-hash-table))

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

(defun gen-code (op str)
  (let ((op-fn (gethash (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")))