1 files changed, 73 insertions, 64 deletions
diff --git a/simulation.lisp b/simulation.lisp
index 2474de2..e10d721 100644
--- a/simulation.lisp
+++ b/simulation.lisp
@@ -1,72 +1,81 @@
 (in-package :cl-forth)
 
-(defvar *stack* ())
+(defvar *stack* nil)
 (defvar *bel* nil)
 
+(defmacro push* (item)
+  `(vector-push ,item *stack*))
+
+(defmacro pop* ()
+  `(the fixnum (vector-pop *stack*)))
+
 (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*))))))
+  (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)))