ＳＩＣＰ読んだばかりですバージョン
1 #! /usr/local/bin/gosh
2 ; $Id$
3 ; cut-sea.
4
5 ;; 範囲制御付きポインタ
6 (define (make-pointer min max)
7 (let ((reg min))
8 (define (set v)
9 (if (and (>= v min) (< v max))
10 (set! reg v)
11 (else (error "ERROR: pointer position out of area." v))))
12 (define (get)
13 reg)
14 (define (init)
15 (set! reg min))
16 (define (dispatch m)
17 (cond ((eq? m 'set) set)
18 ((eq? m 'get) (get))
19 ((eq? m 'init) (init))
20 (else (error "ERROR: No such operation for pointer." m))))
21 dispatch))
22
23 (define (set-pointer p v) ((p 'set) v))
24 (define (get-pointer p) (p 'get))
25 (define (init-pointer p) (p 'init))
26
27 ;; スタック
28 (define (make-stack)
29 (let ((stack '()))
30 (define (push v)
31 (set! stack (cons v stack)))
32 (define (pop)
33 (if (not (null? stack))
34 (let ((v (car stack)))
35 (set! stack (cdr stack))
36 v)
37 (error "ERROR: stack has no value.")))
38 (define (peek)
39 (if (not (null? stack))
40 (car stack)
41 (error "ERROR: stack has no value.")))
42 (define (check)
43 stack)
44 (define (init)
45 (set! stack '()))
46 (define (dispatch m)
47 (cond ((eq? m 'push) push)
48 ((eq? m 'pop) (pop))
49 ((eq? m 'peek) (peek))
50 ((eq? m 'check) (check))
51 ((eq? m 'init) (init))
52 (else (error "ERROR: No such operation for stack." m))))
53 dispatch))
54
55 (define (push s v) ((s 'push) v))
56 (define (pop s) (s 'pop))
57 (define (peek s) (s 'peek))
58 (define (check-stack s) (s 'check)) ;for debug
59 (define (init-stack s) (s 'init))
60
61 ;; テープメモリ
62 (define (make-tape size)
63 (letrec ((min 0)
64 (max size)
65 (tape (make-vector max 0)))
66 (define (set p v)
67 (if (and (>= p min) (< p max))
68 (begin
69 (vector-set! tape p v)
70 v)
71 (error "ERROR: tape area overflow." p)))
72 (define (get p)
73 (if (and (>= p min) (< p max))
74 (vector-ref tape p)
75 (else "ERROR: tape area overflow." p)))
76 (define (check)
77 tape)
78 (define (init)
79 (set! tape (make-vector max 0)))
80 (define (dispatch m)
81 (cond ((eq? m 'set) set)
82 ((eq? m 'get) get)
83 ((eq? m 'check) (check))
84 ((eq? m 'init) (init))
85 (else (error "ERROR: No such operation for stack." m))))
86 dispatch))
87
88 (define (store-value t p v) ((t 'set) p v))
89 (define (load-value t p) ((t 'get) p))
90 (define (check-value t) (t 'check))
91 (define (init-tape t) (t 'init))
92
93 ;; まず単純にコードを読み込み逆順リストにする
94 ;; +-><[]., => (#\, #\. #\] #\[ #\< #\> #\- #\+)
95 ;;
96 (define (read-text source-text)
97 (let ((code '())
98 (text source-text)) ;; source-text はソースコードのポート
99
100 (let loop ((c (read-char text)))
101 (if (eof-object? c)
102 code
103 (case c
104 ((#\+ #\- #\< #\> #\. #\, #\[ #\] #\?)
105 (begin
106 (set! code (cons c code))
107 (loop (read-char text))))
108 (else (loop (read-char text))))))))
109
110 ;; read-text の返り値の逆順リストを reverse しつつ
111 ;; #\[ #\] を読み込んだときに対応を取り込んでおく
112 ;; その情報を組み込んだ内部命令コードリストを返す
113 ;; 要は #\[ でポインタ下のテープのデータが 0 の時の
114 ;; ジャンプ先をとらえておくもの
115 ;;
116 (define (reverse-text code-list)
117 (let ((insts (list 'done))
118 (stack (make-stack)))
119
120 (let loop ((code code-list))
121 (if (null? code)
122 insts
123 (let ((c (car code)))
124 (begin
125 (case c
126 ((#\+) (set! insts
127 (cons 'incre insts)))
128 ((#\-) (set! insts
129 (cons 'decre insts)))
130 ((#\<) (set! insts
131 (cons 'lshif insts)))
132 ((#\>) (set! insts
133 (cons 'rshif insts)))
134 ((#\.) (set! insts
135 (cons 'prout insts)))
136 ((#\,) (set! insts
137 (cons 'getch insts)))
138 ((#\[) (set! insts
139 (cons (cons 'branch (pop stack)) insts)))
140 ((#\]) (begin
141 (push stack insts)
142 (set! insts (cons 'windbk insts))))
143 ((#\?) (set! insts
144 (cons 'infom insts))))
145 (loop (cdr code))))))))
146
147
148 ;;
149 (define (make-vm inport outport tape-size)
150 (let ((pc '())
151 (insts '())
152 (sp (make-stack))
153 (pointer (make-pointer 0 tape-size))
154 (tape (make-tape tape-size)))
155
156
157 ;; 内部命令セット
158 (define (incre)
159 (letrec ((p (get-pointer pointer))
160 (v (load-value tape p)))
161 (store-value tape p (inc! v))))
162
163 (define (decre)
164 (letrec ((p (get-pointer pointer))
165 (v (load-value tape p)))
166 (store-value tape p (dec! v))))
167
168 (define (lshif)
169 (let ((p (get-pointer pointer)))
170 (set-pointer pointer (dec! p))))
171
172 (define (rshif)
173 (let ((p (get-pointer pointer)))
174 (set-pointer pointer (inc! p))))
175
176 (define (prout)
177 (letrec ((p (get-pointer pointer))
178 (v (load-value tape p)))
179 (write-byte v outport)
180 (flush)))
181
182 (define (getch)
183 (letrec ((p (get-pointer pointer))
184 (v #t))
185 (set! v (read-byte inport))
186 (store-value tape p v)))
187
188 (define (branch cont)
189 (letrec ((p (get-pointer pointer))
190 (v (load-value tape p)))
191 (if (eq? v 0)
192 (set! pc (cons 'nop cont))
193 (push sp pc))))
194
195 (define (windbk)
196 (set! pc (cons 'nop (pop sp))))
197
198 (define (nop)
199 (format #t "no operation."))
200
201 (define (done)
202 (format #t "Program reach end..."))
203
204 ;; 外部インターフェース用
205 (define (load code)
206 (begin
207 (init-stack sp)
208 (init-pointer pointer)
209 (init-tape tape)
210 (set! pc code)
211 (set! insts code)
212 'ok))
213
214 (define (execute inst)
215 (if (pair? inst)
216 (if (eq? (car inst) 'branch)
217 (branch (cdr inst))
218 (error "ERROR: Here is expected branch operation."))
219 (cond ((eq? inst 'incre) (incre))
220 ((eq? inst 'decre) (decre))
221 ((eq? inst 'lshif) (lshif))
222 ((eq? inst 'rshif) (rshif))
223 ((eq? inst 'prout) (prout))
224 ((eq? inst 'getch) (getch))
225 ((eq? inst 'windbk) (windbk))
226 ((eq? inst 'done) 'done) ; no message.
227 ((eq? inst 'nop) (nop))
228 ((eq? inst 'infom) (infom))
229 (else (error "ERROR: Invalid instruction code.")))))
230
231 (define (run)
232 (if (not (null? pc))
233 (begin
234 (execute (car pc))
235 (set! pc (cdr pc))
236 (run))
237 'done))
238
239 (define (infom)
240 (begin
241 (format #t "program counter : ~a~%" pc)
242 (format #t "stack pointer : ~a~%" (check-stack sp))
243 (format #t "the pointer : ~a~%" (get-pointer pointer))
244 (format #t "pointed value : ~a~%" (load-value tape (get-pointer pointer)))
245 (format #t "loading program : ~a~%" insts)
246 'ok))
247
248 (define (dispatch m)
249 (cond ((eq? m 'load) load)
250 ((eq? m 'run) (run))
251 ((eq? m 'infom) (infom))
252 (else (error "ERROR: It's invalid instruction for brainfuck virtual machine -- " m))))
253 dispatch))
254
255 (define (compile-load vm inport) ((vm 'load) (reverse-text (read-text inport))))
256 (define (loading vm code) ((vm 'load) code))
257 (define (run vm) (vm 'run))
258 (define (vminfo vm) (vm 'infom))
259
260 ;; メイン
261 (define (main args)
262 (with-error-handler
263 (lambda (err) (format (current-error-port) "ERROR: ~a~%" (slot-ref err 'message)))
264 (lambda ()
265 (if (not (null? (cdr args)))
266 (let ((in (current-input-port))
267 (out (current-output-port)))
268 (begin
269 (define bfm (make-vm in out 30000))
270 (define src (open-input-file (cadr args)))
271 (compile-load bfm src)
272 (run bfm)))
273 (begin
274 (format #t "usage: bf.scm filename~%")
275 (format #t " <filename> -- brainfuck source code~%"))))))
276
277
278 ;; お試しコード埋め込み
279
280 ;; Hello, World プログラム
281 ;(define str (open-input-string "
282 ;>+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]
283 ;<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++[
284 ;<++++>-]<+.[-]++++++++++.
285 ;"))
286 ;(define b (make-vm (current-input-port) (current-output-port) 30000))
287 ;(compile-load b str)
288 ;(run b)
289
290 ;; echo プログラム
291 ;(define str (open-input-string "
292 ;+[>,.<]
293 ;"))
294 ;(define b (make-vm (current-input-port) (current-output-port) 30000))
295 ;(compile-load b str)
296 ;(run b)