« back to all changes in this revision
Viewing changes to intro-to-racket/compile.rkt
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Rodolfo Carvalho
- Date: 2011-05-17 02:42:05 UTC
- Revision ID: rhcarvalho@gmail.com-20110517024205-7p155j135ytm77h3
Intro do Racket as taken from the web
added
removed
intro-to-racket/compile.rkt
1
#lang racket
2
3
;; Author: Matthew Might
4
;; Site: http://matt.might.net/
5
;; http://blog.might.net/
6
7
;; Description:
8
9
;; A compiler from a small, functional
10
;; language into the pure lambda calculus.
11
12
(require test-engine/racket-tests)
13
14
;; The language:
15
16
;; <exp> ::= <var>
17
18
;; | #t
19
;; | #f
20
;; | (if <exp> <exp> <exp>)
21
;; | (and <exp> <exp>)
22
;; | (or <exp> <exp>)
23
24
;; | <nat>
25
;; | (zero? <exp>)
26
;; | (- <exp> <exp>)
27
;; | (= <exp> <exp>)
28
;; | (+ <exp> <exp>)
29
;; | (* <exp> <exp>)
30
31
;; | <lam>
32
;; | (let ((<var> <exp>) ...) <exp>)
33
;; | (letrec ((<var> <lam>)) <exp>)
34
35
;; | (cons <exp> <exp>)
36
;; | (car <exp>)
37
;; | (cdr <exp>)
38
;; | (pair? <exp>)
39
;; | (null? <exp>)
40
;; | '()
41
42
;; | (<exp> <exp> ...)
43
44
;; <lam> ::= (λ (<var> ...) <exp>)
45
46
47
; Void.
48
(define VOID `(λ (void) void))
49
50
; Error.
51
(define ERROR '(λ (_)
52
((λ (f) (f f)) (λ (f) (f f)))))
53
54
; Booleans.
55
(define TRUE `(λ (t) (λ (f) (t ,VOID))))
56
(define FALSE `(λ (t) (λ (f) (f ,VOID))))
57
58
; Church numerals.
59
(define (church-numeral n)
60
61
(define (apply-n f n z)
62
(cond
63
[(= n 0) z]
64
[else `(,f ,(apply-n f (- n 1) z))]))
65
66
(cond
67
[(= n 0) `(λ (f) (λ (z) z))]
68
[else `(λ (f) (λ (z)
69
,(apply-n 'f n 'z)))]))
70
71
(define ZERO? `(λ (n)
72
((n (λ (_) ,FALSE)) ,TRUE)))
73
74
(define SUM '(λ (n)
75
(λ (m)
76
(λ (f)
77
(λ (z)
78
((m f) ((n f) z)))))))
79
80
(define MUL '(λ (n)
81
(λ (m)
82
(λ (f)
83
(λ (z)
84
((m (n f)) z))))))
85
86
(define PRED '(λ (n)
87
(λ (f)
88
(λ (z)
89
(((n (λ (g) (λ (h)
90
(h (g f)))))
91
(λ (u) z))
92
(λ (u) u))))))
93
94
(define SUB `(λ (n)
95
(λ (m)
96
((m ,PRED) n))))
97
98
99
; Lists.
100
(define CONS `(λ (car)
101
(λ (cdr)
102
(λ (on-cons)
103
(λ (on-nil)
104
((on-cons car) cdr))))))
105
106
(define NIL `(λ (on-cons)
107
(λ (on-nil)
108
(on-nil ,VOID))))
109
110
(define CAR `(λ (list)
111
((list (λ (car)
112
(λ (cdr)
113
car)))
114
,ERROR)))
115
116
(define CDR `(λ (list)
117
((list (λ (car)
118
(λ (cdr)
119
cdr)))
120
,ERROR)))
121
122
(define PAIR? `(λ (list)
123
((list (λ (_) (λ (_) ,TRUE)))
124
(λ (_) ,FALSE))))
125
126
(define NULL? `(λ (list)
127
((list (λ (_) (λ (_) ,FALSE)))
128
(λ (_) ,TRUE))))
129
130
131
; Recursion.
132
(define Y '((λ (y) (λ (F) (F (λ (x) (((y y) F) x)))))
133
(λ (y) (λ (F) (F (λ (x) (((y y) F) x)))))))
134
135
136
; Compilation:
137
(define (compile exp)
138
(match exp
139
140
; Symbols stay the same:
141
[(? symbol?) exp]
142
143
; Boolean and conditionals:
144
[#t TRUE]
145
[#f FALSE]
146
[`(if ,cond ,t ,f)
147
; =>
148
(compile `(,cond (λ () ,t) (λ () ,f)))]
149
150
[`(and ,a ,b)
151
; =>
152
(compile `(if ,a ,b #f))]
153
154
[`(or ,a ,b)
155
; =>
156
(compile `(if ,a #t ,b))]
157
158
; Numerals:
159
[(? integer?) (church-numeral exp)]
160
[`(zero? ,exp) `(,ZERO? ,(compile exp))]
161
[`(- ,x ,y) `((,SUB ,(compile x)) ,(compile y))]
162
[`(+ ,x ,y) `((,SUM ,(compile x)) ,(compile y))]
163
[`(* ,x ,y) `((,MUL ,(compile x)) ,(compile y))]
164
[`(= ,x ,y) (compile `(and (zero? (- ,x ,y))
165
(zero? (- ,y ,x))))]
166
167
; Lists:
168
[ (quote '()) NIL]
169
[`(cons ,car ,cdr) `((,CONS ,(compile car))
170
,(compile cdr))]
171
[`(car ,list) `(,CAR ,(compile list))]
172
[`(cdr ,list) `(,CDR ,(compile list))]
173
[`(pair? ,list) `(,PAIR? ,(compile list))]
174
[`(null? ,list) `(,NULL? ,(compile list))]
175
176
; Lambdas:
177
[`(λ () ,exp)
178
; =>
179
`(λ (_) ,(compile exp))]
180
181
[`(λ (,v) ,exp)
182
; =>
183
`(λ (,v) ,(compile exp))]
184
185
[`(λ (,v ,vs ...) ,exp)
186
; =>
187
`(λ (,v)
188
,(compile `(λ (,@vs) ,exp)))]
189
190
; Binding forms:
191
[`(let ((,v ,exp) ...) ,body)
192
; =>
193
(compile `((λ (,@v) ,body) ,@exp))]
194
195
[`(letrec [(,f ,lam)] ,body)
196
; =>
197
(compile `(let ((,f (,Y (λ (,f) ,lam))))
198
,body))]
199
200
; Application -- must be last:
201
[`(,f)
202
; =>
203
(compile `(,(compile f) ,VOID))]
204
205
[`(,f ,exp)
206
; =>
207
`(,(compile f) ,(compile exp))]
208
209
[`(,f ,exp ,rest ...)
210
; =>
211
(compile `((,f ,exp) ,@rest))]
212
213
[else
214
; =>
215
(display (format "unknown exp: ~s~n" exp))
216
(error "unknown expression")]))
217
218
219
; Unchurchification.
220
(define (succ n) (+ n 1))
221
222
(define (natify church-numeral)
223
((church-numeral succ) 0))
224
225
(define (boolify church-boolean)
226
((church-boolean (λ (_) #t)) (λ (_) #f)))
227
228
(define (listify f church-list)
229
((church-list
230
(λ (car) (λ (cdr) (cons (f car) (listify f cdr)))))
231
(λ (_) '())))
232
233
234
; Tests.
235
(define ns (make-base-namespace))
236
237
(define (ec prog)
238
(eval (compile prog) ns))
239
240
(check-expect (natify (eval `(,PRED ,(compile 0)) ns))
241
0)
242
243
(check-expect (natify (eval `(,PRED ,(compile 9)) ns))
244
8)
245
246
(check-expect (natify (eval `((,SUM ,(compile 5))
247
,(compile 6)) ns))
248
11)
249
250
(check-expect (natify (ec `(* 3 10)))
251
30)
252
253
(check-expect (natify (ec `(- 3 1)))
254
2)
255
256
(check-expect (natify (ec `(let ((v 3) (x 10)) v)))
257
3)
258
259
(check-expect (boolify (ec `(= 3 3)))
260
#t)
261
262
(check-expect (listify natify (ec `(cons 4 (cons 3 '()))))
263
'(4 3))
264
265
(check-expect (natify (ec `(car (cons 3 4))))
266
3)
267
268
(check-expect (boolify (ec `(null? (cons 3 4))))
269
#f)
270
271
(check-expect (boolify (ec `(pair? (cons 3 4))))
272
#t)
273
274
(define R1 (compile `(letrec [(f (λ (n)
275
(if (= n 0)
276
1
277
(* n (f (- n 1))))))]
278
(f 5))))
279
280
(check-expect (natify (eval R1 ns))
281
120)
282
283
(test)
Loggerhead is a web-based interface for Breezy
Version: 2.0.1