1 665c255d 2023-08-04 jrmu ;; (define apply-in-underlying-scheme apply)
2 665c255d 2023-08-04 jrmu ;; (define eval-in-underlying-scheme eval)
4 665c255d 2023-08-04 jrmu (define (eval exp env)
5 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
6 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
7 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
8 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
9 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
10 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
11 665c255d 2023-08-04 jrmu ((lambda? exp)
12 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
13 665c255d 2023-08-04 jrmu (lambda-body exp)
15 665c255d 2023-08-04 jrmu ((begin? exp)
16 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
17 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
18 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
19 665c255d 2023-08-04 jrmu ((application? exp)
20 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
21 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
23 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
25 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
26 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
27 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
28 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
29 665c255d 2023-08-04 jrmu (eval-sequence
30 665c255d 2023-08-04 jrmu (procedure-body procedure)
31 665c255d 2023-08-04 jrmu (extend-environment
32 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
34 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
37 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
38 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
39 665c255d 2023-08-04 jrmu (if (no-operands? exps)
41 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
42 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
44 665c255d 2023-08-04 jrmu (define (eval-if exp env)
45 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
46 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
47 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
48 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
49 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
50 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
51 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
52 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
53 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
54 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
57 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
58 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
59 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
62 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
63 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
64 665c255d 2023-08-04 jrmu ((string? exp) true)
65 665c255d 2023-08-04 jrmu (else false)))
66 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
67 665c255d 2023-08-04 jrmu (define (quoted? exp)
68 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
70 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
71 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
72 665c255d 2023-08-04 jrmu (if (pair? exp)
73 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
75 665c255d 2023-08-04 jrmu (define (assignment? exp)
76 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
77 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
78 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
79 665c255d 2023-08-04 jrmu (define (definition? exp)
80 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
81 665c255d 2023-08-04 jrmu (define (definition-variable exp)
82 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
84 665c255d 2023-08-04 jrmu (caadr exp)))
85 665c255d 2023-08-04 jrmu (define (definition-value exp)
86 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
88 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
89 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
90 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
91 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
92 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
93 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
94 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
95 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
96 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
97 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
98 665c255d 2023-08-04 jrmu (define (if-alternative exp)
99 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
100 665c255d 2023-08-04 jrmu (cadddr exp)
102 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
103 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
104 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
105 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
106 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
107 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
108 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
110 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
111 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
112 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
113 665c255d 2023-08-04 jrmu (else (make-begin seq))))
114 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
115 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
116 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
117 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
118 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
119 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
120 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
121 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
122 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
123 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
124 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
125 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
126 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
127 665c255d 2023-08-04 jrmu (define (cond->if exp)
128 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
130 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
131 665c255d 2023-08-04 jrmu (if (null? clauses)
132 665c255d 2023-08-04 jrmu 'false ; no else clause
133 665c255d 2023-08-04 jrmu (let ((first (car clauses))
134 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
135 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
136 665c255d 2023-08-04 jrmu (if (null? rest)
137 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
138 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
140 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
141 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
142 665c255d 2023-08-04 jrmu (expand-clauses rest))))))
143 665c255d 2023-08-04 jrmu (define (true? x)
144 665c255d 2023-08-04 jrmu (not (eq? x false)))
145 665c255d 2023-08-04 jrmu (define (false? x)
146 665c255d 2023-08-04 jrmu (eq? x false))
147 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
148 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
149 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
150 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
151 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
152 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
153 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
154 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
155 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
156 665c255d 2023-08-04 jrmu (define the-empty-environment '())
157 665c255d 2023-08-04 jrmu (define (make-frame variables values)
158 665c255d 2023-08-04 jrmu (cons variables values))
159 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
160 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
161 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
162 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
163 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
164 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
165 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
166 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
167 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
168 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
169 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
170 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
171 665c255d 2023-08-04 jrmu (define (env-loop env)
172 665c255d 2023-08-04 jrmu (define (scan vars vals)
173 665c255d 2023-08-04 jrmu (cond ((null? vars)
174 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
175 665c255d 2023-08-04 jrmu ((eq? var (car vars))
176 665c255d 2023-08-04 jrmu (car vals))
177 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
178 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
179 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
180 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
181 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
182 665c255d 2023-08-04 jrmu (frame-values frame)))))
183 665c255d 2023-08-04 jrmu (env-loop env))
184 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
185 665c255d 2023-08-04 jrmu (define (env-loop env)
186 665c255d 2023-08-04 jrmu (define (scan vars vals)
187 665c255d 2023-08-04 jrmu (cond ((null? vars)
188 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
189 665c255d 2023-08-04 jrmu ((eq? var (car vars))
190 665c255d 2023-08-04 jrmu (set-car! vals val))
191 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
192 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
193 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
194 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
195 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
196 665c255d 2023-08-04 jrmu (frame-values frame)))))
197 665c255d 2023-08-04 jrmu (env-loop env))
198 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
199 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
200 665c255d 2023-08-04 jrmu (define (scan vars vals)
201 665c255d 2023-08-04 jrmu (cond ((null? vars)
202 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
203 665c255d 2023-08-04 jrmu ((eq? var (car vars))
204 665c255d 2023-08-04 jrmu (set-car! vals val))
205 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
206 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
207 665c255d 2023-08-04 jrmu (frame-values frame))))
208 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
209 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
211 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
212 665c255d 2023-08-04 jrmu (define primitive-procedures
213 665c255d 2023-08-04 jrmu (list (list 'car car)
214 665c255d 2023-08-04 jrmu (list 'cdr cdr)
215 665c255d 2023-08-04 jrmu (list 'cons cons)
216 665c255d 2023-08-04 jrmu (list 'null? null?)
217 665c255d 2023-08-04 jrmu (list '* *)
218 665c255d 2023-08-04 jrmu (list '/ /)
219 665c255d 2023-08-04 jrmu (list '+ +)
220 665c255d 2023-08-04 jrmu (list '- -)
221 665c255d 2023-08-04 jrmu (list '= =)
222 665c255d 2023-08-04 jrmu (list 'display display)))
223 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
225 665c255d 2023-08-04 jrmu primitive-procedures))
227 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
228 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
229 665c255d 2023-08-04 jrmu primitive-procedures))
230 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
231 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
232 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
233 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
234 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
235 665c255d 2023-08-04 jrmu (define (driver-loop)
236 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
237 665c255d 2023-08-04 jrmu (let ((input (read)))
238 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
239 665c255d 2023-08-04 jrmu (announce-output output-prompt)
240 665c255d 2023-08-04 jrmu (user-print output)))
241 665c255d 2023-08-04 jrmu (driver-loop))
242 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
243 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
245 665c255d 2023-08-04 jrmu (define (announce-output string)
246 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
247 665c255d 2023-08-04 jrmu (define (user-print object)
248 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
249 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
250 665c255d 2023-08-04 jrmu (procedure-parameters object)
251 665c255d 2023-08-04 jrmu (procedure-body object)
252 665c255d 2023-08-04 jrmu '<procedure-env>))
253 665c255d 2023-08-04 jrmu (display object)))
254 665c255d 2023-08-04 jrmu (define (setup-environment)
255 665c255d 2023-08-04 jrmu (let ((initial-env
256 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
257 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
258 665c255d 2023-08-04 jrmu the-empty-environment)))
259 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
260 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
261 665c255d 2023-08-04 jrmu initial-env))
262 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
264 665c255d 2023-08-04 jrmu (define (let? exp)
265 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
266 665c255d 2023-08-04 jrmu (define (let-vars exp)
267 665c255d 2023-08-04 jrmu (map car (cadr exp)))
268 665c255d 2023-08-04 jrmu (define (let-vals exp)
269 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
270 665c255d 2023-08-04 jrmu (define (let-body exp)
271 665c255d 2023-08-04 jrmu (cddr exp))
272 665c255d 2023-08-04 jrmu (define (let->combination exp)
273 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
274 665c255d 2023-08-04 jrmu (let-vals exp)))
275 665c255d 2023-08-04 jrmu (define (make-application op args)
276 665c255d 2023-08-04 jrmu (cons op args))
278 665c255d 2023-08-04 jrmu (define (test-case actual expected)
280 665c255d 2023-08-04 jrmu (display "Actual: ")
281 665c255d 2023-08-04 jrmu (display actual)
283 665c255d 2023-08-04 jrmu (display "Expected: ")
284 665c255d 2023-08-04 jrmu (display expected)
287 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
288 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
290 665c255d 2023-08-04 jrmu ;; Exercise 4.2. Louis Reasoner plans to reorder the cond clauses in eval so that the clause for procedure applications appears before the clause for assignments. He argues that this will make the interpreter more efficient: Since programs usually contain more applications than assignments, definitions, and so on, his modified eval will usually check fewer clauses than the original eval before identifying the type of an expression.
292 665c255d 2023-08-04 jrmu ;; a. What is wrong with Louis's plan? (Hint: What will Louis's evaluator do with the expression (define x 3)?)
294 665c255d 2023-08-04 jrmu ;; the define special form will be interpreted as an application because the only requirement is that the expression be a pair
296 665c255d 2023-08-04 jrmu ;; b. Louis is upset that his plan didn't work. He is willing to go to any lengths to make his evaluator recognize procedure applications before it checks for most other kinds of expressions. Help him by changing the syntax of the evaluated language so that procedure applications start with call. For example, instead of (factorial 3) we will now have to write (call factorial 3) and instead of (+ 1 2) we will have to write (call + 1 2).
298 665c255d 2023-08-04 jrmu (define (application? exp) (tagged-list? exp 'call))
299 665c255d 2023-08-04 jrmu (define (operator exp) (cadr exp))
300 665c255d 2023-08-04 jrmu (define (operands exp) (cddr exp))
301 665c255d 2023-08-04 jrmu (define (make-application op args)
302 665c255d 2023-08-04 jrmu (cons 'call (cons op args)))
304 665c255d 2023-08-04 jrmu '(define (factorial n)
305 665c255d 2023-08-04 jrmu (if (call = n 0)
307 665c255d 2023-08-04 jrmu (call * n (call factorial (call - n 1))))))
308 665c255d 2023-08-04 jrmu (test-case (geval '(call factorial 5)) 120)
310 665c255d 2023-08-04 jrmu (test-case (geval
311 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
312 665c255d 2023-08-04 jrmu (call + x y (call * x y))))
313 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
