(in-package :cl-forth)

(defvar *stack* nil)
(defvar *bel* nil)

(defmacro push* (item)
  `(vector-push ,item *stack*))

(defmacro pop* ()
  `(the fixnum (vector-pop *stack*)))

(defun simulate-program (program)
  (declare (optimize (speed 3)) (vector program))
  (let ((*bel* (make-array 1000 :element-type '(unsigned-byte 8)))
        (*stack* (make-array 1000 :element-type 'fixnum :fill-pointer 0)))
    (iter (with op = nil)
          (for i below (the fixnum (length program)))
          (declare (fixnum i))
          (setf op (aref program i))
          ;; (print op)
          ;; (print *stack*)
          (case (car op)
            (:push-int (push* (cadr op)))
            (:+ (push* (+ (pop*) (pop*))))
            (:dump (format t "~a~%" (pop*)))
            (:= (push* (if (= (pop*) (pop*)) 1 0)))
            (:eş (let ((top (pop*)))
                   (push* top)
                   (push* top)))
            (:ise (when (= 0 (pop*))
                    (setf i (cadr op))))
            (:yoksa (setf i (cadr op)))
            (:yap (if (= 3 (length op))
                      (setf i (third op))))
            (:< (let ((top (pop*)))
                  (push* (if (< (pop*) top) 1 0))))
            (:iken (when (= 0 (pop*))
                     (setf i (cadr op))))
            (:bel (push* 0))
            (:oku (push* (aref *bel* (pop*))))
            (:yaz (let ((top (pop*)))
                    (setf (aref *bel* (pop*)) top)))
            (:syscall (let ((fn (pop*)))
                        (case fn
                          (1 (let* ((len (pop*))
                                    (start (pop*))
                                    (file-desc (pop*)))
                               (declare (ignore file-desc))
                               ;; (princ (map 'string #'code-char
                               ;;             (subseq *bel* start (+ len start))))
                               (loop for i from start below (+ len start)
                                     do (write-char (code-char (aref *bel* i))))
                               (fresh-line)))
                          (60 (return-from simulate-program)))))
            (:pipe (let ((top (pop*)))
                     (push* (logior (pop*) top))))
            (:<< (let ((top (pop*)))
                   (push* (ash (pop*) top))))
            (:>> (let ((top (pop*)))
                   (push* (ash (pop*) (- top)))))
            (:& (let ((top (pop*)))
                  (push* (logand (pop*) top))))
            (:düş (pop*))
            (:değiş (let* ((top1 (pop*))
                           (top2 (pop*)))
                      (push* top1)
                      (push* top2)))
            (:rot (let* ((top1 (pop*))
                         (top2 (pop*))
                         (top3 (pop*)))
                    (push* top2)
                    (push* top1)
                    (push* top3)))
            (:üst (let* ((top1 (pop*))
                         (top2 (pop*)))
                    (push* top2)
                    (push* top1)
                    (push* top2)))))))

(defun str->prog (str)
  (parse-tokens (lex-string str)))