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