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 (define (apply procedure arguments)
29 (cond ((primitive-procedure? procedure)
30 (apply-primitive-procedure procedure arguments))
31 ((compound-procedure? procedure)
33 (procedure-body procedure)
35 (procedure-parameters procedure)
37 (procedure-environment procedure))))
39 (error "unknown procedure type -- APPLY" procedure))))
41 (define (list-of-values exps env)
42 (if (no-operands? exps)
44 (cons (eval (first-operand exps) env)
45 (list-of-values (rest-operands exps) env))))
47 (define (eval-if exp env)
48 (if (true? (eval (if-predicate exp) env))
49 (eval (if-consequent exp) env)
50 (eval (if-alternative exp) env)))
52 (define (eval-sequence exps env)
53 (cond ((last-exp? exps)
54 (eval (first-exp exps) env))
56 (eval (first-exp exps) env)
57 (eval-sequence (rest-exps exps) env))))
59 (define (eval-assignment exp env)
60 (set-variable-value! (assignment-variable exp)
61 (eval (assignment-value exp) env)
65 (define (eval-definition exp env)
66 (define-variable! (definition-variable exp)
67 (eval (definition-value exp) env)
72 (define (self-evaluating? expr)
73 (cond [(number? expr) #t]
77 (define (variable? expr)
81 (define (quoted? expr)
82 (tagged-list? expr 'quote))
84 (define (tagged-list? expr tag)
85 (or (pair? expr) (eq? (car expr) tag)))
87 (define (text-of-quotation expr)
91 (define (assignment? expr)
92 (tagged-list? expr 'set!))
94 (define (assignment-variable expr)
97 (define (assignment-value expr)
98 (car (cdr (cdr expr))))
101 (define (definition? expr)
102 (tagged-list? expr 'define))
104 (define (definition-variable expr)
105 (if (symbol? (car (cdr expr))) ;; (define foo 42)
107 ;; (define (foo x) (....))
108 (car (car (cdr expr)))))
110 (define (definition-value expr)
112 (if (symbol? (car (cdr expr)))
113 (car (cdr (cdr expr)))
114 ;; (define (foo x) (....))
115 (make-lambda (cdr (car (cdr expr))) ;; gives (x)
116 (cdr (cdr expr))))) ;; body
119 (define (lambda? expr)
120 (tagged-list? expr 'lambda))
122 (define (lambda-parameters expr)
125 ;;(lambda (x) (..)(..)...(..))
126 (define (lambda-body expr)
129 (define (make-lambda params body)
130 (cons 'lambda (cons params body)))
133 (define (if? exp) (tagged-list? exp 'if))
134 (define (if-predicate expr) (car (cdr expr)))
135 (define (if-consequent expr) (car (cdr (cdr expr))))
136 (define (if-alternative expr)
137 (if (not (null? (cdr (cdr (cdr expr)))))
138 (car (cdr (cdr (cdr expr))))
141 (define (make-if predicate consequent alternative)
142 (list 'if predicate consequent alternative))
145 (define (begin? exp) (tagged-list? exp 'begin))
146 (define (begin-actions exp) (cdr exp))
147 (define (last-exp? seq) (null? (cdr seq)))
148 (define (first-exp seq) (car seq))
149 (define (rest-exp seq) (cdr seq))
151 (define (sequence->exp seq)
152 (cond ((null? seq) seq)
153 ((last-exp? seq) (first-exp seq))
154 (else (make-begin seq))))
155 (define (make-begin seq) (cons 'begin seq))
157 ;; procedure application
158 (define (application? exp) (pair? exp))
159 (define (operator exp) (car exp))
160 (define (operands exp) (cdr exp))
161 (define (no-operands? ops) (null? ops))
162 (define (first-operand ops) (car ops))
163 (define (rest-operands ops) (cdr ops))
165 ;; expander for `cond' expressions to be transformed into `if' expressions
166 (define (cond? exp) (tagged-list? exp 'cond))
167 (define (cond-clauses exp) (cdr exp))
168 (define (cond-else-clause? clause)
169 (eq? (cond-predicate clause) 'else))
170 (define (cond-predicate clause) (car clause))
171 (define (cond-actions clause) (cdr clause))
172 (define (cond->if exp)
173 (expand-clauses (cond-clauses exp)))
175 (define (expand-clauses clauses)
177 'false ; no else clause
178 (let ((first (car clauses))
179 (rest (cdr clauses)))
180 (if (cond-else-clause? first)
182 (sequence->exp (cond-actions first))
183 (error "ELSE clause isn't last -- COND->IF"
185 (make-if (cond-predicate first)
186 (sequence->exp (cond-actions first))
187 (expand-clauses rest))))))
197 (define (make-procedure parameters body env)
198 (list 'procedure parameters body env))
200 (define (compound-procedure? p)
201 (tagged-list? p 'procedure))
203 (define (procedure-parameters p) (cadr p))
204 (define (procedure-body p) (caddr p))
205 (define (procedure-env p) (cadddr p))
207 ;; operations on environment
208 (define (enclosing-environment env) (cdr env))
209 (define (first-frame env) (car env))
210 (define the-empty-environment '())
213 (define (make-frame variables values)
214 (cons variables values))
216 (define (frame-variables frame) (car frame))
217 (define (frame-values frame) (cdr frame))
218 (define (add-bindings-to-frame! var val frame)
219 (set-car! frame (cons var (frame-variables frame)))
220 (set-cdr! frame (cons val (frame-values frame))))
222 (define (extend-environment vars vals base-env)
223 (if (= (length vars) (length vals))
224 (cons (make-frame vars vals) base-env)
225 (if (< (length vars) (length vals))
226 (error "Too many args supplied" vars vals)
227 (error "Too many args supplied" vars vals))))
229 (define (lookup-variable-value var env)
230 (define (env-loop env)
231 (define (scan vars vals)
233 (env-loop (enclosing-environment env))]
234 [(eq? var (car vars))
236 [else (scan (cdr vars) (cdr vals))]))
237 (if (eq? env the-empty-environment)
238 (error "unbound variable" var)
239 (let ([frame (first-frame env)])
240 (scan (frame-variables frame)
241 (frame-values frame)))))
244 (define (set-variable-value! var val env)
245 (define (env-loop env)
246 (define (scan vars vals)
248 (env-loop (enclosing-environment env))]
249 [(eq? var (car vars))
251 [else (scan (cdr vars) (cdr vals))]))
252 (if (eq? env the-empty-environment)
253 (error "unbound variable" var)
254 (let ([frame (first-frame env)])
255 (scan (frame-variables frame)
256 (frame-values frame)))))
259 (define (define-variable! var val env)
260 (let ([frame (first-frame env)])
261 (define (scan vars vals)
263 (add-bindings-to-frame! var val frame)]
264 [(eq? var (car vars))
266 [else (scan (cdr vars) (cdr vals))]))
267 (scan (frame-variables frame)
268 (frame-values frame))))