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