(in-package :cl-forth)

(defun assembly-undefined-ops ()
  (iter (for (k) in-hashtable *operations*)
        (collect k into defops)
        (finally (return (remove-if (lambda (sym) (search "SYSCALL" (string sym)))
                                    (set-difference *identifiers* defops
                                                    :test #'string=))))))

(defun make-token (sym? line col)
  (if (or (numberp sym?) (is-identifier 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))

;;; LEXER
(defun lex-line (line &optional (line-num 0))
  (iter (with line-stream = (make-string-input-stream line))
        (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= #\|  next-char)
             (read-char line-stream)
             (collect (make-token "|" line-num col) into tokens))
            ((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 :external-format :utf-8)
       (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 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 lex-string (string &optional report-errors)
  (let ((has-error nil))
    (values
     (let ((str (make-string-input-stream string)))
       (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 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)))

;;; PARSER
(defun parse-tokens (tokens)
  (iter (with ops = (make-array (length tokens) :fill-pointer 0
                                                :adjustable t))
        (with stack = ())
        (for i from 0)
        (for token in tokens)
        (let ((op (token-op token)))
          (cond ((numberp op)
                 (vector-push-extend `(push ,op) ops))
                ((string= 'ise op)
                 (push (list 'ise i) stack)
                 (vector-push-extend (list 'ise nil) ops))
                ((string= 'yoksa op)
                 (let ((top (pop stack)))
                   (assert (string= 'ise (car top)))
                   (setf (second (aref ops (cadr top))) i)
                   (push (list 'yoksa i) stack)
                   (vector-push-extend (list 'yoksa nil i) ops)))
                ((string= 'yap op)
                 (let ((top (pop stack)))
                   (cond ((find (car top) (list 'yoksa 'ise))
                          (setf (second (aref ops (cadr top))) i)
                          (vector-push-extend (list 'yap i) ops))
                         ((string= 'iken (car top))
                          (setf (second (aref ops (cadr top))) i)
                          (vector-push-extend (list 'yap i (third top)) ops))
                         (t (error "yap cannot reference: ~a" (car top))))))
                ((string= 'döngü op)
                 (push (list 'döngü i) stack)
                 (vector-push-extend (list 'döngü i) ops))
                ((string= 'iken op)
                 (let ((top (pop stack)))
                   (assert (string= 'döngü (car top)))
                   (push (list 'iken i (cadr top)) stack)
                   (vector-push-extend (list 'iken nil) ops)))
                ((search "syscall" (string-downcase (string op)))
                 (let ((syscall-num (parse-integer (subseq (string op) 8))))
                   (vector-push-extend (list 'syscall syscall-num) 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)))


;;; INTERPRETER
;; (eval-always
;;   (define-condition op-not-implemented (style-warning)
;;     ((undef-ops :initarg :ops :reader undef-ops))
;;     (:report (lambda (condition stream)
;;                (format stream "These ops are not defined in op-case: ~s"
;;                        (undef-ops condition)))))
  
;;   (defun identifier-coverage (defined-ops)
;;     (let ((undef-ops (set-difference *identifiers* defined-ops)))
;;       (unless (null undef-ops)
;;         (warn (make-condition 'op-not-implemented :ops undef-ops))))))

;; (defmacro op-case (case-form &body body)
;;   (iter (for (op-id) in body)
;;         (when (not (is-identifier op-id))
;;           (error "op-case: ~a is not an identifier" op-id))
;;         (collect op-id into defined-ops)
;;         (finally (identifier-coverage defined-ops)))
;;   (let ((case-sym (gensym)))
;;     `(let ((,case-sym ,case-form))
;;        (case ,case-sym
;;          ,@body
;;          (otherwise (if (is-identifier (first ,case-sym))
;;                         (error "op: ~a -- Not implemented yet"
;;                                (first ,case-sym))
;;                         (error "op: ~a -- Does not exist"
;;                                (first ,case-sym))))))))

;; (defun interpret-program (program)
;;   (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
;;         ;; (for op in-sequence program)
;;         (for i from 0 below (length program))
;;         (let ((op (aref program i)))
;;           (op-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))
;;             (dump (print (vector-pop stack)))
;;             (= (vector-push-extend (if (= (vector-pop stack)
;;                                           (vector-pop stack))
;;                                        1 0)
;;                                    stack))
;;             (yap (next-iteration))
;;             (yoksa (setf i (second op)))
;;             (ise (if (= (vector-pop stack) 1)
;;                      nil
;;                      (setf i (second op))))
;;             (eş (let ((top (vector-pop stack)))
;;                   (vector-push-extend top stack)
;;                   (vector-push-extend top stack)))
;;             (değiş (let* ((fst (vector-pop stack))
;;                           (snd (vector-pop stack)))
;;                      (vector-push-extend fst stack)
;;                      (vector-push-extend snd stack)))
;;             (düş (vector-pop stack))
;;             (üst (let* ((fst (vector-pop stack))
;;                         (snd (vector-pop stack)))
;;                    (vector-push-extend snd stack)
;;                    (vector-push-extend fst stack)
;;                    (vector-push-extend snd stack)))
;;             (rot (let* ((fst (vector-pop stack))
;;                         (snd (vector-pop stack))
;;                         (trd (vector-pop stack)))
;;                    (vector-push-extend snd stack)
;;                    (vector-push-extend fst stack)
;;                    (vector-push-extend trd stack)))))))

;;; COMPILER
(defun write-program (program out &key (mem-cap 640000))
  (format out "~a~%" "segment .text")
  (gen-dump out)
  (format out "~{~a~%~}" '("global _start"
                           "_start:"))
  (iter (for op in-sequence program)
        (gen-header op out)
        (gen-code op out))
  (gen-header '(exit 0) out)
  (gen-code '(exit 0) out)
  (format out "~a~%" "segment .bss")
  (format out "~a ~a~%" "bel: resb" mem-cap))

(defun generate-program (program &key (path "output.asm") (compile nil)
                                   (mem-cap 640000) (silence nil))
  (with-open-file (out path :direction :output
                            :if-exists :supersede)
    (write-program program out :mem-cap mem-cap))
  (when compile
    (run `("nasm" "-felf64" ,path) :output t :silence silence)
    (let ((name (first (uiop:split-string path :separator '(#\.)))))
      (run `("ld" "-o" ,name ,(concatenate 'string name ".o"))
           :output t :silence silence))))

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