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