added interpreter again

1 files changed, 72 insertions, 0 deletions

diff --git a/simulation.lisp b/simulation.lisp
new file mode 100644
index 0000000..2474de2
--- /dev/null
+++ b/simulation.lisp
@@ -0,0 +1,72 @@
+(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)))