73 lines
2.9 KiB
Common Lisp
73 lines
2.9 KiB
Common Lisp
(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)))
|