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 ((and? exp) (eval-and exp env))
9 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
10 665c255d 2023-08-04 jrmu ((lambda? exp)
11 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
12 665c255d 2023-08-04 jrmu (lambda-body exp)
14 665c255d 2023-08-04 jrmu ((begin? exp)
15 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
16 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
17 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
18 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
19 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
20 665c255d 2023-08-04 jrmu ((do? exp) (eval (do->combination exp) env))
21 665c255d 2023-08-04 jrmu ((application? exp)
22 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
23 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
25 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
26 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
27 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
28 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
29 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
30 665c255d 2023-08-04 jrmu (eval-sequence
31 665c255d 2023-08-04 jrmu (procedure-body procedure)
32 665c255d 2023-08-04 jrmu (extend-environment
33 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
35 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
38 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
40 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
41 665c255d 2023-08-04 jrmu (if (no-operands? exps)
43 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
44 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
46 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
47 665c255d 2023-08-04 jrmu (if (pair? exp)
48 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
51 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
52 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
53 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
54 665c255d 2023-08-04 jrmu ((string? exp) true)
55 665c255d 2023-08-04 jrmu (else false)))
56 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
57 665c255d 2023-08-04 jrmu (define (quoted? exp)
58 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
59 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
61 665c255d 2023-08-04 jrmu ;; assignment/definition
62 665c255d 2023-08-04 jrmu (define (assignment? exp)
63 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
64 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
65 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
66 665c255d 2023-08-04 jrmu (define (definition? exp)
67 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
68 665c255d 2023-08-04 jrmu (define (definition-variable exp)
69 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
71 665c255d 2023-08-04 jrmu (caadr exp)))
72 665c255d 2023-08-04 jrmu (define (definition-value exp)
73 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
75 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
76 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
77 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
78 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
79 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
82 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
83 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
84 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
87 665c255d 2023-08-04 jrmu (define (make-definition var val)
88 665c255d 2023-08-04 jrmu `(define ,var ,val))
91 665c255d 2023-08-04 jrmu ;; if/and/or
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 (eval-if exp env)
102 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
103 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
104 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
106 665c255d 2023-08-04 jrmu (define (and? exp)
107 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
108 665c255d 2023-08-04 jrmu (define (and-clauses exp)
110 665c255d 2023-08-04 jrmu (define (or? exp)
111 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
112 665c255d 2023-08-04 jrmu (define (or-clauses exp)
114 665c255d 2023-08-04 jrmu (define (eval-and exp env)
115 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
116 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
117 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
118 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
119 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
120 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
121 665c255d 2023-08-04 jrmu (define (eval-or exp env)
122 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
123 665c255d 2023-08-04 jrmu (if (null? clauses)
125 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
126 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
127 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
130 665c255d 2023-08-04 jrmu ;; lambda/let/let*
131 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
132 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
133 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
134 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
135 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
137 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
139 665c255d 2023-08-04 jrmu (cons (map (lambda (var val)
140 665c255d 2023-08-04 jrmu (list var val))
143 665c255d 2023-08-04 jrmu (define (let? exp)
144 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
145 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
146 665c255d 2023-08-04 jrmu (define (let-vars exp)
147 665c255d 2023-08-04 jrmu (map car (cadr exp)))
148 665c255d 2023-08-04 jrmu (define (let-vals exp)
149 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
150 665c255d 2023-08-04 jrmu (define (let-body exp)
151 665c255d 2023-08-04 jrmu (cddr exp))
152 665c255d 2023-08-04 jrmu (define (let->combination exp)
153 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
154 665c255d 2023-08-04 jrmu (let-vals exp)))
155 665c255d 2023-08-04 jrmu (define (named-let? exp)
156 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
157 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
158 665c255d 2023-08-04 jrmu (define (named-let-name exp)
159 665c255d 2023-08-04 jrmu (cadr exp))
160 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
161 665c255d 2023-08-04 jrmu (map car (caddr exp)))
162 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
163 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
164 665c255d 2023-08-04 jrmu (define (named-let-body exp)
165 665c255d 2023-08-04 jrmu (cdddr exp))
166 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
167 665c255d 2023-08-04 jrmu (sequence->exp
168 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
169 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
170 665c255d 2023-08-04 jrmu (named-let-body exp)))
171 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
172 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
175 665c255d 2023-08-04 jrmu (define (make-application op args)
176 665c255d 2023-08-04 jrmu (cons op args))
178 665c255d 2023-08-04 jrmu (define (let*? exp)
179 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
180 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
181 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
182 665c255d 2023-08-04 jrmu (define let*-body let-body)
183 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
184 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
185 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
186 665c255d 2023-08-04 jrmu (make-let (list (car vars))
187 665c255d 2023-08-04 jrmu (list (car vals))
188 665c255d 2023-08-04 jrmu (let*-body exp))
189 665c255d 2023-08-04 jrmu (make-let (list (car vars))
190 665c255d 2023-08-04 jrmu (list (car vals))
191 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
192 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
193 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
194 665c255d 2023-08-04 jrmu (if (null? vars)
195 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
196 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
199 665c255d 2023-08-04 jrmu ;; begin/sequence
200 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
201 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
202 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
203 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
204 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
205 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
206 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
207 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
208 665c255d 2023-08-04 jrmu (else (make-begin seq))))
209 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
210 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
211 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
212 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
213 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
215 665c255d 2023-08-04 jrmu ;; application
216 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
217 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
218 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
219 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
220 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
221 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
224 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
225 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
226 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
227 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
228 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
229 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
230 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
231 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
232 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
233 665c255d 2023-08-04 jrmu (caddr clause))
234 665c255d 2023-08-04 jrmu (define (cond->if exp)
235 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
236 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
237 665c255d 2023-08-04 jrmu (if (null? clauses)
238 665c255d 2023-08-04 jrmu 'false ; no else clause
239 665c255d 2023-08-04 jrmu (let ((first (car clauses))
240 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
241 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
242 665c255d 2023-08-04 jrmu (if (null? rest)
243 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
244 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
246 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
247 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
248 665c255d 2023-08-04 jrmu (make-application
249 665c255d 2023-08-04 jrmu (cond-extended-proc first)
250 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
251 665c255d 2023-08-04 jrmu (expand-clauses rest))
252 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
253 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
254 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
255 665c255d 2023-08-04 jrmu (define (true? x)
256 665c255d 2023-08-04 jrmu (not (eq? x false)))
257 665c255d 2023-08-04 jrmu (define (false? x)
258 665c255d 2023-08-04 jrmu (eq? x false))
260 665c255d 2023-08-04 jrmu ;; procedure
261 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
262 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
263 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
264 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
265 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
266 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
267 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
269 665c255d 2023-08-04 jrmu ;; environment
270 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
271 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
272 665c255d 2023-08-04 jrmu (define the-empty-environment '())
273 665c255d 2023-08-04 jrmu (define (make-frame variables values)
274 665c255d 2023-08-04 jrmu (cons variables values))
275 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
276 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
277 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
278 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
279 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
280 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
281 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
282 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
283 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
284 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
285 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
286 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
287 665c255d 2023-08-04 jrmu (define (env-loop env)
288 665c255d 2023-08-04 jrmu (define (scan vars vals)
289 665c255d 2023-08-04 jrmu (cond ((null? vars)
290 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
291 665c255d 2023-08-04 jrmu ((eq? var (car vars))
292 665c255d 2023-08-04 jrmu (car vals))
293 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
294 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
295 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
296 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
297 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
298 665c255d 2023-08-04 jrmu (frame-values frame)))))
299 665c255d 2023-08-04 jrmu (env-loop env))
300 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
301 665c255d 2023-08-04 jrmu (define (env-loop env)
302 665c255d 2023-08-04 jrmu (define (scan vars vals)
303 665c255d 2023-08-04 jrmu (cond ((null? vars)
304 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
305 665c255d 2023-08-04 jrmu ((eq? var (car vars))
306 665c255d 2023-08-04 jrmu (set-car! vals val))
307 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
308 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
309 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
310 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
311 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
312 665c255d 2023-08-04 jrmu (frame-values frame)))))
313 665c255d 2023-08-04 jrmu (env-loop env))
314 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
315 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
316 665c255d 2023-08-04 jrmu (define (scan vars vals)
317 665c255d 2023-08-04 jrmu (cond ((null? vars)
318 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
319 665c255d 2023-08-04 jrmu ((eq? var (car vars))
320 665c255d 2023-08-04 jrmu (set-car! vals val))
321 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
322 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
323 665c255d 2023-08-04 jrmu (frame-values frame))))
325 665c255d 2023-08-04 jrmu ;; primitives
326 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
327 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
328 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
329 665c255d 2023-08-04 jrmu (define primitive-procedures
330 665c255d 2023-08-04 jrmu (list (list 'car car)
331 665c255d 2023-08-04 jrmu (list 'cdr cdr)
332 665c255d 2023-08-04 jrmu (list 'caar caar)
333 665c255d 2023-08-04 jrmu (list 'cadr cadr)
334 665c255d 2023-08-04 jrmu (list 'cddr cddr)
335 665c255d 2023-08-04 jrmu (list 'cons cons)
336 665c255d 2023-08-04 jrmu (list 'null? null?)
337 665c255d 2023-08-04 jrmu (list '* *)
338 665c255d 2023-08-04 jrmu (list '/ /)
339 665c255d 2023-08-04 jrmu (list '+ +)
340 665c255d 2023-08-04 jrmu (list '- -)
341 665c255d 2023-08-04 jrmu (list '= =)
342 665c255d 2023-08-04 jrmu (list '< <)
343 665c255d 2023-08-04 jrmu (list '> >)
344 665c255d 2023-08-04 jrmu (list '<= <=)
345 665c255d 2023-08-04 jrmu (list '>= >=)
346 665c255d 2023-08-04 jrmu (list 'remainder remainder)
347 665c255d 2023-08-04 jrmu (list 'eq? eq?)
348 665c255d 2023-08-04 jrmu (list 'equal? equal?)
349 665c255d 2023-08-04 jrmu (list 'display display)))
350 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
352 665c255d 2023-08-04 jrmu primitive-procedures))
353 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
354 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
355 665c255d 2023-08-04 jrmu primitive-procedures))
356 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
357 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
358 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
360 665c255d 2023-08-04 jrmu ;; driver-loop
361 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
362 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
363 665c255d 2023-08-04 jrmu (define (driver-loop)
364 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
365 665c255d 2023-08-04 jrmu (let ((input (read)))
366 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
367 665c255d 2023-08-04 jrmu (announce-output output-prompt)
368 665c255d 2023-08-04 jrmu (user-print output)))
369 665c255d 2023-08-04 jrmu (driver-loop))
370 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
371 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
373 665c255d 2023-08-04 jrmu (define (announce-output string)
374 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
375 665c255d 2023-08-04 jrmu (define (user-print object)
376 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
377 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
378 665c255d 2023-08-04 jrmu (procedure-parameters object)
379 665c255d 2023-08-04 jrmu (procedure-body object)
380 665c255d 2023-08-04 jrmu '<procedure-env>))
381 665c255d 2023-08-04 jrmu (display object)))
382 665c255d 2023-08-04 jrmu (define (setup-environment)
383 665c255d 2023-08-04 jrmu (let ((initial-env
384 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
385 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
386 665c255d 2023-08-04 jrmu the-empty-environment)))
387 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
388 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
389 665c255d 2023-08-04 jrmu initial-env))
390 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
392 665c255d 2023-08-04 jrmu ;; auxiliary
393 665c255d 2023-08-04 jrmu (define (test-case actual expected)
395 665c255d 2023-08-04 jrmu (display "Actual: ")
396 665c255d 2023-08-04 jrmu (display actual)
398 665c255d 2023-08-04 jrmu (display "Expected: ")
399 665c255d 2023-08-04 jrmu (display expected)
401 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
402 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
403 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
404 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
406 665c255d 2023-08-04 jrmu ;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
408 665c255d 2023-08-04 jrmu ;; Implemented according to this spec:
409 665c255d 2023-08-04 jrmu ;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
412 665c255d 2023-08-04 jrmu ;; (do ((vec (make-vector 5))
413 665c255d 2023-08-04 jrmu ;; (i 0 (+ i 1)))
414 665c255d 2023-08-04 jrmu ;; ((= i 5) vec)
415 665c255d 2023-08-04 jrmu ;; (vector-set! vec i i)) => #(0 1 2 3 4)
417 665c255d 2023-08-04 jrmu (define (do? exp)
418 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
419 665c255d 2023-08-04 jrmu (define (do-vars exp)
420 665c255d 2023-08-04 jrmu (map car (cadr exp)))
421 665c255d 2023-08-04 jrmu (define (do-inits exp)
422 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
423 665c255d 2023-08-04 jrmu (define (do-steps exp)
424 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
425 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
426 665c255d 2023-08-04 jrmu (car var-init-step)
427 665c255d 2023-08-04 jrmu (caddr var-init-step)))
428 665c255d 2023-08-04 jrmu (cadr exp)))
429 665c255d 2023-08-04 jrmu (define (do-test exp)
430 665c255d 2023-08-04 jrmu (caaddr exp))
431 665c255d 2023-08-04 jrmu (define (do-expressions exp)
432 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
433 665c255d 2023-08-04 jrmu (caddr exp)
434 665c255d 2023-08-04 jrmu (cdaddr exp)))
435 665c255d 2023-08-04 jrmu (define (do-commands exp)
436 665c255d 2023-08-04 jrmu (cdddr exp))
437 665c255d 2023-08-04 jrmu (define (do->combination exp)
438 665c255d 2023-08-04 jrmu (sequence->exp
440 665c255d 2023-08-04 jrmu (make-definition
442 665c255d 2023-08-04 jrmu (make-lambda
443 665c255d 2023-08-04 jrmu (do-vars exp)
446 665c255d 2023-08-04 jrmu (do-test exp)
447 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
448 665c255d 2023-08-04 jrmu (sequence->exp
449 665c255d 2023-08-04 jrmu (append (do-commands exp)
450 665c255d 2023-08-04 jrmu (list (make-application
452 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
453 665c255d 2023-08-04 jrmu (make-application 'do-iter (do-inits exp)))))
456 665c255d 2023-08-04 jrmu ;; (define do-name
457 665c255d 2023-08-04 jrmu ;; (lambda (x y)
458 665c255d 2023-08-04 jrmu ;; (if (null? x)
459 665c255d 2023-08-04 jrmu ;; (begin y x (car y)) ;; if there are no expressions, then (null? x) would be returned
460 665c255d 2023-08-04 jrmu ;; (begin (display 'command)
461 665c255d 2023-08-04 jrmu ;; (display 'another)
462 665c255d 2023-08-04 jrmu ;; (do-name (cdr x) (cddr y))) ;; if the step is omitted, it is simply x y
463 665c255d 2023-08-04 jrmu ;; (do-name '(1 2 3 4)
464 665c255d 2023-08-04 jrmu ;; '(1 2 3 4 5 6 7 8))
475 665c255d 2023-08-04 jrmu '(let ((y 0))
477 665c255d 2023-08-04 jrmu ((= y 5) y)
478 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
482 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
483 665c255d 2023-08-04 jrmu ((null? y))
484 665c255d 2023-08-04 jrmu (set! y (cdr y)))
487 665c255d 2023-08-04 jrmu '(let ((y 0))
488 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
489 665c255d 2023-08-04 jrmu ((= x 5) y)
490 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
493 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
494 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
495 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
496 665c255d 2023-08-04 jrmu ((null? x) sum)))
499 665c255d 2023-08-04 jrmu '(let ((z '()))
500 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
501 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
502 665c255d 2023-08-04 jrmu ((null? x) y x z)
503 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
504 665c255d 2023-08-04 jrmu '(4 3 2 1))
508 665c255d 2023-08-04 jrmu ;; test-suite
510 665c255d 2023-08-04 jrmu ;; procedure definitions
513 665c255d 2023-08-04 jrmu '(define (assoc key records)
514 665c255d 2023-08-04 jrmu (cond ((null? records) false)
515 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
516 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
519 665c255d 2023-08-04 jrmu '(define (map proc list)
520 665c255d 2023-08-04 jrmu (if (null? list)
522 665c255d 2023-08-04 jrmu (cons (proc (car list))
523 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
526 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
527 665c255d 2023-08-04 jrmu (if (null? sequence)
529 665c255d 2023-08-04 jrmu (op (car sequence)
530 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
532 665c255d 2023-08-04 jrmu ;; all special forms
533 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
534 665c255d 2023-08-04 jrmu (test-eval '10 10)
535 665c255d 2023-08-04 jrmu (geval '(define x 3))
536 665c255d 2023-08-04 jrmu (test-eval 'x 3)
537 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
538 665c255d 2023-08-04 jrmu (test-eval 'x -25)
539 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
540 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
541 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
542 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
543 665c255d 2023-08-04 jrmu (else 'failed))
545 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
547 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
548 665c255d 2023-08-04 jrmu (+ x y (* x y)))
549 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
553 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
554 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
555 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
556 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
557 665c255d 2023-08-04 jrmu (test-eval 'x -2)
558 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
559 665c255d 2023-08-04 jrmu (test-eval 'x -2)
560 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
561 665c255d 2023-08-04 jrmu (test-eval 'x 25)
562 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
563 665c255d 2023-08-04 jrmu (test-eval 'x 2)
564 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
565 665c255d 2023-08-04 jrmu (test-eval 'x 25)
566 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
567 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
573 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
574 665c255d 2023-08-04 jrmu (else false))
578 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
579 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
580 665c255d 2023-08-04 jrmu ((map (lambda (x)
581 665c255d 2023-08-04 jrmu (* x (+ x 1)))
582 665c255d 2023-08-04 jrmu '(2 4 1 9))
584 665c255d 2023-08-04 jrmu (lambda (x)
585 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
586 665c255d 2023-08-04 jrmu (else 'never-reach))
588 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
591 665c255d 2023-08-04 jrmu ;; procedure definition and application
593 665c255d 2023-08-04 jrmu '(define (factorial n)
594 665c255d 2023-08-04 jrmu (if (= n 0)
596 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
597 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
602 665c255d 2023-08-04 jrmu '(map (lambda (x)
603 665c255d 2023-08-04 jrmu (* x (+ x 1)))
604 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
605 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
606 665c255d 2023-08-04 jrmu ;; accumulate
609 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
612 665c255d 2023-08-04 jrmu ;; make-let
614 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
621 665c255d 2023-08-04 jrmu '(let ((x 3))
625 665c255d 2023-08-04 jrmu '(let ((x 3)
630 665c255d 2023-08-04 jrmu '(let ((x 3)
632 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
636 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
638 665c255d 2023-08-04 jrmu '(let ((x 6)
639 665c255d 2023-08-04 jrmu (y (let ((x 2))
641 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
650 665c255d 2023-08-04 jrmu '(let* ((x 3)
651 665c255d 2023-08-04 jrmu (y (+ x 2))
652 665c255d 2023-08-04 jrmu (z (+ x y 5)))
661 665c255d 2023-08-04 jrmu '(let* ((x 3))
662 665c255d 2023-08-04 jrmu (let* ((y 5))
667 665c255d 2023-08-04 jrmu '(let* ((x 3)
668 665c255d 2023-08-04 jrmu (y (+ x 1)))
669 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
673 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
675 665c255d 2023-08-04 jrmu '(let* ((x 6)
676 665c255d 2023-08-04 jrmu (y (let* ((x 2)
677 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
680 665c255d 2023-08-04 jrmu (z (+ x y)))
684 665c255d 2023-08-04 jrmu ;; named-let
687 665c255d 2023-08-04 jrmu '(let eight ()
693 665c255d 2023-08-04 jrmu '(let loop ((count 0))
694 665c255d 2023-08-04 jrmu (if (= 100 count)
696 665c255d 2023-08-04 jrmu (loop (+ count 1))))
699 665c255d 2023-08-04 jrmu '(define (prime? x)
700 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
701 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
702 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
703 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
705 665c255d 2023-08-04 jrmu '(let primes ((x 2)
707 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
708 665c255d 2023-08-04 jrmu ((prime? x)
710 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
711 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
712 665c255d 2023-08-04 jrmu '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
715 665c255d 2023-08-04 jrmu '(define (fib n)
716 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
719 665c255d 2023-08-04 jrmu (if (= count 0)
721 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
722 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
