(in-package :cl-forth)

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

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

(defmacro defop (op-name (&key (indent 4) args) &body asm-strings)
  `(setf (gethash ',op-name *operations*)
         (lambda (out-stream ,@args)
           (format out-stream
                   ,(format nil "~~{~a~~a~~%~~}" 
                            (make-string indent :initial-element
                                         #\Space))
                   ,(normalize-op-list asm-strings)))))


(defop push (:args (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 |.| ()
  "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 (:args (exit-code))
  "mov rax, 60"
  ("mov rdi, ~a" exit-code)
  "syscall")

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

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

(defop yap (:args (label-num) :indent 0)
  ("et_~a:" label-num))

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