simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some type declarations for sim (performance didn't change much)

Browse Source
This commit is contained in:
mRnea
2024-08-11 22:17:57 +03:00
parent 9f9956e889
commit e75dd92a1f
1 changed files with 73 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

111
simulation.lisp
View File

@@ -1,72 +1,81 @@
(in-package :cl-forth) (in-package :cl-forth)
(defvar *stack* ()) (defvar *stack* nil)
(defvar *bel* nil) (defvar *bel* nil)
(defmacro push* (item)
`(vector-push ,item *stack*))
(defmacro pop* ()
`(the fixnum (vector-pop *stack*)))
(defun simulate-program (program) (defun simulate-program (program)
(setf *stack* ()) (declare (optimize (speed 3)) (vector program))
(setf *bel* (make-array 1000 :element-type '(unsigned-byte 8))) (let ((*bel* (make-array 1000 :element-type '(unsigned-byte 8)))
(*stack* (make-array 1000 :element-type 'fixnum :fill-pointer 0)))
(iter (with op = nil) (iter (with op = nil)
(for i below (length program)) (for i below (the fixnum (length program)))
(declare (fixnum i))
(setf op (aref program i)) (setf op (aref program i))
;; (print op) ;; (print op)
;; (print *stack*) ;; (print *stack*)
(case (car op) (case (car op)
(:push-int (push (cadr op) *stack*)) (:push-int (push* (cadr op)))
(:+ (push (+ (pop *stack*) (pop *stack*)) *stack*)) (:+ (push* (+ (pop*) (pop*))))
(:dump (format t "~a~%" (pop *stack*))) (:dump (format t "~a~%" (pop*)))
(:= (push (if (= (pop *stack*) (pop *stack*)) 1 0) (:= (push* (if (= (pop*) (pop*)) 1 0)))
*stack*)) (:eş (let ((top (pop*)))
(:eş (let ((top (pop *stack*))) (push* top)
(push top *stack*) (push* top)))
(push top *stack*))) (:ise (when (= 0 (pop*))
(:ise (when (= 0 (pop *stack*))
(setf i (cadr op)))) (setf i (cadr op))))
(:yoksa (setf i (cadr op))) (:yoksa (setf i (cadr op)))
(:yap (if (= 3 (length op)) (:yap (if (= 3 (length op))
(setf i (third op)))) (setf i (third op))))
(:< (let ((top (pop *stack*))) (:< (let ((top (pop*)))
(push (if (< (pop *stack*) top) 1 0) (push* (if (< (pop*) top) 1 0))))
*stack*))) (:iken (when (= 0 (pop*))
(:iken (when (= 0 (pop *stack*))
(setf i (cadr op)))) (setf i (cadr op))))
(:bel (push 0 *stack*)) (:bel (push* 0))
(:oku (push (aref *bel* (pop *stack*)) *stack*)) (:oku (push* (aref *bel* (pop*))))
(:yaz (let ((top (pop *stack*))) (:yaz (let ((top (pop*)))
(setf (aref *bel* (pop *stack*)) top))) (setf (aref *bel* (pop*)) top)))
(:syscall (let ((fn (pop *stack*))) (:syscall (let ((fn (pop*)))
(case fn (case fn
(1 (let* ((len (pop *stack*)) (1 (let* ((len (pop*))
(start (pop *stack*)) (start (pop*))
(file-desc (pop *stack*))) (file-desc (pop*)))
(declare (ignore file-desc)) (declare (ignore file-desc))
(princ (map 'string #'code-char ;; (princ (map 'string #'code-char
(subseq *bel* start (+ len start)))))) ;; (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))))) (60 (return-from simulate-program)))))
(:pipe (let ((top (pop *stack*))) (:pipe (let ((top (pop*)))
(push (logior (pop *stack*) top) *stack*))) (push* (logior (pop*) top))))
(:<< (let ((top (pop *stack*))) (:<< (let ((top (pop*)))
(push (ash (pop *stack*) top) *stack*))) (push* (ash (pop*) top))))
(:>> (let ((top (pop *stack*))) (:>> (let ((top (pop*)))
(push (ash (pop *stack*) (- top)) *stack*))) (push* (ash (pop*) (- top)))))
(:& (let ((top (pop *stack*))) (:& (let ((top (pop*)))
(push (logand (pop *stack*) top) *stack*)) ) (push* (logand (pop*) top))))
(:düş (pop *stack*)) (:düş (pop*))
(:değiş (let* ((top1 (pop *stack*)) (:değiş (let* ((top1 (pop*))
(top2 (pop *stack*))) (top2 (pop*)))
(push top1 *stack*) (push* top1)
(push top2 *stack*))) (push* top2)))
(:rot (let* ((top1 (pop *stack*)) (:rot (let* ((top1 (pop*))
(top2 (pop *stack*)) (top2 (pop*))
(top3 (pop *stack*))) (top3 (pop*)))
(push top2 *stack*) (push* top2)
(push top1 *stack*) (push* top1)
(push top3 *stack*))) (push* top3)))
(:üst (let* ((top1 (pop *stack*)) (:üst (let* ((top1 (pop*))
(top2 (pop *stack*))) (top2 (pop*)))
(push top2 *stack*) (push* top2)
(push top1 *stack*) (push* top1)
(push top2 *stack*)))))) (push* top2)))))))
(defun str->prog (str) (defun str->prog (str)
(parse-tokens (lex-string str))) (parse-tokens (lex-string str)))