(in-package :cl-forth)

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

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

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