151e0c2ac8661229e34d27bcd63ed63f060b6661
[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-syntax call
7 (syntax-rules ()
8 ((_ (f) . l) (f . l))))
9
10 (define (fold f init l)
11 (if (pair? l)
12 (fold f (f (car l) init) (cdr l))
13 init))
14
15 (define (pr . x)
16 (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
17 (with-output-to-port port
18 (lambda ()
19 (pretty-print x)))
20 (close port)
21 (car (reverse x)))
22
23 (define (pf x)
24 (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
25 (with-output-to-port port
26 (lambda () (pretty-print (syntax->datum x)) x))
27 (close port)
28 x)
29
30 (define (C x) `(@@ (language python compile) ,x))
31 (define (O x) `(@@ (oop pf-objects) ,x))
32 (define (G x) `(@ (guile) ,x))
33
34 (define (union as vs)
35 (let lp ((as as) (vs vs))
36 (match as
37 ((x . as)
38 (if (member x vs)
39 (lp as vs)
40 (lp as (cons x vs))))
41 (()
42 vs))))
43
44 (define (diff as vs)
45 (let lp ((as as) (rs '()))
46 (match as
47 ((x . as)
48 (if (member x vs)
49 (lp as rs)
50 (lp as (cons x rs))))
51 (()
52 rs))))
53
54 (define (get-globals code)
55 (let lp ((vs (glob code '())) (rs (scope code '())))
56 (match vs
57 ((x . l)
58 (if (member x rs)
59 (lp l rs)
60 (lp l (cons x rs))))
61 (()
62 rs))))
63
64 (define (glob x vs)
65 (match x
66 ((#:global . l)
67 (let lp ((l l) (vs vs))
68 (match l
69 (((#:identifier v . _) . l)
70 (let ((s (string->symbol v)))
71 (if (member s vs)
72 (lp l vs)
73 (lp l (cons s vs)))))
74 (()
75 vs))))
76 ((x . y)
77 (glob y (glob x vs)))
78 (x vs)))
79
80 (define (scope x vs)
81 (match x
82 ((#:def (#:identifier f . _) . _)
83 (union (list (string->symbol f)) vs))
84 ((#:lambdef . _)
85 vs)
86 ((#:classdef . _)
87 vs)
88 ((#:global . _)
89 vs)
90 ((#:identifier v . _)
91 (let ((s (string->symbol v)))
92 (if (member s vs)
93 vs
94 (cons s vs))))
95 ((x . y)
96 (scope y (scope x vs)))
97 (_ vs)))
98
99 (define (defs x vs)
100 (match x
101 ((#:def (#:identifier f . _) . _)
102 (union (list (string->symbol f)) vs))
103 ((#:lambdef . _)
104 vs)
105 ((#:class . _)
106 vs)
107 ((#:global . _)
108 vs)
109 ((x . y)
110 (defs y (defs x vs)))
111 (_ vs)))
112
113 (define (g vs e)
114 (lambda (x) (e vs x)))
115
116 (define return (make-fluid 'error-return))
117
118 (define (make-set vs x u)
119 (match x
120 ((#:test (#:power (#:identifier v . _) addings . _) . _)
121 (let ((v (string->symbol v)))
122 (if (null? addings)
123 `(set! ,v ,u)
124 (let* ((rev (reverse addings))
125 (las (car rev))
126 (new (reverse (cdr rev))))
127 `(,(O 'set) ,(let lp ((v v) (new new))
128 (match new
129 ((x . new)
130 (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
131 (() v)))
132 ',(exp vs las) ,u)))))))
133
134
135
136 (define (exp vs x)
137 (match (pr x)
138 ((#:power x () . #f)
139 (exp vs x))
140
141 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
142 ((#:power vf ((and trailer (#:identifier _ . _)) ...
143 (#:arglist (args ...) #f #f)) . #f)
144 (let ((args (map (g vs exp) args)))
145 (match vf
146 ((#:f (#:identifier f . _) e)
147 (let ((obj (gensym "obj"))
148 (l (gensym "l")))
149 '(call-with-values (lambda () (fcall (,(exp vs e)
150 ,@(map (g vd exp) trailer))
151 ,@args))
152 (lambda (,obj . ,l)
153 `(set! ,(string->symbol f) ,obj)
154 (apply 'values ,l)))))
155 (x
156 `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
157
158 ((#:identifier x . _)
159 (string->symbol x))
160
161 ((#:string x)
162 x)
163
164 (((and x (or #:+ #:- #:* #:/)) . l)
165 (cons (keyword->symbol x) (map (g vs exp) l)))
166
167 ((#:u~ x)
168 (list 'lognot (exp vs x)))
169
170 ((#:band . l)
171 (cons 'logand (map (g vs exp) l)))
172
173 ((#:bxor . l)
174 (cons 'logxor (map (g vs exp) l)))
175
176 ((#:bor . l)
177 (cons 'logior (map (g vs exp) l)))
178
179 ((#:not x)
180 (list 'not (exp vs x)))
181
182 ((#:or . x)
183 (cons 'or (map (g vs exp) x)))
184
185 ((#:and . x)
186 (cons 'and (map (g vs exp) x)))
187
188 ((#:test e1 #f)
189 (exp vs e1))
190
191 ((#:test e1 e2 e3)
192 (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
193
194 ((#:if test a ((tests . as) ...) . else)
195 `(,(G 'cond)
196 (,(exp vs test) ,(exp vs a))
197 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
198 ,@(if else `((else ,(exp vs else))) '())))
199
200 ((#:suite . l) (cons 'begin (map (g vs exp) l)))
201
202 ((#:try x #f #f fin)
203 `(dynamic-wind
204 (lambda () #f)
205 (lambda () ,(exp vs x))
206 (lambda () ,(exp vs fin))))
207
208 ((#:while test code #f)
209 (let ((lp (gensym "lp")))
210 `(let ,lp ()
211 (if test
212 (begin
213 ,(exp vs code)
214 (,lp))))))
215
216 ((#:classdef (#:identifier class . _) parents defs)
217 (let ()
218 (define (filt l)
219 (reverse
220 (fold (lambda (x s)
221 (match x
222 (((or 'fast 'functional)) s)
223 (x (cons x s))))
224 '() l)))
225 (define (is-functional l)
226 (fold (lambda (x pred)
227 (if pred
228 pred
229 (match x
230 (('functional) #t)
231 (_ #f)))) #f l))
232 (define (is-fast l)
233 (fold (lambda (x pred)
234 (if pred
235 pred
236 (match x
237 (('fast) #t)
238 (_ #f)))) #f l))
239
240
241 (let* ((class (string->symbol class))
242 (parents (match parents
243 (#f
244 '())
245 ((#:arglist args . _)
246 (map (g vs exp) args))))
247 (is-func (is-functional parents))
248 (is-fast (is-fast parents))
249 (kind (if is-func
250 (if is-fast
251 'mk-pf-class
252 'mk-pyf-class)
253 (if is-fast
254 'mk-p-class
255 'mk-py-class)))
256 (parents (filt parents)))
257 `(define ,class (,(O 'wrap)
258 (,(O kind)
259 ,class
260 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
261 #:const
262 ,(match (exp vs defs)
263 ((begin . l)
264 l)
265 (l l))
266 #:dynamic
267 ()))))))
268
269
270
271 ((#:for e in code . #f)
272 (=> next)
273 (match e
274 (((#:power (#:identifier x . _) () . #f))
275 (match in
276 (((#:test power . _))
277 (match power
278 ((#:power
279 (#:identifier "range" . _)
280 ((#:arglist arglist . _))
281 . _)
282 (match arglist
283 ((arg)
284 (let ((v (gensym "v"))
285 (x (string->symbol x))
286 (lp (gensym "lp")))
287 `(let ((,v ,(exp vs arg)))
288 (let ,lp ((,x 0))
289 (if (< ,x ,v)
290 (begin
291 ,(exp vs code)
292 (,lp (+ ,x 1))))))))
293 ((arg1 arg2)
294 (let ((v1 (gensym "va"))
295 (v2 (gensym "vb"))
296 (lp (gensym "lp")))
297 `(let ((,v1 ,(exp vs arg1))
298 (,v2 ,(exp vs arg2)))
299 (let ,lp ((,x ,v1))
300 (if (< ,x ,v2)
301 (begin
302 ,(exp vs code)
303 (,lp (+ ,x 1))))))))
304 ((arg1 arg2 arg3)
305 (let ((v1 (gensym "va"))
306 (v2 (gensym "vb"))
307 (st (gensym "vs"))
308 (lp (gensym "lp")))
309 `(let ((,v1 ,(exp vs arg1))
310 (,st ,(exp vs arg2))
311 (,v2 ,(exp vs arg3)))
312 (if (> st 0)
313 (let ,lp ((,x ,v1))
314 (if (< ,x ,v2)
315 (begin
316 ,(exp vs code)
317 (,lp (+ ,x ,st)))))
318 (if (< st 0)
319 (let ,lp ((,x ,v1))
320 (if (> ,x ,v2)
321 (begin
322 ,(exp vs code)
323 (,lp (+ ,x ,st)))))
324 (error "range with step 0 not allowed"))))))
325 (_ (next))))
326 (_ (next))))
327 (_ (next))))
328 (_ (next))))
329
330 ((#:while test code else)
331 (let ((lp (gensym "lp")))
332 `(let ,lp ()
333 (if test
334 (begin
335 ,(exp vs code)
336 (,lp))
337 ,(exp vs else)))))
338
339 ((#:try x exc else fin)
340 (define (f x)
341 (match else
342 ((#f x)
343 `(catch #t
344 (lambda () ,x)
345 (lambda ,(gensym "x") ,(exp vs x))))))
346
347 `(dynamic-wind
348 (lambda () #f)
349 (lambda ()
350 ,(f
351 (let lp ((code (exp vs x)) (l (reverse exc)))
352 (match l
353 ((((e) c) . l)
354 (lp `(catch ,(exp vs e)
355 (lambda () ,code)
356 (lambda ,(gensym "x")
357 ,(exp vs c))) l))
358 ((((e . as) c) . l)
359 (lp `(let ((,as ,(exp vs e)))
360 (catch ,as
361 (lambda () ,code)
362 (lambda ,(gensym "x")
363 ,(exp vs c)))) l))
364 (()
365 code))))
366 (lambda () ,(exp vs fin)))))
367
368 ((#:def (#:identifier f . _)
369 (#:types-args-list
370 args
371 #f #f)
372 #f
373 code)
374 (let* ((f (string->symbol f))
375 (r (gensym "return"))
376 (as (map (lambda (x) (match x
377 ((((#:identifier x . _) . #f) #f)
378 (string->symbol x))))
379 args))
380 (vs (union as vs))
381 (ns (scope code vs))
382 (df (defs code '()))
383 (ls (diff (diff ns vs) df)))
384
385 `(define ,f (lambda (,@as)
386 (,(C 'with-return) ,r
387 (let ,(map (lambda (x) (list x #f)) ls)
388 ,(with-fluids ((return r))
389 (exp ns code))))))))
390
391 ((#:global . _)
392 '(values))
393
394 ((#:lambdef v e)
395 (list `lambda v (exp vs e)))
396
397 ((#:stmt l)
398 (if (> (length l) 1)
399 (cons 'values (map (g vs exp) l))
400 (exp vs (car l))))
401
402
403 ((#:expr-stmt (l) (#:assign))
404 (exp vs l))
405
406 ((#:expr-stmt l (#:assign u))
407 (cond
408 ((= (length l) (length u))
409 (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
410 ((= (length u) 1)
411 (let ((vars (map (lambda (x) (gensym "v")) l)))
412 `(call-with-values (lambda () (exp vs (car u)))
413 (lambda vars
414 ,@(map make-set l vars)))))))
415
416
417
418 ((#:return . x)
419 `(,(fluid-ref return) ,@(map (g vs exp) x)))
420
421 ((#:expr-stmt
422 ((#:test (#:power (#:identifier v . _) () . #f) #f))
423 (#:assign (l)))
424 (let ((s (string->symbol v)))
425 `(set! ,s ,(exp vs l))))
426
427 ((#:comp x #f)
428 (exp vs x))
429
430 ((#:comp x (op . y))
431 (define (tr op x y)
432 (match op
433 ((or "<" ">" "<=" ">=")
434 (list (G (string->symbol op)) x y))
435 ("!=" (list 'not (list 'equal? x y)))
436 ("==" (list 'equal? x y))
437 ("is" (list 'eq? x y))
438 ("isnot" (list 'not (list 'eq? x y)))
439 ("in" (list 'member x y))
440 ("notin" (list 'not (list 'member x y)))
441 ("<>" (list 'not (list 'equal? x y)))))
442 (tr op (exp vs x) (exp vs y)))
443
444 (x x)))
445
446 (define (comp x)
447 (define start
448 (match (pr 'start x)
449 (((#:stmt
450 ((#:expr-stmt
451 ((#:test
452 (#:power
453 (#:identifier "module" . _)
454 ((#:arglist arglist #f #f))
455 . #f) #f))
456 (#:assign)))) . _)
457 (let ()
458 (define args
459 (map (lambda (x)
460 (exp '() x))
461 arglist))
462
463 `((,(G 'define-module) (language python module ,@args)))))
464 (x '())))
465
466 (if (pair? start)
467 (set! x (cdr x)))
468
469 (let ((globs (get-globals x)))
470 `(begin
471 ,@start
472 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
473 ,@(map (g globs exp) x))))
474
475 (define-syntax with-return
476 (lambda (x)
477 (define (analyze ret x)
478 (syntax-case x (begin let if)
479 ((begin a ... b)
480 #`(begin a ... #,(analyze ret #'b)))
481 ((let lp v a ... b)
482 (symbol? (syntax->datum #'lp))
483 #`(let lp v a ... #,(analyze ret #'b)))
484 ((let v a ... b)
485 #`(let v a ... #,(analyze ret #'b)))
486 ((if p a b)
487 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
488 ((if p a)
489 #`(if p #,(analyze ret #'a)))
490 ((return a b ...)
491 (equal? (syntax->datum #'return) (syntax->datum ret))
492 (if (eq? #'(b ...) '())
493 #'a
494 #`(values a b ...)))
495 (x #'x)))
496
497 (define (is-ec ret x tail)
498 (syntax-case x (begin let)
499 ((begin a ... b)
500 #t
501 (or
502 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
503 (is-ec ret #'b tail)))
504
505 ((let lp ((y x) ...) a ... b)
506 (symbol? (syntax->datum #'lp))
507 (or
508 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
509 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
510 (is-ec ret #'b tail)))
511
512 ((let ((y x) ...) a ... b)
513 #t
514 (or
515 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
516 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
517 (is-ec ret #'b tail)))
518
519 ((if p a b)
520 #t
521 (or
522 (is-ec ret #'p #f)
523 (is-ec ret #'a tail)
524 (is-ec ret #'b tail)))
525 ((if p a)
526 #t
527 (or
528 (is-ec ret #'p #f)
529 (is-ec ret #'a tail)))
530
531 ((return a b ...)
532 (equal? (syntax->datum #'return) (syntax->datum ret))
533 (not tail))
534
535 ((a ...)
536 #t
537 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
538
539 (x
540 #t
541 #f)))
542
543 (syntax-case x ()
544 ((_ ret l)
545 (let ((code (analyze #'ret #'l)))
546 (if (is-ec #'ret #'l #t)
547 #`(let/ec ret #,code)
548 code))))))
549
550 (define-syntax-rule (var v)
551 (if (defined? 'v)
552 (values)
553 (define! 'v #f)))
554