/
desugar.rkt
364 lines (314 loc) · 12.4 KB
/
desugar.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
#lang racket
;This is a very simple desugarer for a simple scheme like language based on the article at http://matt.might.net/articles/desugaring-scheme/ over time we will grow this into a consideral subset of the racket language which we will grow out of this file by adding and changing functionality
; TODO remove language dependances from racket
; Entry Point
;; add begin to top level
(define dll #f)
(define (desugar-input)
;; (define program (read-input))
(define out (void))
(define program (read-input (open-input-file (command-line
#:args (filename output)
(begin
(set! out (open-output-file output #:exists 'replace))
filename)) #:mode 'text)))
;; check for #lang dll
(set! program (splice-begin-forms program))
(if (is-dll? program)
(begin
(set! dll #t)
(set! program (remove-dll-keyword program))
(set! program (desugar-dll program)))
(set! program (desugar-tops program))) ;; desugar-tops
(set! program (map desugar-define program)) ;; desugar the defines now
(set! program (partition-k
atomic-define?
program
(lambda (atomic complex)
(define bindings
(for/list ([c complex])
(match c
[`(define ,v ,complex)
`(,v (void))]
[else (displayln "cannot desugar begin")])))
(define sets
(for/list ([c complex])
(match c
[`(define ,v ,complex)
`(set! ,v ,complex)]
[else (displayln "cannot desguar begin")])))
(append atomic (list (desugar-exp `(let ,bindings ,@sets)))))))
(write-output program out))
(define (write-output program [file (current-output-port)])
(cond
[(empty? program)
'()]
[else
(write (car program) file)
(newline file)
(write-output (cdr program) file)]))
(define (is-dll? program)
(match program
[`(#:lang dll . ,body) #t]
[else #f]))
(define (remove-dll-keyword program)
(match program
[`(#:lang dll . ,body) body]
[else (error "No dll keyword")]))
; reads all input from std in into a list
(define (read-input [file (current-input-port)])
(define line (read file))
(if (eof-object? line)
'()
(cons line (read-input file))))
; desugar top level begins, hope this is correct
(define (splice-begin-forms tops)
(match tops
[`(,stuff ... (begin ,forms ...) ,rest ...)
`(,@stuff ,@forms ,@rest)]
[else tops]))
; Desugaring Functions
(define (desugar-dll tops)
(define (top-to-def-dll top)
(match top
[`(define (,name ,params ...) . ,body)
(function-def->var-def top)]
[`(define ,var ,exp)
`(define ,var ,exp)]
[`(using ,str)
`(using ,str)]
[else (error "only using and define forms allowed in dll")]))
(map top-to-def-dll tops))
(define (desugar-tops tops)
(define (top-to-def top)
(match top
[`(define (,name ,params ...) . ,body)
(function-def->var-def top)]
[`(define ,var ,exp)
`(define ,var ,exp)]
;; [`(begin ,forms ...) `(begin ,@forms)]
[exp `(define ,(gensym '_) ,exp)]))
(map top-to-def tops))
; desugar define statements of the form (define ,v ,exp)
(define (desugar-define def)
(match def
[`(define ,v ,exp) `(define ,v ,(desugar-exp exp))]
[`(begin ,form) (desugar-exp form)]
[`(using ,str) `(using ,str)]
[else (displayln `(cannot desugar define ,def))]))
(define (desugar-exp exp)
(match exp
[(? symbol?) exp]
[`(quote ,s-exp) (desugar-quote s-exp)]
[`(let ((,vs ,es) ...) . ,body)
`((lambda ,vs ,(desugar-body body)) ,@(map desugar-exp es))]
[`(letrec ((,vs ,es) ...) . ,body)
(desugar-exp `(let ,(for/list ([v vs])
(list v '(void)))
,@(map (λ (v e)
`(set! ,v ,e))
vs es)
,@body))]
[`(lambda ,params . ,body) `(lambda ,params ,(desugar-body body))]
[`(when ,cond . ,body) `(if ,(desugar-exp cond)
(begin ,@(map desugar-exp body))
(void))]
[`(unless ,cond . ,body) `(if ,(desugar-exp cond)
(void)
(begin ,@(map desugar-exp body)))]
[`(cond) '(void)]
[`(cond (else ,exp)) (desugar-exp exp)]
[`(cond (,test ,exp))
`(if ,(desugar-exp test) ,(desugar-exp exp) (void))]
[`(cond (,test ,exp) ,rest ...)
`(if ,(desugar-exp test) ,(desugar-exp exp) ,(desugar-exp `(cond . ,rest)))]
[`(and) #t]
[`(or) #f]
[`(and ,exp) (desugar-exp exp)]
[`(or ,exp) (desugar-exp exp)]
[`(and ,exp . ,rest)
`(if ,(desugar-exp exp)
,(desugar-exp `(and . ,rest)) #f)]
[`(or ,exp . ,rest)
(define $t (gensym 't))
(desugar-exp `(let ((,$t ,exp))
(if ,$t ,$t (or . ,rest))))]
[`(if ,test ,exp)
`(if ,(desugar-exp test) ,(desugar-exp exp) (void))]
[`(if ,test ,exp1 ,exp2)
`(if ,(desugar-exp test) ,(desugar-exp exp1) ,(desugar-exp exp2))]
[`(set! ,v ,exp) `(set! ,v ,(desugar-exp exp))]
[`(quasiquote ,qq-exp) (desugar-quasi-quote 1 qq-exp)]
[`(begin . ,body) (desugar-body body)]
[`(first ,exp) `(car ,exp)]
[`(rest ,exp) `(cdr ,exp)]
[`(+ ,farg ,sarg . ,rest) (if (null? rest) ;; added today, need to test
`(+ ,farg ,sarg)
`(+ ,farg ,(desugar-exp `(+ ,sarg ,@rest))))]
[`(* ,farg ,sarg . ,rest) (if (null? rest) ;; added today , need to test
`(* ,farg ,sarg)
`(* ,farg ,(desugar-exp `(* ,sarg ,@rest))))]
[`(/ ,farg ,sarg . ,rest) ;;(if (null? rest) ;; added today , need to test
;; `(/ ,farg ,sarg)
(foldl (lambda (v a) `(/ ,a
,(desugar-exp v)))
`(/ ,(desugar-exp farg)
,(desugar-exp sarg))
rest)]
[`(- ,farg ,sarg . ,rest) ;;(if (null? rest) ;; added today, need to test
;; `(- ,farg ,sarg)
(foldl (lambda (v a) `(- ,a
,(desugar-exp v)))
`(- ,(desugar-exp farg)
,(desugar-exp sarg))
rest)]
[`(list . ,rest) (foldr (lambda (x a) `(cons ,(desugar-exp x) ,a))
`(quote()) rest)] ;; needs testing a is accumulator
[`(reverse ,list)`(reverse ,(desugar-exp list))]
[`(map ,fun . ,lists) `(map ,(desugar-exp fun) ,@(map desugar-exp lists))]
[`(foldl ,fun ,init . ,lists) `(foldl ,(desugar-exp fun)
,(desugar-exp init)
,@(map desugar-exp lists))]
[`(foldr ,fun ,init ,lists ...) `(foldl ,(desugar-exp fun)
,(desugar-exp init)
,@(map (lambda (l) `(reverse ,(desugar-exp l))) lists))] ;; need to test
[`(apply ,fun ,opts ... ,list) `(apply ,(desugar-exp fun)
,(desugar-exp (foldl cons list opts)))]
[`(filter ,fun ,list) `(filter ,(desugar-exp fun) ,(desugar-exp list))]
[(? atomic?) exp]
[`(,function . ,args)
`(,(desugar-exp function) ,@(map desugar-exp args))]
[else (displayln `(could not desugar expression ,@exp))]))
;; --------- desugar helpers -------------
(define (convert-nested-cons->list conses)
(match conses
[`(cons ,v . ,rest) `(,v ,convert-nested-cons->list rest)]
[`(quote ,e) '()]
[else (error "error")]))
;; desugar body of a lambda or begin
(define (desugar-body body)
(match body
[`(,exp)
(desugar-exp exp)]
[`(,(and (? not-define?) exps) ...)
`(begin ,@(map desugar-exp exps))]
[`(,tops ... ,exp)
(define defs (desugar-tops tops))
(desugar-exp (match defs
[`((define ,vs ,es) ...)
`(letrec ,(map list vs es) ,exp)]))]))
(define (desugar-quote s-exp)
(cond
[(pair? s-exp) `(cons ,(desugar-quote (car s-exp))
,(desugar-quote (cdr s-exp)))]
[(null? s-exp) ''()]
[(number? s-exp) s-exp]
[(string? s-exp) s-exp]
[(boolean? s-exp) s-exp]
[(symbol? s-exp) `(quote, s-exp)]
[else
(error (format "strange value in quote: ~s~n" s-exp))]))
(define (desugar-quasi-quote n s-exp)
(match s-exp
[(list 'unquote exp)
(if (= n 1)
(desugar-exp exp)
(list 'list ''unquote
(desugar-quasi-quote (- n 1) exp)))]
[`(quasiquote ,s-exp)
`(list 'quasiquote ,(desugar-quasi-quote (+ n 1) s-exp))]
[(cons (list 'unquote-splicing exp) rest)
(if (= n 1)
`(append ,exp ,(desugar-quasi-quote n rest))
(cons (list 'unquote-splicing (desugar-quasi-quote (- n 1) exp))
(desugar-quasi-quote n rest)))]
[`(,qq-exp1 . ,rest)
`(cons ,(desugar-quasi-quote n qq-exp1)
,(desugar-quasi-quote n rest))]
[else
(desugar-quote s-exp)]))
(define (desugar-let exp) ;; `(let ((,vs ,es) ...) . ,body)
(define vars (cadr exp))
(define body (cddr exp))
(define var-getter
(lambda (x)
(if (null? x)
'()
(cons (caar x) (var-getter (cdr x))))))
(define exp-getter
(lambda (x)
(if (null? x)
'()
(cons (cadar x) (exp-getter (cdr x))))))
(define var-names (var-getter vars))
(define exps (exp-getter vars))
`((lambda ,var-names ,(desugar-body body))
,@(map desugar-exp exps)))
;; i love me some functional programming grahamammm
(define (desugar-letrec exp) ;; `(letrec ((,vs ,es) ..) . ,body)
(define vars (car (cdr exp)))
(define body (cdr (cdr exp)))
(define get-var
(lambda (v)
(if (null? v)
'()
(car v))))
(define get-exp
(lambda (e)
(if (null? e)
'()
(cdr e))))
(desugar-exp
`(let ,(map (lambda (v) (list (get-var v) '(void))) vars)
,@(map (lambda (v) `(set! ,(get-var v) ,@(get-exp v))) vars)
,@body)))
;; ------ desugaring lambda ------
(define (desugar-lambda exp) ;; `(lambda ,params . ,body)
(match exp
[`(lambda ,params . ,body)
`(lambda ,params ,(desugar-body body))]))
; ----- helper functions -----
(define (function-def->var-def def)
(match def
[`(define (,name ,params ...) . ,body)
`(define ,name (lambda ,params ,@body))]
[else (error "shouldn't happen")]))
(define (not-define? symbol)
(not (define? symbol)))
(define (define? symbol)
(match symbol
[`(define . ,_) #t]
[else #f]))
; aotmic-define? : term -> boolean
(define (atomic-define? def)
(match def
[`(define ,v ,exp) (atomic? exp)]
[`(begin-top . ,forms) #t] ;; for now just do this
[`(using ,str) #t]
[else #f]))
; matches `(define (,f ,params ...) . ,body)
(define (function-def? top)
(and (eq? 'define (car top)) (list? (cadr top))))
; matches `(define ,v ,exp)
(define (var-def? exp)
(and (eq? 'define (car exp)) (not (list? (cadr exp)))))
; matches any atomic
(define (atomic? exp)
(match exp
[`(lambda . ,_)#t]
[(? number?) #t]
[(? string?) #t]
[(? boolean?) #t]
[`(quote . ,_) #t]
['(void) #t]
[`() #t]
[else #f]))
(define (partition-k pred list k)
(if (not (pair? list)) ;; check if empty
(k '() '())
(partition-k pred (cdr list)
(lambda (in out)
(if (pred (car list))
(k (cons (car list) in) out)
(k in (cons (car list) out)))))))
(desugar-input)