d634d1bd9c23fee65428aacde9d69da93c9a1bca
[software/python-on-guile.git] / modules / language / python / compile.scm
1 (define-module (language python compile)
2 #:use-module (ice-9 match)
3 #:use-module (ice-9 pretty-print)
4 #:export (comp))
5
6 (define (p x) (pretty-print (syntax->datum x)) x)
7 (define (pf x)
8 (define port (open-file "compile.log" "a"))
9 (with-output-to-port port
10 (lambda () (pretty-print (syntax->datum x)) x))
11 (close port)
12 x)
13
14 (define (C x) `(@@ (language python compile) ,x))
15 (define (G x) `(@ (guile) ,x))
16
17 (define (union as vs)
18 (let lp ((as as) (vs vs))
19 (match as
20 ((x . as)
21 (if (member x vs)
22 (lp as vs)
23 (lp as (cons x vs))))
24 (()
25 vs))))
26
27 (define (diff as vs)
28 (let lp ((as as) (rs '()))
29 (match as
30 ((x . as)
31 (if (member x vs)
32 (lp as rs)
33 (lp as (cons x rs))))
34 (()
35 rs))))
36
37 (define (get-globals code)
38 (let lp ((vs (glob code '())) (rs (scope code '())))
39 (match vs
40 ((x . l)
41 (if (member x rs)
42 (lp l rs)
43 (lp l (cons x rs))))
44 (()
45 rs))))
46
47 (define (glob x vs)
48 (match x
49 ((#:global . l)
50 (let lp ((l l) (vs vs))
51 (match l
52 (((#:identifier v) . l)
53 (let ((s (string->symbol v)))
54 (if (member s vs)
55 (lp l vs)
56 (lp l (cons s vs)))))
57 (()
58 vs))))
59 ((x . y)
60 (glob y (glob x vs)))
61 (x vs)))
62
63 (define (scope x vs)
64 (match x
65 ((#:def (#:identifier f) . _)
66 (union (list (string->symbol f)) vs))
67 ((#:lambdef . _)
68 vs)
69 ((#:class . _)
70 vs)
71 ((#:global . _)
72 vs)
73 ((#:identifier v)
74 (let ((s (string->symbol v)))
75 (if (member s vs)
76 vs
77 (cons s vs))))
78 ((x . y)
79 (scope y (scope x vs)))
80 (_ vs)))
81
82 (define (defs x vs)
83 (match x
84 ((#:def (#:identifier f) . _)
85 (union (list (string->symbol f)) vs))
86 ((#:lambdef . _)
87 vs)
88 ((#:class . _)
89 vs)
90 ((#:global . _)
91 vs)
92 ((x . y)
93 (defs y (defs x vs)))
94 (_ vs)))
95
96 (define (g vs e)
97 (lambda (x) (e vs x)))
98
99 (define return (make-fluid 'error-return))
100
101 (define (exp vs x)
102 (match (p x)
103 ((#:power (#:identifier x) () . #f)
104 (string->symbol x))
105
106 ((#:power x () . #f)
107 x)
108
109 (((and x (or #:+ #:- #:* #:/)) . l)
110 (cons (keyword->symbol x) (map (g vs exp) l)))
111
112 ((#:u~ x)
113 (list 'lognot (exp vs x)))
114
115 ((#:band . l)
116 (cons 'logand (map (g vs exp) l)))
117
118 ((#:bxor . l)
119 (cons 'logxor (map (g vs exp) l)))
120
121 ((#:bor . l)
122 (cons 'logior (map (g vs exp) l)))
123
124 ((#:not x)
125 (list 'not (exp vs x)))
126
127 ((#:or . x)
128 (cons 'or (map (g vs exp) x)))
129
130 ((#:and . x)
131 (cons 'and (map (g vs exp) x)))
132
133 ((#:test e1 #f)
134 (exp vs e1))
135
136 ((#:test e1 e2 e3)
137 (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
138
139 ((#:suite . l) (cons 'begin (map (g vs exp) l)))
140
141 ((#:try x #f #f fin)
142 `(dynamic-wind
143 (lambda () #f)
144 (lambda () ,(exp vs x))
145 (lambda () ,(exp vs fin))))
146
147 ((#:while test code #f)
148 (let ((lp (gensym "lp")))
149 `(let ,lp ()
150 (if test
151 (begin
152 ,(exp vs code)
153 (,lp))))))
154
155 ((#:for exp in code #f)
156 (match (cons exp in)
157 ((((#:power (#:identifier x) #f . #f)) .
158 ((#:power (#:identifier 'range) ((arg) #f #f) . #f)))
159 (let ((v (gensym "v"))
160 (lp (gensym "lp")))
161 `(let ((,v ,(exp arg)))
162 (let ,lp ((,x 0))
163 (if (< ,x ,v)
164 (begin
165 ,(exp vs code)
166 (,lp (+ ,x 1))))))))
167
168 ((((#:power (#:identifier x) #f . #f)) .
169 ((#:power (#:identifier 'range) ((arg1 arg2) #f #f) . #f)))
170 (let ((v1 (gensym "va"))
171 (v2 (gensym "vb"))
172 (lp (gensym "lp")))
173 `(let ((,v1 ,(exp arg1))
174 (,v2 ,(exp arg2)))
175 (let ,lp ((,x ,v1))
176 (if (< ,x ,v2)
177 (begin
178 ,(exp vs code)
179 (,lp (+ ,x 1))))))))
180
181 ((((#:power (#:identifier x) #f . #f)) .
182 ((#:power (#:identifier 'range) ((arg1 arg2 arg3) #f #f) . #f)))
183 (let ((v1 (gensym "va"))
184 (v2 (gensym "vb"))
185 (st (gensym "vs"))
186 (lp (gensym "lp")))
187 `(let ((,v1 ,(exp arg1))
188 (,st ,(exp arg2))
189 (,v2 ,(exp arg3)))
190 (let ,lp ((,x ,v1))
191 (if (< ,x ,v2)
192 (begin
193 ,(exp vs code)
194 (,lp (+ ,x ,st))))))))))
195
196
197 ((#:while test code else)
198 (let ((lp (gensym "lp")))
199 `(let ,lp ()
200 (if test
201 (begin
202 ,(exp vs code)
203 (,lp))
204 ,(exp else)))))
205
206 ((#:try x exc else fin)
207 (define (f x)
208 (match else
209 ((#f x)
210 `(catch #t
211 (lambda () ,x)
212 (lambda ,(gensym "x") ,(exp vs x))))))
213
214 `(dynamic-wind
215 (lambda () #f)
216 (lambda ()
217 ,(f
218 (let lp ((code (exp vs x)) (l (reverse exc)))
219 (match l
220 ((((e) c) . l)
221 (lp `(catch ,(exp vs e)
222 (lambda () ,code)
223 (lambda ,(gensym "x")
224 ,(exp c))) l))
225 ((((e . as) c) . l)
226 (lp `(let ((,as ,(exp vs e)))
227 (catch ,as
228 (lambda () ,code)
229 (lambda ,(gensym "x")
230 ,(exp vs c))) l)))
231 (()
232 code))))
233 (lambda () ,(exp vs fin)))))
234
235 ((#:def (#:identifier f)
236 (#:types-args-list
237 args
238 #f)
239 #f
240 code)
241 (let* ((f (string->symbol f))
242 (r (gensym "return"))
243 (as (map (lambda (x) (match x
244 ((((#:identifier x) . #f) #f)
245 (string->symbol x))))
246 args))
247 (vs (union as vs))
248 (ns (scope code vs))
249 (df (defs code '()))
250 (ls (diff (diff ns vs) df)))
251
252 `(define (,f ,@as) (,(C 'with-return) ,r
253 (let ,(map (lambda (x) (list x #f)) ls)
254 ,(with-fluids ((return r))
255 (exp ns code)))))))
256
257 ((#:global . _)
258 '(values))
259
260 ((#:lambdef v e)
261 (list `lambda v (exp vs e)))
262
263 ((#:stmt l)
264 (if (> (length l) 1)
265 (cons 'values (map (g vs exp) l))
266 (exp vs (car l))))
267
268
269 ((#:expr-stmt (l) (#:assign))
270 (exp vs l))
271
272 ((#:return . x)
273 `(,(fluid-ref return) ,@(map (g vs exp) x)))
274
275 ((#:expr-stmt
276 ((#:test (#:power (#:identifier v) () . #f) #f))
277 (#:assign (l)))
278 (let ((s (string->symbol v)))
279 `(set! ,s ,(exp vs l))))
280
281
282 ((#:comp . l)
283 (define (tr op x y)
284 (match op
285 ((or "<" ">" "<=" ">=")
286 (list (string->symbol op) x y))
287 ("!=" (list 'not (list 'equal? x y)))
288 ("==" (list 'equal? x y))
289 ("is" (list 'eq? x y))
290 ("isnot" (list 'not (list 'eq? x y)))
291 ("in" (list 'member x y))
292 ("notin" (list 'not (list 'member x y)))
293 ("<>" (list 'not (list 'equal? x y)))))
294 (let lp ((l l))
295 (match l
296 (()
297 '())
298 ((x op y)
299 (tr op (exp vs x) (exp vs y)))
300 ((x op . l)
301 (tr op (exp vs x) (lp vs l))))))))
302
303 (define (comp x)
304 (let ((globs (get-globals x)))
305 `(begin
306 ,@(map (lambda (s) `(define ,s (values))) globs)
307 ,@(map (g globs exp) x))))
308
309 (define-syntax with-return
310 (lambda (x)
311 (define (analyze ret x)
312 (syntax-case x (begin let if)
313 ((begin a ... b)
314 #`(begin a ... #,(analyze ret #'b)))
315 ((let lp v a ... b)
316 (symbol? (syntax->datum #'lp))
317 #`(let lp v a ... #,(analyze ret #'b)))
318 ((let v a ... b)
319 #`(let v a ... #,(analyze ret #'b)))
320 ((if p a b)
321 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
322 ((if p a)
323 #`(if p #,(analyze ret #'a)))
324 ((return a b ...)
325 (equal? (syntax->datum #'return) (syntax->datum ret))
326 (if (eq? #'(b ...) '())
327 #'a
328 #`(values a b ...)))
329 (x #'x)))
330
331 (define (is-ec ret x tail)
332 (syntax-case x (begin let)
333 ((begin a ... b)
334 #t
335 (or
336 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
337 (is-ec ret #'b tail)))
338
339 ((let lp ((y x) ...) a ... b)
340 (symbol? (syntax->datum #'lp))
341 (or
342 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
343 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
344 (is-ec ret #'b tail)))
345
346 ((let ((y x) ...) a ... b)
347 #t
348 (or
349 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
350 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
351 (is-ec ret #'b tail)))
352
353 ((if p a b)
354 #t
355 (or
356 (is-ec ret #'p #f)
357 (is-ec ret #'a tail)
358 (is-ec ret #'b tail)))
359 ((if p a)
360 #t
361 (or
362 (is-ec ret #'p #f)
363 (is-ec ret #'a tail)))
364
365 ((return a b ...)
366 (equal? (syntax->datum #'return) (syntax->datum ret))
367 (not tail))
368
369 ((a ...)
370 #t
371 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
372
373 (x
374 #t
375 #f)))
376
377 (syntax-case x ()
378 ((_ ret l)
379 (pf (let ((code (analyze #'ret #'l)))
380 (if (is-ec #'ret #'l #t)
381 #`(let/ec ret #,code)
382 code)))))))
383
384
385