1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Mandatory SICP Metacircular Evaluator ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 (define apply-in-underlying-scheme apply)
7 ;; Verbatim code from SICP
9 (display "eval and apply\n")
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 (self-evaluating? exp)
90 (cond ((number? exp) true)
94 (define (variable? exp) (symbol? exp))
97 (tagged-list? exp 'quote))
99 (define (text-of-quotation exp)
102 (define (tagged-list? exp tag)
107 (define (assignment? exp)
108 (tagged-list? exp 'set!))
110 (define (assignment-variable exp)
113 (define (assignment-value exp) (caddr exp))
115 (define (definition? exp)
116 (tagged-list? exp 'define))
118 (define (definition-variable exp)
119 (if (symbol? (cadr exp))
123 (define (definition-value exp)
124 (if (symbol? (cadr exp))
127 (cdadr exp) ; formal parameters
131 (display "lambda... \n")
133 (define (lambda? exp)
134 (tagged-list? exp 'lambda))
135 (define (lambda-parameters exp) (cadr exp))
136 (define (lambda-body exp) (cddr exp))
138 (define (make-lambda parameters body)
139 (cons 'lambda (cons parameters body)))
141 (define (if? exp) (tagged-list? exp 'if))
142 (define (if-predicate exp) (cadr exp))
143 (define (if-consequent exp) (caddr exp))
144 (define (if-alternative exp)
145 (if (not (null? (cdddr exp)))
149 (define (make-if predicate
158 (tagged-list? exp 'begin))
159 (define (begin-actions exp) (cdr exp))
160 (define (last-exp? seq) (null? (cdr seq)))
161 (define (first-exp seq) (car seq))
162 (define (rest-exps seq) (cdr seq))
164 (define (sequence->exp seq)
165 (cond ((null? seq) seq)
166 ((last-exp? seq) (first-exp seq))
167 (else (make-begin seq))))
169 (define (make-begin seq) (cons 'begin seq))
171 (define (application? exp) (pair? exp))
172 (define (operator exp) (car exp))
173 (define (operands exp) (cdr exp))
174 (define (no-operands? ops) (null? ops))
175 (define (first-operand ops) (car ops))
176 (define (rest-operands ops) (cdr ops))
179 (display "cond... \n")
182 (tagged-list? exp 'cond))
183 (define (cond-clauses exp) (cdr exp))
184 (define (cond-else-clause? clause)
185 (eq? (cond-predicate clause) 'else))
186 (define (cond-predicate clause)
188 (define (cond-actions clause)
190 (define (cond->if exp)
191 (expand-clauses (cond-clauses exp)))
192 (define (expand-clauses clauses)
194 'false ; no else clause
195 (let ((first (car clauses))
196 (rest (cdr clauses)))
197 (if (cond-else-clause? first)
200 (cond-actions first))
201 (error "ELSE clause isn't last: COND->IF"
203 (make-if (cond-predicate first)
205 (cond-actions first))
217 (display "make-procedure...\n")
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 (display "make-frame\n")
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 (display "extend-environment\n")
245 (define (extend-environment vars vals base-env)
246 (if (= (length vars) (length vals))
247 (cons (make-frame vars vals) base-env)
248 (if (< (length vars) (length vals))
249 (error "Too many arguments supplied"
252 (error "Too few arguments supplied"
256 (display "lookup-variable\n")
258 (define (lookup-variable-value var env)
259 (define (env-loop env)
260 (define (scan vars vals)
263 (enclosing-environment env)))
264 ((eq? var (car vars))
266 (else (scan (cdr vars)
268 (if (eq? env the-empty-environment)
269 (error "Unbound variable" var)
270 (let ((frame (first-frame env)))
271 (scan (frame-variables frame)
272 (frame-values frame)))))
275 (display "set-variable\n")
277 (define (set-variable-value! var val env)
278 (define (env-loop env)
279 (define (scan vars vals)
282 (enclosing-environment env)))
283 ((eq? var (car vars))
285 (else (scan (cdr vars)
287 (if (eq? env the-empty-environment)
288 (error "Unbound variable: SET!" var)
289 (let ((frame (first-frame env)))
290 (scan (frame-variables frame)
291 (frame-values frame)))))
294 (display "define-variable\n")
296 (define (define-variable! var val env)
297 (let ((frame (first-frame env)))
298 (define (scan vars vals)
300 (add-binding-to-frame!
302 ((eq? var (car vars))
304 (else (scan (cdr vars)
306 (scan (frame-variables frame)
307 (frame-values frame))))
309 (display "setup-environment...\n")
311 (define (setup-environment)
314 (primitive-procedure-names)
315 (primitive-procedure-objects)
316 the-empty-environment)))
317 (define-variable! 'true true initial-env)
318 (define-variable! 'false false initial-env)
321 (define (primitive-procedure? proc)
322 (tagged-list? proc 'primitive))
324 (define (primitive-implementation proc)
327 (define primitive-procedures
328 (list (list 'car car)
336 (define (primitive-procedure-names)
337 (map car primitive-procedures))
339 (define (primitive-procedure-objects)
341 (list 'primitive (cadr proc)))
342 primitive-procedures))
346 (define (apply-primitive-procedure proc args)
347 (apply-in-underlying-scheme
348 (primitive-implementation proc) args))
350 (define input-prompt ";;; M-Eval input:")
351 (define output-prompt ";;; M-Eval value:")
354 (display "driver-loop...\n")
357 (define (driver-loop)
358 (prompt-for-input input-prompt)
359 (let ((input (read)))
362 the-global-environment)))
363 (announce-output output-prompt)
364 (user-print output)))
367 (define (prompt-for-input string)
369 (display string) (newline))
371 (define (announce-output string)
372 (newline) (display string) (newline))
374 (define (user-print object)
375 (if (compound-procedure? object)
377 (list 'compound-procedure
378 (procedure-parameters object)
379 (procedure-body object)
383 (define the-global-environment