1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Mandatory SICP Metacircular Evaluator ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 ;; To use, simply (load "metacirc.scm") and run the (driver-loop) command.
7 (define apply-in-underlying-scheme apply)
11 ;; Verbatim code from SICP
13 (define (eval exp env)
14 (cond ((self-evaluating? exp)
17 (lookup-variable-value exp env))
19 (text-of-quotation exp))
21 (eval-assignment exp env))
23 (eval-definition exp env))
28 (lambda-parameters exp)
36 (eval (cond->if exp) env))
38 (apply (eval (operator exp) env)
43 (error "Unknown expression type: EVAL" exp))))
45 (define (apply procedure arguments)
46 (cond ((primitive-procedure? procedure)
47 (apply-primitive-procedure
50 ((compound-procedure? procedure)
52 (procedure-body procedure)
57 (procedure-environment
60 (error "Unknown procedure type: APPLY"
63 (define (list-of-values exps env)
64 (if (no-operands? exps)
66 (cons (eval (first-operand exps) env)
71 (define (eval-if exp env)
72 (if (true? (eval (if-predicate exp) env))
73 (eval (if-consequent exp) env)
74 (eval (if-alternative exp) env)))
76 (define (eval-sequence exps env)
77 (cond ((last-exp? exps)
78 (eval (first-exp exps) env))
80 (eval (first-exp exps) env)
81 (eval-sequence (rest-exps exps)
84 (define (eval-assignment exp env)
86 (assignment-variable exp)
87 (eval (assignment-value exp) env)
91 (define (eval-definition exp env)
93 (definition-variable exp)
94 (eval (definition-value exp) env)
98 (define (self-evaluating? exp)
99 (cond ((number? exp) true)
103 (define (variable? exp) (symbol? exp))
105 (define (quoted? exp)
106 (tagged-list? exp 'quote))
108 (define (text-of-quotation exp)
111 (define (tagged-list? exp tag)
116 (define (assignment? exp)
117 (tagged-list? exp 'set!))
119 (define (assignment-variable exp)
122 (define (assignment-value exp) (caddr exp))
124 (define (definition? exp)
125 (tagged-list? exp 'define))
127 (define (definition-variable exp)
128 (if (symbol? (cadr exp))
132 (define (definition-value exp)
133 (if (symbol? (cadr exp))
136 (cdadr exp) ; formal parameters
140 (define (lambda? exp)
141 (tagged-list? exp 'lambda))
142 (define (lambda-parameters exp) (cadr exp))
143 (define (lambda-body exp) (cddr exp))
145 (define (make-lambda parameters body)
146 (cons 'lambda (cons parameters body)))
148 (define (if? exp) (tagged-list? exp 'if))
149 (define (if-predicate exp) (cadr exp))
150 (define (if-consequent exp) (caddr exp))
151 (define (if-alternative exp)
152 (if (not (null? (cdddr exp)))
156 (define (make-if predicate
165 (tagged-list? exp 'begin))
166 (define (begin-actions exp) (cdr exp))
167 (define (last-exp? seq) (null? (cdr seq)))
168 (define (first-exp seq) (car seq))
169 (define (rest-exps seq) (cdr seq))
171 (define (sequence->exp seq)
172 (cond ((null? seq) seq)
173 ((last-exp? seq) (first-exp seq))
174 (else (make-begin seq))))
176 (define (make-begin seq) (cons 'begin seq))
178 (define (application? exp) (pair? exp))
179 (define (operator exp) (car exp))
180 (define (operands exp) (cdr exp))
181 (define (no-operands? ops) (null? ops))
182 (define (first-operand ops) (car ops))
183 (define (rest-operands ops) (cdr ops))
187 (tagged-list? exp 'cond))
188 (define (cond-clauses exp) (cdr exp))
189 (define (cond-else-clause? clause)
190 (eq? (cond-predicate clause) 'else))
191 (define (cond-predicate clause)
193 (define (cond-actions clause)
195 (define (cond->if exp)
196 (expand-clauses (cond-clauses exp)))
197 (define (expand-clauses clauses)
199 'false ; no else clause
200 (let ((first (car clauses))
201 (rest (cdr clauses)))
202 (if (cond-else-clause? first)
205 (cond-actions first))
206 (error "ELSE clause isn't last: COND->IF"
208 (make-if (cond-predicate first)
210 (cond-actions first))
222 (define (make-procedure parameters body env)
223 (list 'procedure parameters body env))
224 (define (compound-procedure? p)
225 (tagged-list? p 'procedure))
226 (define (procedure-parameters p) (cadr p))
227 (define (procedure-body p) (caddr p))
228 (define (procedure-environment p) (cadddr p))
230 (define (enclosing-environment env) (cdr env))
231 (define (first-frame env) (car env))
232 (define the-empty-environment '())
235 (define (make-frame variables values)
236 (cons variables values))
237 (define (frame-variables frame) (car frame))
238 (define (frame-values frame) (cdr frame))
239 (define (add-binding-to-frame! var val frame)
240 (set-car! frame (cons var (car frame)))
241 (set-cdr! frame (cons val (cdr frame))))
243 (define (extend-environment vars vals base-env)
244 (if (= (length vars) (length vals))
245 (cons (make-frame vars vals) base-env)
246 (if (< (length vars) (length vals))
247 (error "Too many arguments supplied"
250 (error "Too few arguments supplied"
254 (define (lookup-variable-value var env)
255 (define (env-loop env)
256 (define (scan vars vals)
259 (enclosing-environment env)))
260 ((eq? var (car vars))
262 (else (scan (cdr vars)
264 (if (eq? env the-empty-environment)
265 (error "Unbound variable" var)
266 (let ((frame (first-frame env)))
267 (scan (frame-variables frame)
268 (frame-values frame)))))
271 (define (set-variable-value! var val env)
272 (define (env-loop env)
273 (define (scan vars vals)
276 (enclosing-environment env)))
277 ((eq? var (car vars))
279 (else (scan (cdr vars)
281 (if (eq? env the-empty-environment)
282 (error "Unbound variable: SET!" var)
283 (let ((frame (first-frame env)))
284 (scan (frame-variables frame)
285 (frame-values frame)))))
288 (define (define-variable! var val env)
289 (let ((frame (first-frame env)))
290 (define (scan vars vals)
292 (add-binding-to-frame!
294 ((eq? var (car vars))
299 (scan (frame-variables frame)
300 (frame-values frame))))
302 (define (setup-environment)
305 (primitive-procedure-names)
306 (primitive-procedure-objects)
307 the-empty-environment)))
308 (define-variable! 'true true initial-env)
309 (define-variable! 'false false initial-env)
313 (define (primitive-procedure? proc)
314 (tagged-list? proc 'primitive))
316 (define (primitive-implementation proc)
319 (define primitive-procedures
320 (list (list 'car car)
328 (define (primitive-procedure-names)
329 (map car primitive-procedures))
331 (define (primitive-procedure-objects)
333 (list 'primitive (cadr proc)))
334 primitive-procedures))
336 (define (apply-primitive-procedure proc args)
337 (apply-in-underlying-scheme
338 (primitive-implementation proc) args))
340 (define input-prompt ";;; M-Eval input:")
341 (define output-prompt ";;; M-Eval value:")
344 (define (driver-loop)
345 (prompt-for-input input-prompt)
346 (let ((input (read)))
349 the-global-environment)))
350 (announce-output output-prompt)
351 (user-print output)))
354 (define (prompt-for-input string)
356 (display string) (newline))
358 (define (announce-output string)
359 (newline) (display string) (newline))
361 (define (user-print object)
362 (if (compound-procedure? object)
364 (list 'compound-procedure
365 (procedure-parameters object)
366 (procedure-body object)
371 (define the-global-environment (setup-environment))