1 665c255d 2023-08-04 jrmu (define (eval exp env)
2 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
3 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
4 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
5 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
6 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
7 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
8 665c255d 2023-08-04 jrmu ((lambda? exp)
9 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
10 665c255d 2023-08-04 jrmu (lambda-body exp)
12 665c255d 2023-08-04 jrmu ((begin? exp)
13 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
14 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
15 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
16 665c255d 2023-08-04 jrmu ((application? exp)
17 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
18 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
20 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
22 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
23 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
24 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
25 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
26 665c255d 2023-08-04 jrmu (eval-sequence
27 665c255d 2023-08-04 jrmu (procedure-body procedure)
28 665c255d 2023-08-04 jrmu (extend-environment
29 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
31 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
34 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
35 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
36 665c255d 2023-08-04 jrmu (if (no-operands? exps)
38 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
39 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
41 665c255d 2023-08-04 jrmu (define (eval-if exp env)
42 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
43 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
44 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
45 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
46 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
47 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
48 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
49 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
50 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
51 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
54 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
55 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
56 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
59 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
60 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
61 665c255d 2023-08-04 jrmu ((string? exp) true)
62 665c255d 2023-08-04 jrmu (else false)))
63 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
64 665c255d 2023-08-04 jrmu (define (quoted? exp)
65 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
67 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
68 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
69 665c255d 2023-08-04 jrmu (if (pair? exp)
70 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
72 665c255d 2023-08-04 jrmu (define (assignment? exp)
73 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
74 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
75 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
76 665c255d 2023-08-04 jrmu (define (definition? exp)
77 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
78 665c255d 2023-08-04 jrmu (define (definition-variable exp)
79 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
81 665c255d 2023-08-04 jrmu (caadr exp)))
82 665c255d 2023-08-04 jrmu (define (definition-value exp)
83 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
85 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
86 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
87 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
88 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
89 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
90 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
91 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
92 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
93 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
94 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
95 665c255d 2023-08-04 jrmu (define (if-alternative exp)
96 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
97 665c255d 2023-08-04 jrmu (cadddr exp)
99 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
100 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
101 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
102 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
103 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
104 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
105 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
107 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
108 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
109 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
110 665c255d 2023-08-04 jrmu (else (make-begin seq))))
111 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
112 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
113 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
114 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
115 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
116 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
117 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
118 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
119 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
120 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
121 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
122 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
123 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
124 665c255d 2023-08-04 jrmu (define (cond->if exp)
125 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
127 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
128 665c255d 2023-08-04 jrmu (if (null? clauses)
129 665c255d 2023-08-04 jrmu 'false ; no else clause
130 665c255d 2023-08-04 jrmu (let ((first (car clauses))
131 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
132 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
133 665c255d 2023-08-04 jrmu (if (null? rest)
134 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
135 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
137 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
138 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
139 665c255d 2023-08-04 jrmu (expand-clauses rest))))))
140 665c255d 2023-08-04 jrmu (define (true? x)
141 665c255d 2023-08-04 jrmu (not (eq? x false)))
142 665c255d 2023-08-04 jrmu (define (false? x)
143 665c255d 2023-08-04 jrmu (eq? x false))
144 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
145 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
146 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
147 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
148 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
149 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
150 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
151 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
152 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
153 665c255d 2023-08-04 jrmu (define the-empty-environment '())
154 665c255d 2023-08-04 jrmu (define (make-frame variables values)
155 665c255d 2023-08-04 jrmu (cons variables values))
156 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
157 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
158 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
159 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
160 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
161 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
162 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
163 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
164 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
165 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
166 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
167 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
168 665c255d 2023-08-04 jrmu (define (env-loop env)
169 665c255d 2023-08-04 jrmu (define (scan vars vals)
170 665c255d 2023-08-04 jrmu (cond ((null? vars)
171 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
172 665c255d 2023-08-04 jrmu ((eq? var (car vars))
173 665c255d 2023-08-04 jrmu (car vals))
174 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
175 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
176 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
177 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
178 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
179 665c255d 2023-08-04 jrmu (frame-values frame)))))
180 665c255d 2023-08-04 jrmu (env-loop env))
181 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
182 665c255d 2023-08-04 jrmu (define (env-loop env)
183 665c255d 2023-08-04 jrmu (define (scan vars vals)
184 665c255d 2023-08-04 jrmu (cond ((null? vars)
185 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
186 665c255d 2023-08-04 jrmu ((eq? var (car vars))
187 665c255d 2023-08-04 jrmu (set-car! vals val))
188 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
189 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
190 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
191 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
192 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
193 665c255d 2023-08-04 jrmu (frame-values frame)))))
194 665c255d 2023-08-04 jrmu (env-loop env))
195 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
196 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
197 665c255d 2023-08-04 jrmu (define (scan vars vals)
198 665c255d 2023-08-04 jrmu (cond ((null? vars)
199 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
200 665c255d 2023-08-04 jrmu ((eq? var (car vars))
201 665c255d 2023-08-04 jrmu (set-car! vals val))
202 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
203 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
204 665c255d 2023-08-04 jrmu (frame-values frame))))
205 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
206 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
208 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
209 665c255d 2023-08-04 jrmu (define primitive-procedures
210 665c255d 2023-08-04 jrmu (list (list 'car car)
211 665c255d 2023-08-04 jrmu (list 'cdr cdr)
212 665c255d 2023-08-04 jrmu (list 'cons cons)
213 665c255d 2023-08-04 jrmu (list 'null? null?)
214 665c255d 2023-08-04 jrmu (list '* *)
215 665c255d 2023-08-04 jrmu (list '/ /)
216 665c255d 2023-08-04 jrmu (list '+ +)
217 665c255d 2023-08-04 jrmu (list '- -)
218 665c255d 2023-08-04 jrmu (list 'display display)))
219 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
221 665c255d 2023-08-04 jrmu primitive-procedures))
223 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
224 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
225 665c255d 2023-08-04 jrmu primitive-procedures))
226 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
227 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
228 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
229 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
230 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
231 665c255d 2023-08-04 jrmu (define (driver-loop)
232 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
233 665c255d 2023-08-04 jrmu (let ((input (read)))
234 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
235 665c255d 2023-08-04 jrmu (announce-output output-prompt)
236 665c255d 2023-08-04 jrmu (user-print output)))
237 665c255d 2023-08-04 jrmu (driver-loop))
238 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
239 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
241 665c255d 2023-08-04 jrmu (define (announce-output string)
242 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
243 665c255d 2023-08-04 jrmu (define (user-print object)
244 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
245 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
246 665c255d 2023-08-04 jrmu (procedure-parameters object)
247 665c255d 2023-08-04 jrmu (procedure-body object)
248 665c255d 2023-08-04 jrmu '<procedure-env>))
249 665c255d 2023-08-04 jrmu (display object)))
250 665c255d 2023-08-04 jrmu (define (setup-environment)
251 665c255d 2023-08-04 jrmu (let ((initial-env
252 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
253 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
254 665c255d 2023-08-04 jrmu the-empty-environment)))
255 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
256 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
257 665c255d 2023-08-04 jrmu initial-env))
258 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
260 665c255d 2023-08-04 jrmu ;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
262 665c255d 2023-08-04 jrmu ;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
265 665c255d 2023-08-04 jrmu (define (let? exp)
266 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
267 665c255d 2023-08-04 jrmu (define (let-vars exp)
268 665c255d 2023-08-04 jrmu (map car (cadr exp)))
269 665c255d 2023-08-04 jrmu (define (let-vals exp)
270 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
271 665c255d 2023-08-04 jrmu (define (let-body exp)
272 665c255d 2023-08-04 jrmu (cddr exp))
273 665c255d 2023-08-04 jrmu (define (let->combination exp)
274 665c255d 2023-08-04 jrmu (cons (make-lambda (let-vars exp) (let-body exp))
275 665c255d 2023-08-04 jrmu (let-vals exp)))
277 665c255d 2023-08-04 jrmu (define (test-case actual expected)
279 665c255d 2023-08-04 jrmu (display "Actual: ")
280 665c255d 2023-08-04 jrmu (display actual)
282 665c255d 2023-08-04 jrmu (display "Expected: ")
283 665c255d 2023-08-04 jrmu (display expected)
286 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
287 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
289 665c255d 2023-08-04 jrmu ;; eval test suite
290 665c255d 2023-08-04 jrmu (test-case (geval
291 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
292 665c255d 2023-08-04 jrmu (+ x y (* x y))))
293 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
295 665c255d 2023-08-04 jrmu '(define old-value
296 665c255d 2023-08-04 jrmu (let ((x 0))
297 665c255d 2023-08-04 jrmu (lambda (y)
298 665c255d 2023-08-04 jrmu (let ((z x))
303 665c255d 2023-08-04 jrmu (test-case (geval '(+ (old-value 4) (old-value 5)))
305 665c255d 2023-08-04 jrmu (test-case (geval '(- (old-value 2) (old-value 8)))
