3 (#%require "ex4_8.rkt" ;; for let and named let
6 ;; metacircular evaluator
8 (cond ((self-evaluating? exp) exp)
9 ((variable? exp) (lookup-variable-value exp env))
10 ((quoted? exp) (text-of-quotation exp))
11 ((assignment? exp) (eval-assignment exp env))
12 ((definition? exp) (eval-definition exp env))
13 ((if? exp) (eval-if exp env))
15 (make-procedure (lambda-parameters exp)
18 ((begin? exp) (eval-sequence (begin-actions exp) env))
19 ((cond? exp) (eval (cond->if exp) env))
20 ((let? exp) (eval (let->combination exp) env)) ;; from ex4.8
21 ((let*? exp) (eval (let*->nested-lets exp) env)) ;; from ex4_7
23 (apply (eval (operator exp) env)
24 (list-of-values (operands exp) env)))
26 (error "unknown expression type -- EVAL" exp))))
28 ;; capture the underlying apply before redefining it
29 (define apply-in-underlying-scheme apply)
31 (define (apply procedure arguments)
32 (cond ((primitive-procedure? procedure)
33 (apply-primitive-procedure procedure arguments))
34 ((compound-procedure? procedure)
36 (procedure-body procedure)
38 (procedure-parameters procedure)
40 (procedure-environment procedure))))
42 (error "unknown procedure type -- APPLY" procedure))))
44 (define (list-of-values exps env)
45 (if (no-operands? exps)
47 (cons (eval (first-operand exps) env)
48 (list-of-values (rest-operands exps) env))))
50 (define (eval-if exp env)
51 (if (true? (eval (if-predicate exp) env))
52 (eval (if-consequent exp) env)
53 (eval (if-alternative exp) env)))
55 (define (eval-sequence exps env)
56 (cond ((last-exp? exps)
57 (eval (first-exp exps) env))
59 (eval (first-exp exps) env)
60 (eval-sequence (rest-exps exps) env))))
62 (define (eval-assignment exp env)
63 (set-variable-value! (assignment-variable exp)
64 (eval (assignment-value exp) env)
68 (define (eval-definition exp env)
69 (define-variable! (definition-variable exp)
70 (eval (definition-value exp) env)
75 (define (self-evaluating? expr)
76 (cond [(number? expr) #t]
80 (define (variable? expr)
84 (define (quoted? expr)
85 (tagged-list? expr 'quote))
87 (define (tagged-list? expr tag)
88 (or (pair? expr) (eq? (car expr) tag)))
90 (define (text-of-quotation expr)
94 (define (assignment? expr)
95 (tagged-list? expr 'set!))
97 (define (assignment-variable expr)
100 (define (assignment-value expr)
101 (car (cdr (cdr expr))))
104 (define (definition? expr)
105 (tagged-list? expr 'define))
107 (define (definition-variable expr)
108 (if (symbol? (car (cdr expr))) ;; (define foo 42)
110 ;; (define (foo x) (....))
111 (car (car (cdr expr)))))
113 (define (definition-value expr)
115 (if (symbol? (car (cdr expr)))
116 (car (cdr (cdr expr)))
117 ;; (define (foo x) (....))
118 (make-lambda (cdr (car (cdr expr))) ;; gives (x)
119 (cdr (cdr expr))))) ;; body
122 (define (lambda? expr)
123 (tagged-list? expr 'lambda))
125 (define (lambda-parameters expr)
128 ;;(lambda (x) (..)(..)...(..))
129 (define (lambda-body expr)
132 (define (make-lambda params body)
133 (cons 'lambda (cons params body)))
136 (define (if? exp) (tagged-list? exp 'if))
137 (define (if-predicate expr) (car (cdr expr)))
138 (define (if-consequent expr) (car (cdr (cdr expr))))
139 (define (if-alternative expr)
140 (if (not (null? (cdr (cdr (cdr expr)))))
141 (car (cdr (cdr (cdr expr))))
144 (define (make-if predicate consequent alternative)
145 (list 'if predicate consequent alternative))
148 (define (begin? exp) (tagged-list? exp 'begin))
149 (define (begin-actions exp) (cdr exp))
150 (define (last-exp? seq) (null? (cdr seq)))
151 (define (first-exp seq) (car seq))
152 (define (rest-exps seq) (cdr seq))
154 (define (sequence->exp seq)
155 (cond ((null? seq) seq)
156 ((last-exp? seq) (first-exp seq))
157 (else (make-begin seq))))
158 (define (make-begin seq) (cons 'begin seq))
160 ;; procedure application
161 (define (application? exp) (pair? exp))
162 (define (operator exp) (car exp))
163 (define (operands exp) (cdr exp))
164 (define (no-operands? ops) (null? ops))
165 (define (first-operand ops) (car ops))
166 (define (rest-operands ops) (cdr ops))
168 ;; expander for `cond' expressions to be transformed into `if' expressions
169 (define (cond? exp) (tagged-list? exp 'cond))
170 (define (cond-clauses exp) (cdr exp))
171 (define (cond-else-clause? clause)
172 (eq? (cond-predicate clause) 'else))
173 (define (cond-predicate clause) (car clause))
174 (define (cond-actions clause) (cdr clause))
175 (define (cond->if exp)
176 (expand-clauses (cond-clauses exp)))
178 (define (expand-clauses clauses)
180 'false ; no else clause
181 (let ((first (car clauses))
182 (rest (cdr clauses)))
183 (if (cond-else-clause? first)
185 (sequence->exp (cond-actions first))
186 (error "ELSE clause isn't last -- COND->IF"
188 (make-if (cond-predicate first)
189 (sequence->exp (cond-actions first))
190 (expand-clauses rest))))))
200 (define (make-procedure parameters body env)
201 (list 'procedure parameters body env))
203 (define (compound-procedure? p)
204 (tagged-list? p 'procedure))
206 (define (procedure-parameters p) (cadr p))
207 (define (procedure-body p) (caddr p))
208 (define (procedure-environment p) (cadddr p))
210 ;; operations on environment
211 (define (enclosing-environment env) (cdr env))
212 (define (first-frame env) (car env))
213 (define the-empty-environment '())
216 (define (make-frame variables values)
217 (cons variables values))
219 (define (frame-variables frame) (car frame))
220 (define (frame-values frame) (cdr frame))
221 (define (add-bindings-to-frame! var val frame)
222 (set-car! frame (cons var (frame-variables frame)))
223 (set-cdr! frame (cons val (frame-values frame))))
225 (define (extend-environment vars vals base-env)
226 (if (= (length vars) (length vals))
227 (cons (make-frame vars vals) base-env)
228 (if (< (length vars) (length vals))
229 (error "Too many args supplied" vars vals)
230 (error "Too many args supplied" vars vals))))
232 (define (lookup-variable-value var env)
233 (define (env-loop env)
234 (define (scan vars vals)
236 (env-loop (enclosing-environment env))]
237 [(eq? var (car vars))
239 [else (scan (cdr vars) (cdr vals))]))
240 (if (eq? env the-empty-environment)
241 (error "unbound variable" var)
242 (let ([frame (first-frame env)])
243 (scan (frame-variables frame)
244 (frame-values frame)))))
247 (define (set-variable-value! var val env)
248 (define (env-loop env)
249 (define (scan vars vals)
251 (env-loop (enclosing-environment env))]
252 [(eq? var (car vars))
254 [else (scan (cdr vars) (cdr vals))]))
255 (if (eq? env the-empty-environment)
256 (error "unbound variable" var)
257 (let ([frame (first-frame env)])
258 (scan (frame-variables frame)
259 (frame-values frame)))))
262 (define (define-variable! var val env)
263 (let ([frame (first-frame env)])
264 (define (scan vars vals)
266 (add-bindings-to-frame! var val frame)]
267 [(eq? var (car vars))
269 [else (scan (cdr vars) (cdr vals))]))
270 (scan (frame-variables frame)
271 (frame-values frame))))
274 ;; primitive procedures
275 (define (primitive-procedure? proc)
276 (tagged-list? proc 'primitive))
278 (define (primitive-implementation proc) (cadr proc))
280 (define primitive-procedures
281 (list (list 'car car)
289 (define (primitive-procedure-names)
290 (map car primitive-procedures))
292 (define (primitive-procedure-objects)
293 (map (lambda (proc) (list 'primitive (cadr proc)))
294 primitive-procedures))
296 ;; apply from implementation language
297 (define (apply-primitive-procedure proc args)
298 (apply-in-underlying-scheme
299 (primitive-implementation proc) args))
301 ;; setting up the environment
302 (define (setup-environment)
304 (extend-environment (primitive-procedure-names)
305 (primitive-procedure-objects)
306 the-empty-environment)))
307 (define-variable! 'true #t initial-env)
308 (define-variable! 'false #f initial-env)
311 (define the-global-environment (setup-environment))