1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Mandatory SICP Metacircular Evaluator ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 (define apply-in-underlying-scheme apply)
9 ;; Verbatim code from SICP
11 (define (eval exp env)
12 (cond ((self-evaluating? exp)
15 (lookup-variable-value exp env))
17 (text-of-quotation exp))
19 (eval-assignment exp env))
21 (eval-definition exp env))
26 (lambda-parameters exp)
34 (eval (cond->if exp) env))
36 (apply (eval (operator exp) env)
41 (error "Unknown expression type: EVAL" exp))))
43 (define (apply procedure arguments)
44 (cond ((primitive-procedure? procedure)
45 (apply-primitive-procedure
48 ((compound-procedure? procedure)
50 (procedure-body procedure)
55 (procedure-environment
58 (error "Unknown procedure type: APPLY"
61 (define (list-of-values exps env)
62 (if (no-operands? exps)
64 (cons (eval (first-operand exps) env)
69 (define (eval-if exp env)
70 (if (true? (eval (if-predicate exp) env))
71 (eval (if-consequent exp) env)
72 (eval (if-alternative exp) env)))
74 (define (eval-sequence exps env)
75 (cond ((last-exp? exps)
76 (eval (first-exp exps) env))
78 (eval (first-exp exps) env)
79 (eval-sequence (rest-exps exps)
82 (define (eval-assignment exp env)
84 (assignment-variable exp)
85 (eval (assignment-value exp) env)
89 (define (eval-definition exp env)
91 (definition-variable exp)
92 (eval (definition-value exp) env)
96 (define (self-evaluating? exp)
97 (cond ((number? exp) true)
101 (define (variable? exp) (symbol? exp))
103 (define (quoted? exp)
104 (tagged-list? exp 'quote))
106 (define (text-of-quotation exp)
109 (define (tagged-list? exp tag)
114 (define (assignment? exp)
115 (tagged-list? exp 'set!))
117 (define (assignment-variable exp)
120 (define (assignment-value exp) (caddr exp))
122 (define (definition? exp)
123 (tagged-list? exp 'define))
125 (define (definition-variable exp)
126 (if (symbol? (cadr exp))
130 (define (definition-value exp)
131 (if (symbol? (cadr exp))
134 (cdadr exp) ; formal parameters
138 (define (lambda? exp)
139 (tagged-list? exp 'lambda))
140 (define (lambda-parameters exp) (cadr exp))
141 (define (lambda-body exp) (cddr exp))
143 (define (make-lambda parameters body)
144 (cons 'lambda (cons parameters body)))
146 (define (if? exp) (tagged-list? exp 'if))
147 (define (if-predicate exp) (cadr exp))
148 (define (if-consequent exp) (caddr exp))
149 (define (if-alternative exp)
150 (if (not (null? (cdddr exp)))
154 (define (make-if predicate
163 (tagged-list? exp 'begin))
164 (define (begin-actions exp) (cdr exp))
165 (define (last-exp? seq) (null? (cdr seq)))
166 (define (first-exp seq) (car seq))
167 (define (rest-exps seq) (cdr seq))
169 (define (sequence->exp seq)
170 (cond ((null? seq) seq)
171 ((last-exp? seq) (first-exp seq))
172 (else (make-begin seq))))
174 (define (make-begin seq) (cons 'begin seq))
176 (define (application? exp) (pair? exp))
177 (define (operator exp) (car exp))
178 (define (operands exp) (cdr exp))
179 (define (no-operands? ops) (null? ops))
180 (define (first-operand ops) (car ops))
181 (define (rest-operands ops) (cdr ops))
185 (tagged-list? exp 'cond))
186 (define (cond-clauses exp) (cdr exp))
187 (define (cond-else-clause? clause)
188 (eq? (cond-predicate clause) 'else))
189 (define (cond-predicate clause)
191 (define (cond-actions clause)
193 (define (cond->if exp)
194 (expand-clauses (cond-clauses exp)))
195 (define (expand-clauses clauses)
197 'false ; no else clause
198 (let ((first (car clauses))
199 (rest (cdr clauses)))
200 (if (cond-else-clause? first)
203 (cond-actions first))
204 (error "ELSE clause isn't last: COND->IF"
206 (make-if (cond-predicate first)
208 (cond-actions first))
220 (define (make-procedure parameters body env)
221 (list 'procedure parameters body env))
222 (define (compound-procedure? p)
223 (tagged-list? p 'procedure))
224 (define (procedure-parameters p) (cadr p))
225 (define (procedure-body p) (caddr p))
226 (define (procedure-environment p) (cadddr p))
228 (define (enclosing-environment env) (cdr env))
229 (define (first-frame env) (car env))
230 (define the-empty-environment '())
233 (define (make-frame variables values)
234 (cons variables values))
235 (define (frame-variables frame) (car frame))
236 (define (frame-values frame) (cdr frame))
237 (define (add-binding-to-frame! var val frame)
238 (set-car! frame (cons var (car frame)))
239 (set-cdr! frame (cons val (cdr frame))))
241 (define (extend-environment vars vals base-env)
242 (if (= (length vars) (length vals))
243 (cons (make-frame vars vals) base-env)
244 (if (< (length vars) (length vals))
245 (error "Too many arguments supplied"
248 (error "Too few arguments supplied"
252 (define (lookup-variable-value var env)
253 (define (env-loop env)
254 (define (scan vars vals)
257 (enclosing-environment env)))
258 ((eq? var (car vars))
260 (else (scan (cdr vars)
262 (if (eq? env the-empty-environment)
263 (error "Unbound variable" var)
264 (let ((frame (first-frame env)))
265 (scan (frame-variables frame)
266 (frame-values frame)))))
269 (define (set-variable-value! var val env)
270 (define (env-loop env)
271 (define (scan vars vals)
274 (enclosing-environment env)))
275 ((eq? var (car vars))
277 (else (scan (cdr vars)
279 (if (eq? env the-empty-environment)
280 (error "Unbound variable: SET!" var)
281 (let ((frame (first-frame env)))
282 (scan (frame-variables frame)
283 (frame-values frame)))))
286 (define (define-variable! var val env)
287 (let ((frame (first-frame env)))
288 (define (scan vars vals)
290 (add-binding-to-frame!
292 ((eq? var (car vars))
297 (scan (frame-variables frame)
298 (frame-values frame))))
300 (define (setup-environment)
303 (primitive-procedure-names)
304 (primitive-procedure-objects)
305 the-empty-environment)))
306 (define-variable! 'true true initial-env)
307 (define-variable! 'false false initial-env)
311 (define (primitive-procedure? proc)
312 (tagged-list? proc 'primitive))
314 (define (primitive-implementation proc)
317 (define primitive-procedures
318 (list (list 'car car)
326 (define (primitive-procedure-names)
327 (map car primitive-procedures))
329 (define (primitive-procedure-objects)
331 (list 'primitive (cadr proc)))
332 primitive-procedures))
334 (define (apply-primitive-procedure proc args)
335 (apply-in-underlying-scheme
336 (primitive-implementation proc) args))
338 (define input-prompt ";;; M-Eval input:")
339 (define output-prompt ";;; M-Eval value:")
342 (define (driver-loop)
343 (prompt-for-input input-prompt)
344 (let ((input (read)))
347 the-global-environment)))
348 (announce-output output-prompt)
349 (user-print output)))
352 (define (prompt-for-input string)
354 (display string) (newline))
356 (define (announce-output string)
357 (newline) (display string) (newline))
359 (define (user-print object)
360 (if (compound-procedure? object)
362 (list 'compound-procedure
363 (procedure-parameters object)
364 (procedure-body object)
369 (define the-global-environment (setup-environment))