]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/eval-4.33.rkt
Solution to 4.44. A bit too verbose. Can be improved by better
[sicp.git] / src / sicp / eval-4.33.rkt
1 #lang racket
2
3 (require (rename-in racket/base
4                     [apply apply-in-underlying-scheme]
5                     [eval eval-in-underlying-scheme]
6                     [cons cons-in-underlying-scheme]
7                     [car  car-in-underlying-scheme]
8                     [cdr  cdr-in-underlying-scheme]))
9
10 (provide (all-defined-out))
11
12 (define (self-evaluating? expr)
13   (match expr
14     [(? number? expr) #t]
15     [(? char? expr) #t]
16     [(? string? expr) #t]
17     [_ #f]))
18
19 (define (variable? expr) (symbol? expr))
20
21 ;; sequence
22 (define (eval-sequence exps env)
23   (cond 
24     [(last-exp? exps) (eval (first-exp exps) env)]
25     [else (eval (first-exp exps) env)
26           (eval-sequence (rest-exps exps) env)]))
27
28 ;; begin
29 (define (last-exp? seq) (null? (cdr seq)))
30 (define (first-exp seq) (car seq))
31 (define (rest-exps seq) (cdr seq))
32
33 ;; lambda
34 (define (make-lambda parameters body)
35   (cons 'lambda (cons parameters body)))
36
37 ;; environment data structures
38 (define (enclosing-environment env) (cdr env))
39 (define (first-frame env) (car env))
40 (define the-empty-environment '())
41
42 (define (make-frame variables values)
43   (let ([ht (make-hash)])
44     (for-each (lambda (var val)
45                 (hash-set! ht var val))
46               variables
47               values)
48     ht))
49
50 (define (frame-variables frame)
51   (hash-keys frame))
52
53 (define (frame-values frame)
54   (hash-values frame))
55
56 (define (add-binding-to-frame! var val frame)
57   (hash-set! frame var val))
58
59 ;; environment is a list of frames, most recent being the last 
60 ;; one consed into the list
61 (define (extend-environment vars vals base-env)
62   (let ([frame (make-frame vars vals)])
63     (cons-in-underlying-scheme frame base-env)))
64
65 (define (lookup-variable-value var env)
66   (if (eq? env the-empty-environment)
67       (error "unbound variable: " var)
68       (let ([frame (first-frame env)])
69         (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))])
70           (if (eq? value '*unassigned*)
71               (error "evaluating a variable that is not assigned a value -- " var)
72               value)))))
73
74 (define (set-variable-value! var val env)
75   (if (eq? env the-empty-environment)
76       (error "unbound variable: " var)
77       (let ([frame (first-frame env)])
78         (if (hash-has-key? frame var)
79             (hash-set! frame var val)
80             (set-variable-value! var val (enclosing-environment env))))))
81
82 (define (define-variable! var val env)
83   (let ([frame (first-frame env)])
84     (if (hash-has-key? frame var)
85         (hash-set! frame var val)
86         (add-binding-to-frame! var val frame))))
87
88 ;; primitive procedure
89 (define (primitive-implementation proc) (cadr proc))
90
91 (define primitive-procedures
92   (list  (list 'cons cons-in-underlying-scheme)
93          (list 'car car-in-underlying-scheme)
94          (list 'cdr cdr-in-underlying-scheme)
95          (list 'null? null?)
96          (list 'list list)
97          (list '+ +)
98          (list '- -)
99          (list '* *)
100          (list '/ /)
101          (list '= =)
102          (list '> >)
103          (list '< <)
104          (list 'newline newline)
105          (list 'display display)))
106
107 (define (primitive-procedure-names)
108   (map car-in-underlying-scheme primitive-procedures))
109
110 (define (primitive-procedure-objects)
111   (map (lambda (proc) (list 'primitive (cadr proc)))
112        primitive-procedures))
113
114 (define (apply-primitive-procedure proc args)
115   (apply-in-underlying-scheme
116    (primitive-implementation proc) args))
117
118 ;; global env
119 (define (make-environment)
120   (let ((initial-env
121          (extend-environment (primitive-procedure-names)
122                              (primitive-procedure-objects)
123                              the-empty-environment)))
124     (define-variable! 'true true initial-env)
125     (define-variable! 'false false initial-env)
126     initial-env))
127
128 (define the-global-environment (make-environment))
129
130 ;; application
131 (define (list-of-values exps env)
132   (if (no-operands? exps)
133       '()
134       (cons (eval (first-operand exps) env)
135             (list-of-values (rest-operands exps) env))))
136
137 (define (no-operands? ops) (null? ops))
138 (define (first-operand ops) (car ops))
139 (define (rest-operands ops) (cdr ops))
140
141 ;; compound procedure
142 (define (make-procedure params body env)
143   (list 'procedure params (scan-out-definitions body) env))
144
145 (define (procedure-parameters p) (cadr p))
146 (define (procedure-body p) (scan-out-definitions (caddr p)))
147 (define (procedure-environment p) (cadddr p))
148
149 (define (apply procedure arguments env)
150   ;;(display (format "~s~%" arguments))
151   (match procedure
152     [`(primitive ,f ...)  (apply-primitive-procedure procedure (list-of-arg-values arguments env))]
153     [`(procedure ,f ...)  (eval-sequence
154                            (procedure-body procedure)
155                            (extend-environment
156                             (procedure-parameters procedure)
157                             (list-of-delayed-args arguments env)
158                             (procedure-environment procedure)))]
159     [_                (error "Unknown procedure type -- APPLY" procedure)]))
160
161 (define (list-of-arg-values exps env)
162   (if (no-operands? exps)
163       '()
164       (cons (actual-value (first-operand exps) env)
165             (list-of-arg-values (rest-operands exps) env))))
166
167 (define (list-of-delayed-args exps env)
168   (if (no-operands? exps)
169       '()
170       (cons (delay-it (first-operand exps) env)
171             (list-of-delayed-args (rest-operands exps) env))))
172
173 ;; truth
174 (define (true? x)
175   (not (eq? x false)))
176
177 (define (false? x)
178   (eq? x false))
179
180 ;; cond
181 (define (cond->if clauses)
182   (define (seq->exp actions) 
183     (if (empty? (cdr actions)) 
184         (car actions) 
185         `(begin ,@actions)))
186   (if (empty? clauses)
187       'false
188       (let ([clause (car clauses)])
189         (match clause
190           [`(else ,action ...) (seq->exp action)]
191           [`(,pred ,action ...) `(if ,pred 
192                                      ,(seq->exp action) 
193                                      ,(cond->if (cdr clauses)))]))))
194
195 ;; let
196 (define (let->combination lexpr)
197   (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
198                [`((,var ,val) ...) bindings])
199     `((lambda ,var ,@body) ,@val)))
200
201 ;; named let
202 (define (named-let->combination lexpr)
203   (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
204                [`((,var ,val) ...) bindings])
205     `(begin (define ,name (lambda ,var ,@body))
206             (,name ,@val))))
207
208 ;; let*
209 (define (let*->nested-lets lexpr)
210   (match lexpr
211     [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
212      `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
213      [`(let* () ,body ..1) `(let () ,@body)]))
214
215 ;; internal definitions
216 (define (scan-out-definitions body)
217   (match body
218     [`((define ,var ,e) ..1 ,rest)
219      `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
220         ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
221         ,rest))]
222     [_  body]))
223
224 ;; letrec
225 (define (letrec->combination lexpr)
226   (match lexpr
227     [`(letrec (,bindings ...) ,body ..1)
228      `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings)
229         ,@(map (lambda (binding) 
230                  (let ([name (car binding)]
231                        [value (cadr binding)])
232                    `(set! ,name ,value))) 
233                bindings)
234         ,@body)]))
235
236 ;; thunks
237 (define (actual-value exp env)
238   ;(display (format "eval expr ~s~%" exp))
239   ;(newline)
240   (force-it (eval exp env)))
241
242 (define (force-it obj)
243   ;; (display (format "~s~%" obj))
244   (match obj
245     [`(thunk ,exp ,env) (begin
246                           ;(display (format "eval's output ~s~%" obj))
247                           ;(newline)
248                           (actual-value exp env))]
249     [_ obj]))
250
251 (define (delay-it exp env)
252   (list 'thunk exp env))
253
254 (define (quote->cons exp)
255   ;(display (format "q->c: ~s~%" exp))
256   (match exp
257     [(? null?)  '()]
258     [_          `(cons (quote ,(car exp)) ,(quote->cons (cdr exp)))]))
259
260 ;; eval
261 (define (eval exp env)
262   ;; use this display statement to visualize the recursive evaluation process
263   ;(display (format "eval: ~s~%" exp))
264   (match exp
265     [(? self-evaluating? exp) exp]
266     [(? variable? exp) (lookup-variable-value exp env)]
267     [`(quote ,x) (if (pair? x) (eval (quote->cons x) env) x)]
268     [`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
269     [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
270     [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
271     [`(if ,pred ,consequent ,alternative) (if (true? (actual-value pred env)) (eval consequent env) (eval alternative env))]
272     [`(unless ,condition ,consequent ,alternative) (if (true? (eval condition env)) (eval alternative env) (eval consequent env))]
273     [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
274     [`(begin ,exp ...) (eval-sequence exp env)]
275     [`(cond ,clauses ...) (eval (cond->if clauses) env)]
276     [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (eval (let->combination exp) env)]
277     [`(let ,(? symbol? name) ,bindings ,body ..1) (eval (named-let->combination exp) env)]
278     [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)]
279     [`(letrec ,bindings ,body ..1) (eval (letrec->combination exp) env)]
280     [`(,f ,x ...) (apply (actual-value f env) 
281                          x
282                          env)]
283     [_ (error "unable to evaluate expression -- EVAL " exp)]))
284
285
286 (define (interpret)
287   (let loop ([input (read)]
288              [env the-global-environment])
289     (let ([output (actual-value input env)])
290       (display output)
291       (loop (read) env))))
292
293 (define (t expr)
294   (let ([t1 (current-inexact-milliseconds)])
295     (eval expr the-global-environment)
296     (displayln (- (current-inexact-milliseconds) t1))))
297