1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
2 +++ b/toyscheme/toyscheme.scm Thu Jul 17 14:48:33 2008 +0800
3 @@ -0,0 +1,345 @@
4 +;; toyscheme.scm
5 +;;
6 +;; The scheme interpreter implemented in SICP, chapter 4, with
7 +;; slightly modifications.
8 +;;
9 +;; Li Qun <liqun82@users.sf.net>
10 +;; Wednesday, 16 Jul 2008, 04:57pm
11 +;;
12 +;; Run this script with:
13 +;; guile -e main toyscheme.scm
14 +
15 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16 +;; Built-in special forms:
17 +;; lambda, define, if, cond, begin, set!, let, quote
18 +;;
19 +;; Primitive procedures loaded on startup:
20 +;; +, -, *, /
21 +;; car, cdr, cons
22 +;; not, null?, >, <, =
23 +;;
24 +;; Supported types:
25 +;; number, string, symbol
26 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 +
28 +(define (self-evaluating? exp)
29 + (cond ((number? exp) #t)
30 + ((string? exp) #t)
31 + (else #f)))
32 +
33 +(define (variable? exp) (symbol? exp))
34 +
35 +(define (quoted? exp)
36 + (taggled-list? exp 'quote))
37 +
38 +(define (text-of-quotation exp) (cadr exp))
39 +
40 +(define (taggled-list? exp tag)
41 + (if (pair? exp)
42 + (eq? (car exp) tag)
43 + #f))
44 +
45 +(define (assignment? exp)
46 + (taggled-list? exp 'set!))
47 +
48 +(define (assignment-variable exp) (cadr exp))
49 +(define (assignment-value exp) (caddr exp))
50 +
51 +(define (definition? exp)
52 + (taggled-list? exp 'define))
53 +
54 +(define (definition-variable exp)
55 + (if (symbol? (cadr exp)) ;; (define foo ...)
56 + (cadr exp)
57 + (caadr exp))) ;; (define (foo x) (...))
58 +
59 +(define (definition-value exp)
60 + (if (symbol? (cadr exp))
61 + (caddr exp)
62 + (make-lambda (cdadr exp) ;; formal parameters
63 + (cddr exp)))) ;; body
64 +
65 +(define (lambda? exp) (taggled-list? exp 'lambda))
66 +(define (lambda-parameters exp) (cadr exp))
67 +(define (lambda-body exp) (cddr exp))
68 +
69 +(define (make-lambda parameters body)
70 + (cons 'lambda (cons parameters body)))
71 +
72 +(define (let? exp) (taggled-list? exp 'let))
73 +(define (let->lambda exp)
74 + (let ((vars (map car (cadr exp)))
75 + (vals (map cadr (cadr exp)))
76 + (body (caddr exp)))
77 + (cons (list 'lambda vars body) vals)))
78 +
79 +(define (if? exp) (taggled-list? exp 'if))
80 +(define (if-predicate exp) (cadr exp))
81 +(define (if-consequent exp) (caddr exp))
82 +
83 +(define (if-alternative exp)
84 + (if (not (null? (cdddr exp)))
85 + (cadddr exp)
86 + #f))
87 +
88 +(define (make-if predicate consequent alternative)
89 + (list 'if predicate consequent alternative))
90 +
91 +(define (begin? exp) (taggled-list? exp 'begin))
92 +(define (begin-actions exp) (cdr exp))
93 +(define (last-exp? seq) (null? (cdr seq)))
94 +(define (first-exp seq) (car seq))
95 +(define (rest-exps seq) (cdr seq))
96 +
97 +(define (sequence->exp seq)
98 + (cond ((null? seq) seq)
99 + ((last-exp? seq) (first-exp seq))
100 + (else (make-begin seq))))
101 +
102 +(define (make-begin seq)
103 + (cons 'begin seq))
104 +
105 +(define (appliation? exp) (pair? exp))
106 +(define (operator exp) (car exp))
107 +(define (operands exp) (cdr exp))
108 +(define (no-operands? ops) (null? ops))
109 +(define (first-operand ops) (car ops))
110 +(define (rest-operands ops) (cdr ops))
111 +
112 +(define (cond? exp) (taggled-list? exp 'cond))
113 +(define (cond-clauses exp) (cdr exp))
114 +
115 +(define (cond-else-clause? clause)
116 + (eq? (cond-predicate clause) 'else))
117 +
118 +(define (cond-predicate clause) (car clause))
119 +(define (cond-actions clause) (cdr clause))
120 +
121 +(define (cond->if exp)
122 + (expand-clauses (cond-clauses exp)))
123 +
124 +(define (expand-clauses clauses)
125 + (if (null? clauses)
126 + #f
127 + (let ((first (car clauses))
128 + (rest (cdr clauses)))
129 + (if (cond-else-clause? first)
130 + (if (null? rest)
131 + (sequence->exp (cond-actions first))
132 + (error "ELSE clause isn't last -- COND->IF"
133 + clauses))
134 + (make-if (cond-predicate first)
135 + (sequence->exp (cond-actions first))
136 + (expand-clauses rest))))))
137 +
138 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139 +
140 +(define (make-procedure parameters body env)
141 + (list 'procedure parameters body env))
142 +
143 +(define (compound-procedure? p)
144 + (taggled-list? p 'procedure))
145 +
146 +(define (procedure-parameters p) (cadr p))
147 +(define (procedure-body p) (caddr p))
148 +(define (procedure-environment p) (cadddr p))
149 +
150 +;; `env' is a list of frames
151 +(define (enclosing-environment env) (cdr env))
152 +(define (first-frame env) (car env))
153 +(define the-empty-environment '())
154 +
155 +(define (make-frame variables values)
156 + (cons variables values))
157 +
158 +(define (frame-variables frame) (car frame))
159 +(define (frame-values frame) (cdr frame))
160 +
161 +(define (add-binding-to-frame! var val frame)
162 + (set-car! frame (cons var (car frame)))
163 + (set-cdr! frame (cons val (cdr frame))))
164 +
165 +(define (extend-environment vars vals base-env)
166 + (if (= (length vars) (length vals))
167 + (cons (make-frame vars vals) base-env)
168 + (if (< (length vars) (length vals))
169 + (error "Too many arguments supplied" vars vals)
170 + (error "Too few arguments supplied" vals vals))))
171 +
172 +(define (lookup-variable-value var env)
173 + (define (env-loop env)
174 + (define (scan vars vals)
175 + (cond ((null? vars)
176 + (env-loop (enclosing-environment env)))
177 + ((eq? var (car vars))
178 + (car vals))
179 + (else (scan (cdr vars) (cdr vals)))))
180 + (if (eq? env the-empty-environment)
181 + (error "Unbound variable" var)
182 + (let ((frame (first-frame env)))
183 + (scan (frame-variables frame)
184 + (frame-values frame)))))
185 + (env-loop env))
186 +
187 +(define (set-variable-value! var val env)
188 + (define (env-loop env)
189 + (define (scan vars vals)
190 + (cond ((null? vars)
191 + (env-loop (enclosing-environment env)))
192 + ((eq? var (car vars))
193 + (set-car! vals val))
194 + (else (scan (cdr vars) (cdr vals)))))
195 + (if (eq? env the-empty-environment)
196 + (error "Unbound variable -- SET!" var)
197 + (let ((frame (first-frame env)))
198 + (scan (frame-variables frame)
199 + (frame-values frame)))))
200 + (env-loop env))
201 +
202 +(define (define-variable! var val env)
203 + (let ((frame (first-frame env)))
204 + (define (scan vars vals)
205 + (cond ((null? vars)
206 + (add-binding-to-frame! var val frame))
207 + ((eq? var (car vars))
208 + (set-car! vals val))
209 + (else (scan (cdr vars) (cdr vals)))))
210 + (scan (frame-variables frame)
211 + (frame-values frame))))
212 +
213 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
214 +(define (primitive-procedure? proc)
215 + (taggled-list? proc 'primitive))
216 +
217 +(define (primitive-implementation proc)
218 + (cadr proc))
219 +
220 +(define primitive-procedures
221 + (list (list 'car car) ; list operations
222 + (list 'cdr cdr)
223 + (list 'cons cons)
224 + (list 'null? null?) ; prediction
225 + (list '> >)
226 + (list '< <)
227 + (list '= =)
228 + (list 'not not)
229 + (list '+ +) ; basic arithmetics
230 + (list '- -)
231 + (list '* *)
232 + (list '/ /)
233 + ))
234 +
235 +(define (primitive-procedure-names)
236 + (map car primitive-procedures))
237 +
238 +(define (primitive-procedure-objects)
239 + (map (lambda (proc) (list 'primitive (cadr proc)))
240 + primitive-procedures))
241 +
242 +(define (apply-primitive-procedure proc args)
243 + (apply (primitive-implementation proc) args))
244 +
245 +(define (setup-environment)
246 + (let ((initial-env
247 + (extend-environment (primitive-procedure-names)
248 + (primitive-procedure-objects)
249 + the-empty-environment)))
250 + initial-env))
251 +
252 +(define the-global-environment (setup-environment))
253 +
254 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 +
256 +(define (list-of-values exps env)
257 + (if (no-operands? exps)
258 + '()
259 + (cons (toyscheme-eval (first-operand exps) env)
260 + (list-of-values (rest-operands exps) env))))
261 +
262 +(define (eval-if exp env)
263 + (if (toyscheme-eval (if-predicate exp) env)
264 + (toyscheme-eval (if-consequent exp) env)
265 + (toyscheme-eval (if-alternative exp) env)))
266 +
267 +(define (eval-sequence exps env)
268 + (cond ((last-exp? exps) (toyscheme-eval (first-exp exps) env))
269 + (else (toyscheme-eval (first-exp exps) env)
270 + (eval-sequence (rest-exps exps) env))))
271 +
272 +(define (eval-assignment exp env)
273 + (set-variable-value! (assignment-variable exp)
274 + (toyscheme-eval (assignment-value exp) env)
275 + env)
276 + 'ok)
277 +
278 +(define (eval-definition exp env)
279 + (define-variable! (definition-variable exp)
280 + (toyscheme-eval (definition-value exp) env)
281 + env)
282 + 'ok)
283 +
284 +(define (toyscheme-eval exp env)
285 + (cond ((self-evaluating? exp) exp)
286 + ((variable? exp) (lookup-variable-value exp env))
287 + ((quoted? exp) (text-of-quotation exp))
288 + ((assignment? exp) (eval-assignment exp env))
289 + ((definition? exp) (eval-definition exp env))
290 + ((if? exp) (eval-if exp env))
291 + ((lambda? exp)
292 + (make-procedure (lambda-parameters exp)
293 + (lambda-body exp)
294 + env))
295 + ((let? exp) (toyscheme-eval (let->lambda exp) env))
296 + ((begin? exp)
297 + (eval-sequence (begin-actions exp) env))
298 + ((cond? exp) (toyscheme-eval (cond->if exp) env))
299 + ((appliation? exp)
300 + (toyscheme-apply (toyscheme-eval (operator exp) env)
301 + (list-of-values (operands exp) env)))
302 + (else
303 + (error "unknown expression type -- TOYSCHEME-EVAL" exp))))
304 +
305 +(define (toyscheme-apply procedure arguments)
306 + (cond ((primitive-procedure? procedure)
307 + (apply-primitive-procedure procedure arguments))
308 + ((compound-procedure? procedure)
309 + (eval-sequence
310 + (procedure-body procedure)
311 + (extend-environment
312 + (procedure-parameters procedure)
313 + arguments
314 + (procedure-environment procedure))))
315 + (else
316 + (error "unknown procedure type -- TOYSCHEME-APPLY" procedure))))
317 +
318 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319 +
320 +(define input-prompt "Scheme> ")
321 +(define output-prompt "Answer: ")
322 +
323 +(define (prompt-for-input string)
324 + (newline) (newline) (display string))
325 +
326 +(define (announce-output string)
327 + (newline) (display string))
328 +
329 +(define (user-print object)
330 + (if (compound-procedure? object)
331 + (display (list 'compound-procedure
332 + (procedure-parameters object)
333 + (procedure-body object)
334 + '<procedure-env>))
335 + (display object)))
336 +
337 +(define (driver-loop)
338 + (prompt-for-input input-prompt)
339 + (let ((input (read)))
340 + (if (eof-object? input)
341 + (begin (newline) (exit 0))
342 + (let ((output (toyscheme-eval input the-global-environment)))
343 + (announce-output output-prompt)
344 + (user-print output))))
345 + (driver-loop))
346 +
347 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
348 +(define (main args) (driver-loop))