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