From 9f9956e8893f16f4bc4b261597e03877830d1c6f Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Fri, 9 Aug 2024 15:01:12 +0300
Subject: added interpreter again

---
 cl-forth.asd    |  1 +
 main.lisp       |  4 ++--
 simulation.lisp | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 75 insertions(+), 2 deletions(-)
 create mode 100644 simulation.lisp

diff --git a/cl-forth.asd b/cl-forth.asd
index 455a735..f192b5e 100644
--- a/cl-forth.asd
+++ b/cl-forth.asd
@@ -9,6 +9,7 @@
                (:file "util")
                (:file "assembly")
                (:file "cl-forth")
+               (:file "simulation")
                (:file "main")
                (:file "test/tests"))
   :build-operation "program-op"
diff --git a/main.lisp b/main.lisp
index 182d748..a04fa05 100644
--- a/main.lisp
+++ b/main.lisp
@@ -13,12 +13,12 @@
              ;;     (format t "~s~%" program)
              ;;     (generate-program program :compile t)))
              (generate-program (make-program (second args)) :compile t))
-            ((string= flag "-i")
-             (interpret-program (make-program (second args))))
             ((string= flag "-p")
              (format t "~a" (make-program (second args))))
             ((string= flag "-t")
              (run-tests))
+            ((string= flag "-s")
+             (simulate-program (make-program (second args))))
             (t (format t "~a is not a valid flag~%" flag))))))
 
 ;; (defun make-exe ()
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)))
-- 
cgit v1.2.3