blob: e10d721c0b49dc2b6f63c80915982324efc6ca50 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
(in-package :cl-forth)
(defvar *stack* nil)
(defvar *bel* nil)
(defmacro push* (item)
`(vector-push ,item *stack*))
(defmacro pop* ()
`(the fixnum (vector-pop *stack*)))
(defun simulate-program (program)
(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)))
|
