]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/metacircular.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / metacircular.rkt
1 #lang planet neil/sicp
2
3 (#%require "ex4_8.rkt" ;; for let and named let
4          "ex4_7.rkt")
5
6 ;; metacircular evaluator
7 (define (eval exp env)
8   (cond ((self-evaluating? exp) exp)
9         ((variable? exp) (lookup-variable-value exp env))
10         ((quoted? exp) (text-of-quotation exp))
11         ((assignment? exp) (eval-assignment exp env))
12         ((definition? exp) (eval-definition exp env))
13         ((if? exp) (eval-if exp env))
14         ((lambda? exp)
15          (make-procedure (lambda-parameters exp)
16                          (lambda-body exp)
17                          env))
18         ((begin? exp) (eval-sequence (begin-actions exp) env))
19         ((cond? exp) (eval (cond->if exp) env))
20         ((let? exp) (eval (let->combination exp) env))  ;; from ex4.8
21         ((let*? exp) (eval (let*->nested-lets exp) env)) ;; from ex4_7
22         ((application? exp)
23          (apply (eval (operator exp) env)
24                 (list-of-values (operands exp) env)))
25         (else
26          (error "unknown expression type -- EVAL" exp))))
27
28 ;; capture the underlying apply before redefining it
29 (define apply-in-underlying-scheme apply)
30
31 (define (apply procedure arguments)
32   (cond ((primitive-procedure? procedure)
33          (apply-primitive-procedure procedure arguments))
34         ((compound-procedure? procedure)
35          (eval-sequence
36           (procedure-body procedure)
37           (extend-environment
38            (procedure-parameters procedure)
39            arguments
40            (procedure-environment procedure))))
41         (else
42          (error "unknown procedure type -- APPLY" procedure))))
43
44 (define (list-of-values exps env)
45   (if (no-operands? exps)
46       '()
47       (cons (eval (first-operand exps) env)
48             (list-of-values (rest-operands exps) env))))
49
50 (define (eval-if exp env)
51   (if (true? (eval (if-predicate exp) env))
52       (eval (if-consequent exp) env)
53       (eval (if-alternative exp) env)))
54
55 (define (eval-sequence exps env)
56   (cond ((last-exp? exps) 
57          (eval (first-exp exps) env))
58         (else
59          (eval (first-exp exps) env)
60          (eval-sequence (rest-exps exps) env))))
61
62 (define (eval-assignment exp env)
63   (set-variable-value! (assignment-variable exp)
64                        (eval (assignment-value exp) env)
65                        env)
66   'ok)
67
68 (define (eval-definition exp env)
69   (define-variable! (definition-variable exp)
70                     (eval (definition-value exp) env)
71                     env)
72   'ok)
73
74 ;; =====
75 (define (self-evaluating? expr)
76   (cond [(number? expr) #t]
77         [(string? expr) #t]
78         [else #f]))
79
80 (define (variable? expr)
81   (symbol? expr))
82
83 ;; quotation
84 (define (quoted? expr)
85   (tagged-list? expr 'quote))
86
87 (define (tagged-list? expr tag)
88   (or (pair? expr) (eq? (car expr) tag)))
89
90 (define (text-of-quotation expr)
91   (car (cdr expr)))
92
93 ;; assignment
94 (define (assignment? expr)
95   (tagged-list? expr 'set!))
96
97 (define (assignment-variable expr)
98   (car (cdr expr)))
99
100 (define (assignment-value expr)
101   (car (cdr (cdr expr))))
102
103 ;; define
104 (define (definition? expr)
105   (tagged-list? expr 'define))
106
107 (define (definition-variable expr)
108   (if (symbol? (car (cdr expr))) ;; (define foo 42)
109       (car (cdr expr))
110       ;; (define (foo x) (....))
111       (car (car (cdr expr)))))
112
113 (define (definition-value expr)
114   ;; (define foo 42)
115   (if (symbol? (car (cdr expr)))
116       (car (cdr (cdr expr)))
117       ;; (define (foo x) (....))
118       (make-lambda (cdr (car (cdr expr))) ;; gives (x)
119                    (cdr (cdr expr)))))    ;; body
120
121 ;; lambda
122 (define (lambda? expr)
123   (tagged-list? expr 'lambda))
124
125 (define (lambda-parameters expr)
126   (car (cdr expr)))
127
128 ;;(lambda (x) (..)(..)...(..))
129 (define (lambda-body expr)
130   (cdr (cdr expr)))
131
132 (define (make-lambda params body)
133   (cons 'lambda (cons params body)))
134
135 ;; if
136 (define (if? exp) (tagged-list? exp 'if))
137 (define (if-predicate expr) (car (cdr expr)))
138 (define (if-consequent expr) (car (cdr (cdr expr))))
139 (define (if-alternative expr) 
140   (if (not (null? (cdr (cdr (cdr expr)))))
141       (car (cdr (cdr (cdr expr))))
142       'false))
143
144 (define (make-if predicate consequent alternative)
145   (list 'if predicate consequent alternative))
146
147 ;; begin
148 (define (begin? exp) (tagged-list? exp 'begin))
149 (define (begin-actions exp) (cdr exp))
150 (define (last-exp? seq) (null? (cdr seq)))
151 (define (first-exp seq) (car seq))
152 (define (rest-exps seq) (cdr seq))
153
154 (define (sequence->exp seq)
155   (cond ((null? seq) seq)
156         ((last-exp? seq) (first-exp seq))
157         (else (make-begin seq))))
158 (define (make-begin seq) (cons 'begin seq))
159
160 ;; procedure application
161 (define (application? exp) (pair? exp))
162 (define (operator exp) (car exp))
163 (define (operands exp) (cdr exp))
164 (define (no-operands? ops) (null? ops))
165 (define (first-operand ops) (car ops))
166 (define (rest-operands ops) (cdr ops))
167
168 ;; expander for `cond' expressions to be transformed into `if' expressions
169 (define (cond? exp) (tagged-list? exp 'cond))
170 (define (cond-clauses exp) (cdr exp))
171 (define (cond-else-clause? clause)
172   (eq? (cond-predicate clause) 'else))
173 (define (cond-predicate clause) (car clause))
174 (define (cond-actions clause) (cdr clause))
175 (define (cond->if exp)
176   (expand-clauses (cond-clauses exp)))
177
178 (define (expand-clauses clauses)
179   (if (null? clauses)
180       'false                          ; no else clause
181       (let ((first (car clauses))
182             (rest (cdr clauses)))
183         (if (cond-else-clause? first)
184             (if (null? rest)
185                 (sequence->exp (cond-actions first))
186                 (error "ELSE clause isn't last -- COND->IF"
187                        clauses))
188             (make-if (cond-predicate first)
189                      (sequence->exp (cond-actions first))
190                      (expand-clauses rest))))))
191
192 ;; true and false
193 (define (true? x)
194   (not (eq? x false)))
195
196 (define (false? x)
197   (eq? x false))
198
199 ;; procedures
200 (define (make-procedure parameters body env)
201   (list 'procedure parameters body env))
202
203 (define (compound-procedure? p)
204   (tagged-list? p 'procedure))
205
206 (define (procedure-parameters p) (cadr p))
207 (define (procedure-body p) (caddr p))
208 (define (procedure-environment p) (cadddr p))
209
210 ;; operations on environment
211 (define (enclosing-environment env) (cdr env))
212 (define (first-frame env) (car env))
213 (define the-empty-environment '())
214
215 ;; frame operations
216 (define (make-frame variables values)
217   (cons variables values))
218
219 (define (frame-variables frame) (car frame))
220 (define (frame-values frame) (cdr frame))
221 (define (add-bindings-to-frame! var val frame)
222   (set-car! frame (cons var (frame-variables frame)))
223   (set-cdr! frame (cons val (frame-values frame))))
224
225 (define (extend-environment vars vals base-env)
226   (if (= (length vars) (length vals))
227       (cons (make-frame vars vals) base-env)
228       (if (< (length vars) (length vals))
229           (error "Too many args supplied" vars vals)
230           (error "Too many args supplied" vars vals))))
231
232 (define (lookup-variable-value var env)
233   (define (env-loop env)
234     (define (scan vars vals)
235       (cond [(null? vars)
236              (env-loop (enclosing-environment env))]
237             [(eq? var (car vars))
238              (car vals)]
239             [else (scan (cdr vars) (cdr vals))]))
240     (if (eq? env the-empty-environment)
241         (error "unbound variable" var)
242         (let ([frame (first-frame env)])
243           (scan (frame-variables frame)
244                 (frame-values frame)))))
245   (env-loop env))
246
247 (define (set-variable-value! var val env)
248   (define (env-loop env)
249     (define (scan vars vals)
250       (cond [(null? vars)
251              (env-loop (enclosing-environment env))]
252             [(eq? var (car vars))
253              (set-car! vals val)]
254             [else (scan (cdr vars) (cdr vals))]))
255     (if (eq? env the-empty-environment)
256         (error "unbound variable" var)
257         (let ([frame (first-frame env)])
258           (scan (frame-variables frame)
259                 (frame-values frame)))))
260   (env-loop env))
261
262 (define (define-variable! var val env)
263   (let ([frame (first-frame env)])
264     (define (scan vars vals)
265       (cond [(null? vars)
266              (add-bindings-to-frame! var val frame)]
267             [(eq? var (car vars))
268              (set-car! vals val)]
269             [else (scan (cdr vars) (cdr vals))]))
270     (scan (frame-variables frame)
271           (frame-values frame))))
272
273
274 ;; primitive procedures
275 (define (primitive-procedure? proc)
276   (tagged-list? proc 'primitive))
277
278 (define (primitive-implementation proc) (cadr proc))
279
280 (define primitive-procedures
281   (list (list 'car car)
282         (list 'cdr cdr)
283         (list 'cons cons)
284         (list 'null? null?)
285         (list '+ +)
286         (list '- -)
287         (list '= =)))
288
289 (define (primitive-procedure-names)
290   (map car primitive-procedures))
291
292 (define (primitive-procedure-objects)
293   (map (lambda (proc) (list 'primitive (cadr proc)))
294        primitive-procedures))
295
296 ;; apply from implementation language
297 (define (apply-primitive-procedure proc args)
298   (apply-in-underlying-scheme
299    (primitive-implementation proc) args))
300
301 ;; setting up the environment
302 (define (setup-environment)
303   (let ((initial-env
304          (extend-environment (primitive-procedure-names)
305                              (primitive-procedure-objects)
306                              the-empty-environment)))
307     (define-variable! 'true #t initial-env)
308     (define-variable! 'false #f initial-env)
309     initial-env))
310
311 (define the-global-environment (setup-environment))
312
313