(in-package :cl-forth)

(defparameter *identifiers* '(+ - |.| =))

(defun is-identifier (sym)
  (find sym *identifiers*))

(defun make-token (sym? line col)
  (if (or (is-identifier sym?) (numberp sym?))
      (values (list sym? :line line :col col) nil)
      (values (list sym? :line line :col col :error t) t)))

(defun token-op (token)
  (car token))

(defun lex-line (line-stream line-num)
  (iter (with col = 0)
        (with has-err = nil)
        (for next-char = (peek-char nil line-stream nil nil))
        (until (null next-char))
        (let ((flag t))
          (cond ((char= #\. next-char)
                 (collect (make-token '|.| line-num col) into tokens)
                 (read-char line-stream))
                ((char= #\Space next-char) (read-char line-stream))
                ((char= #\; next-char) ;; and not in string
                 (finish))
                (t (setf flag nil)))
          (when flag
            (incf col)
            (next-iteration)))
        (for next-sym in-stream line-stream
             using #'read-preserving-whitespace)
        (multiple-value-bind (token err)
            (make-token next-sym line-num col)
          (collect token into tokens)
          (when err ;; skip line on error and continue lexing
            (setf has-err t)
            (finish))
          (incf col (length (princ-to-string next-sym))))
        (finally (return (values tokens has-err)))))

(defun lex-file (file-name &optional report-errors)
  (let ((has-error nil))
    (values
     (with-open-file (str file-name)
       (iter outer
             (for line = (read-line str nil nil))
             (until (null line))
             (for line-num from 1)
             (multiple-value-bind (tokens has-err)
                 (lex-line (make-string-input-stream line) line-num)
               (when has-err
                 (setf has-error t)
                 (when report-errors
                   (format t "~a~%" line)
                   (let ((err-token (find-if (lambda (tok) (find :error tok))
                                             tokens)))
                     (format t "~a^"
                             (make-string (getf (cdr err-token) :col)
                                          :initial-element #\Space)))))
               (appending tokens))))
     has-error)))

;; (defun prog-from-tokens (tokens)
;;   (iter (for token in tokens)
;;         (let ((op (token-op token)))
;;           (cond ((numberp op)
;;                  (collect `(push ,op) result-type 'vector))
;;                 (t (collect (list op) result-type 'vector))))))

(defun parse-tokens (tokens)
  (iter (with ops = (make-array (length tokens) :fill-pointer 0
                                                :adjustable t))
        (for i from 0)
        (for token in tokens)
        (let ((op (token-op token)))
          (cond ((numberp op)
                 (vector-push-extend `(push ,op) ops))
                (t (vector-push-extend (list op) ops))))
        (finally (return ops))))

(defun make-program (file-name)
  (multiple-value-bind (tokens has-error)
      (lex-file file-name t)
    (when has-error
      (error "Can't generate program due to error during lexing"))
    (parse-tokens tokens)))

;; (defun *ops* '(push pop minus dump))

(defun interpret-program (program)
  (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
        (for op in-sequence program)
        (case (first op)
          (push (vector-push-extend (second op) stack))
          (+ (vector-push-extend (+ (vector-pop stack)
                                    (vector-pop stack))
                                 stack))
          (- (vector-push-extend (let ((top (vector-pop stack)))
                     (- (vector-pop stack) top))
                   stack))
          (|.| (print (vector-pop stack)))
          (= (vector-push-extend (= (vector-pop stack)
                                    (vector-pop stack))
                                 stack))
          (otherwise (error "op: ~a -- Not implemented yet" (first op))))))

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

;; (defun not-implemented (str)
;;   (format str "    ;; -- TODO: not implemented --~%"))

(defun generate-program (program &key (path "output.asm") (compile nil))
  (with-open-file (out path :direction :output
                            :if-exists :supersede)
    (format out "~a~%" "segment .text")
    (gen-dump out)
    (format out "~{~a~%~}" '("global _start"
                             "_start:"))
    (iter (for op in-sequence program)
          (gen-header op out)
          (let ((op-fn (gethash (car op) *operations*)))
            (if (null op-fn)
                (format t "~s is not an op" (car op))
                (apply op-fn out (cdr op)))))
    (format out "~{~a~%~}" '("    mov rax, 60"
                             "    mov rdi, 0"
                             "    syscall")))
  (when compile
    (run `("nasm" "-felf64" ,path))
    (let ((name (first (uiop:split-string path :separator '(#\.)))))
      (run `("ld" "-o" ,name ,(concatenate 'string name ".o"))))))

(defun compile-program (path)
  (generate-program (make-program path) :compile t))