simple python formatting now supported
[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 control)
4 #:use-module (oop pf-objects)
5 #:use-module (oop goops)
6 #:use-module (language python exceptions)
7 #:use-module (language python yield)
8 #:use-module (language python for)
9 #:use-module (language python try)
10 #:use-module (language python list)
11 #:use-module (language python string)
12 #:use-module (ice-9 pretty-print)
13 #:export (comp))
14
15 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
16
17 (define s/d 'set!)
18
19 (define-syntax clear-warning-data
20 (lambda (x)
21 (set! (@@ (system base message) %dont-warn-list) '())
22 #f))
23
24 (define (dont-warn v)
25 (set! (@@ (system base message) %dont-warn-list)
26 (cons v
27 (@@ (system base message) %dont-warn-list))))
28
29 (define-syntax call
30 (syntax-rules ()
31 ((_ (f) . l) (f . l))))
32
33 (define (fold f init l)
34 (if (pair? l)
35 (fold f (f (car l) init) (cdr l))
36 init))
37
38 (define (pr . x)
39 (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
40 (with-output-to-port port
41 (lambda ()
42 (pretty-print (syntax->datum x))))
43 (close port)
44 (car (reverse x)))
45
46 (define (pf x)
47 (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
48 (with-output-to-port port
49 (lambda () (pretty-print (syntax->datum x)) x))
50 (close port)
51 x)
52
53 (define-inlinable (C x) `(@@ (language python compile) ,x))
54 (define-inlinable (Y x) `(@@ (language python yield) ,x))
55 (define-inlinable (T x) `(@@ (language python try) ,x))
56 (define-inlinable (F x) `(@@ (language python for) ,x))
57 (define-inlinable (L x) `(@@ (language python list) ,x))
58 (define-inlinable (A x) `(@@ (language python array) ,x))
59 (define-inlinable (S x) `(@@ (language python string) ,x))
60 (define-inlinable (O x) `(@@ (oop pf-objects) ,x))
61 (define-inlinable (G x) `(@ (guile) ,x))
62
63 (define (union as vs)
64 (let lp ((as as) (vs vs))
65 (match as
66 ((x . as)
67 (if (member x vs)
68 (lp as vs)
69 (lp as (cons x vs))))
70 (()
71 vs))))
72
73 (define (diff as vs)
74 (let lp ((as as) (rs '()))
75 (match as
76 ((x . as)
77 (if (member x vs)
78 (lp as rs)
79 (lp as (cons x rs))))
80 (()
81 rs))))
82
83 (define (get-globals code)
84 (let lp ((vs (glob code '())) (rs (scope code '())))
85 (match vs
86 ((x . l)
87 (if (member x rs)
88 (lp l rs)
89 (lp l (cons x rs))))
90 (()
91 rs))))
92
93 (define (glob x vs)
94 (match x
95 ((#:global . l)
96 (let lp ((l l) (vs vs))
97 (match l
98 (((#:identifier v . _) . l)
99 (let ((s (string->symbol v)))
100 (if (member s vs)
101 (lp l vs)
102 (lp l (cons s vs)))))
103 (()
104 vs))))
105 ((x . y)
106 (glob y (glob x vs)))
107 (x vs)))
108
109 (define (scope x vs)
110 (match x
111 ((#:def f . _)
112 (union (list (exp '() f)) vs))
113
114 ((#:lambdef . _)
115 vs)
116
117 ((#:classdef f . _)
118 (union (list (exp '() f)) vs))
119
120 ((#:global . _)
121 vs)
122
123 ((#:expr-stmt l (#:assign u))
124 (union (fold (lambda (x s)
125 (match x
126 ((#:test (#:power v2 v1 () . _) . _)
127 (if v2
128 (union
129 (union (list (exp '() v1))
130 (list (exp '() v2)))
131 s)
132 (union (list (exp '() v1)) s)))
133 (_ s)))
134 '()
135 l)
136 vs))
137
138 ((x . y)
139 (scope y (scope x vs)))
140 (_ vs)))
141
142 (define (defs x vs)
143 (match x
144 ((#:def (#:identifier f . _) . _)
145 (union (list (string->symbol f)) vs))
146 ((#:lambdef . _)
147 vs)
148 ((#:class . _)
149 vs)
150 ((#:global . _)
151 vs)
152 ((x . y)
153 (defs y (defs x vs)))
154 (_ vs)))
155
156 (define (gen-yield f)
157 (string->symbol
158 (string-append
159 (symbol->string f)
160 ".yield")))
161
162 (define (g vs e)
163 (lambda (x) (e vs x)))
164
165 (define return (make-fluid 'error-return))
166
167 (define-syntax-rule (<< x y) (ash x y))
168 (define-syntax-rule (>> x y) (ash x (- y)))
169
170 (define (fastfkn x)
171 (case x
172 ;; Lists
173 ((append) (L 'pylist-append!))
174 ((count) (L 'pylist-count))
175 ((extend) (L 'pylist-extend!))
176 ((index) (L 'pylist-index))
177 ((pop) (L 'pylist-pop!))
178 ((insert) (L 'pylist-insert!))
179 ((remove) (L 'pylist-remove!))
180 ((reverse) (L 'pylist-reverse!))
181 ((sort) (L 'pylist-sort!))
182
183 ;; String
184 ((format) (S 'py-format))
185 (else #f)))
186
187 (define (get-kwarg vs arg)
188 (let lp ((arg arg) (l '()) (kw '()))
189 (match arg
190 (((#:= a b) . arg)
191 (lp arg
192 l
193 (cons*
194 (exp vs b)
195 (symbol->keyword
196 (exp vs a))
197 kw)))
198 ((x . arg)
199 (lp arg (cons (exp vs x) l) kw))
200 (()
201 (values (reverse l) (reverse kw))))))
202
203 (define (get-addings vs x)
204 (match x
205 (() '())
206 ((x . l)
207 (let ((is-fkn? (match l
208 ((#f) #t)
209 (((#:arglist . _) . _)
210 #t)
211 (_
212 #f))))
213
214 (cons
215 (match x
216 ((#:identifier . _)
217 (let* ((tag (exp vs x))
218 (xs (gensym "xs"))
219 (is-fkn? (aif it (and is-fkn? (fastfkn tag))
220 `(#:call-obj (lambda (e)
221 `(lambda ,xs
222 (apply ,it ,e ,xs))))
223 #f)))
224 (if is-fkn?
225 is-fkn?
226 `(#:identifier ',tag))))
227
228 ((#:arglist args apply #f)
229 (call-with-values (lambda () (get-kwarg vs args))
230 (lambda (args kwarg)
231 (if apply
232 `(#:apply ,@args ,@kwarg
233 ,`(,(L 'to-list) ,(exp vs apply)))
234 `(#:call ,@args ,@kwarg)))))
235
236 ((#:subscripts (n #f #f))
237 `(#:vecref ,(exp vs n)))
238
239 ((#:subscripts (n1 n2 n3))
240 (let ((w (lambda (x) (if (eq? x 'None) ''None x))))
241 `(#:vecsub
242 ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3)))))
243
244 ((#:subscripts (n #f #f) ...)
245 `(#:array-ref ,@ (map (lambda (n)
246 (exp vs n))
247 n)))
248
249 ((#:subscripts (n1 n2 n3) ...)
250 (let ((w (lambda (x) (if (eq? x 'None) ''None x))))
251 `(#:arraysub
252 ,@(map (lambda (x y z)
253 `(,(exp vs x) ,(exp vs y) ,(exp vs z)))
254 n1 n2 n3))))
255
256 (_ (error "unhandled addings")))
257 (get-addings vs l))))))
258
259
260 (define (make-set vs op x u)
261 (define (tr-op op)
262 (match op
263 ("+=" '+)
264 ("-=" '-)
265 ("*=" '*)
266 ("/=" '/)
267 ("%=" 'modulo)
268 ("&=" 'logand)
269 ("|=" 'logior)
270 ("^=" 'logxor)
271 ("**=" 'expt)
272 ("<<=" (C '<<))
273 (">>=" (C '>>))
274 ("//=" 'floor-quotient)))
275
276 (match x
277 ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
278 (let ((addings (get-addings vs addings)))
279 (define q (lambda (x) `',x))
280 (if kind
281 (let ((v (string->symbol v)))
282 (if (null? addings)
283 (if op
284 `(,s/d ,v (,(tr-op op) ,v ,u))
285 `(,s/d ,v ,u))
286 (if op
287 `(,s/d ,(exp vs kind)
288 (,(O 'fset-x) ,v (list ,@(map q addings))
289 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
290
291 `(,s/d ,(exp vs kind)
292 (,(O 'fset-x) ,v (list ,@(map q addings)) ,u)))))
293
294 (let ((v (string->symbol v)))
295 (if (null? addings)
296 (if op
297 `(,s/d ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))
298 `(,s/d ,v ,u))
299 `(,(C 'set-x)
300 ,v
301 ,addings
302 ,(if op
303 `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
304 u)))))))))
305
306 (define is-class? (make-fluid #f))
307 (define (gen-yargs vs x)
308 (match (pr 'yarg x) ((#:list args)
309 (map (g vs exp) args))))
310
311 (define inhibit-finally #f)
312
313 (define tagis (make-hash-table))
314 (define-syntax-rule (gen-table x vs (tag code ...) ...)
315 (begin
316 (hash-set! tagis tag
317 (lambda (x vs)
318 (match x code ...)))
319
320 ...))
321
322 (gen-table x vs
323 (#:power
324 ((_ _ (x) () . #f)
325 (exp vs x))
326
327 ((_ _ x () . #f)
328 (exp vs x))
329
330 ((_ #f vf trailer . **)
331 (let ()
332 (define (pw x)
333 (if **
334 `(expt ,x ,(exp vs **))
335 x))
336 (pw
337 (let lp ((e (exp vs vf)) (trailer trailer))
338 (match trailer
339 (()
340 e)
341 ((#f)
342 (list e))
343 ((x . trailer)
344 (let ((is-fkn? (match trailer
345 ((#f) #t)
346 (((#:arglist . _) . _)
347 #t)
348 (_
349 #f))))
350 (match (pr x)
351 ((#:identifier . _)
352 (let* ((tag (exp vs x))
353 (xs (gensym "xs"))
354 (is-fkn? (aif it (and is-fkn? (fastfkn tag))
355 `(lambda ,xs (apply ,it ,e ,xs))
356 #f)))
357 (lp (if is-fkn?
358 is-fkn?
359 `(,(O 'refq) ,e ',tag #f))
360 trailer)))
361
362 ((#:arglist args apply #f)
363 (call-with-values (lambda () (get-kwarg vs args))
364 (lambda (args kwarg)
365 (if apply
366 (lp `(apply ,e
367 ,@args
368 ,@kwarg
369 ,`(,(L 'to-list) ,(exp vs apply)))
370 trailer)
371 (lp `(,e ,@args ,@kwarg) trailer)))))
372
373 ((#:subscripts (n #f #f))
374 `(,(L 'pylist-ref) ,e ,(exp vs n)))
375
376 ((#:subscripts (n1 n2 n3))
377 (let ((w (lambda (x) (if (eq? x 'None) ''None x))))
378 `(,(L 'pylist-slice) ,e
379 ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3)))))
380
381 ((#:subscripts (n #f #f) ...)
382 `(,(A 'pyarray-ref) ,e (list ,@ (map (lambda (n)
383 (exp vs n))
384 n))))
385
386 ((#:subscripts (n1 n2 n3) ...)
387 (let ((w (lambda (x) (if (eq? x 'None) ''None x))))
388 `(,(A 'pyarray-slice) ,e
389 (list ,@(map (lambda (x y z)
390 `(list ,(exp vs x) ,(exp vs y) ,(exp vs z)))
391 n1 n2 n3)))))
392
393 (_ (error "unhandled trailer")))))))))))
394
395 (#:identifier
396 ((#:identifier x . _)
397 (string->symbol x)))
398
399 (#:string
400 ((#:string #f x)
401 x))
402
403 (#:+
404 ((_ . l)
405 (cons '+ (map (g vs exp) l))))
406 (#:-
407 ((_ . l)
408 (cons '- (map (g vs exp) l))))
409 (#:*
410 ((_ . l)
411 (cons '* (map (g vs exp) l))))
412 (#:/
413 ((_ . l)
414 (cons '/ (map (g vs exp) l))))
415
416 (#:%
417 ((_ . l)
418 (cons 'modulo (map (g vs exp) l))))
419
420 (#://
421 ((_ . l)
422 (cons 'floor-quotient (map (g vs exp) l))))
423
424 (#:<<
425 ((_ . l)
426 (cons (C '<<) (map (g vs exp) l))))
427
428 (#:>>
429 ((_ . l)
430 (cons (C '>>) (map (g vs exp) l))))
431
432 (#:u~
433 ((_ x)
434 (list 'lognot (exp vs x))))
435
436 (#:u-
437 ((_ x)
438 (list '- (exp vs x))))
439
440 (#:u+
441 ((_ x)
442 (list '+ (exp vs x))))
443
444 (#:band
445 ((_ . l)
446 (cons 'logand (map (g vs exp) l))))
447
448 (#:bxor
449 ((_ . l)
450 (cons 'logxor (map (g vs exp) l))))
451
452 (#:bor
453 ((_ . l)
454 (cons 'logior (map (g vs exp) l))))
455
456 (#:not
457 ((_ x)
458 (list 'not (exp vs x))))
459
460 (#:or
461 ((_ . x)
462 (cons 'or (map (g vs exp) x))))
463
464 (#:and
465 ((_ . x)
466 (cons 'and (map (g vs exp) x))))
467
468 (#:test
469 ((_ e1 #f)
470 (exp vs e1))
471
472 ((_ e1 e2 e3)
473 (list 'if (exp vs e2) (exp vs e1) (exp vs e3))))
474
475
476
477 (#:if
478 ((_ test a ((tests . as) ...) . else)
479 `(,(G 'cond)
480 (,(exp vs test) ,(exp vs a))
481 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
482 ,@(if else `((else ,(exp vs else))) '()))))
483
484 (#:suite
485 ((_ . l) (cons 'begin (map (g vs exp) l))))
486
487 (#:classdef
488 ((_ (#:identifier class . _) parents defs)
489 (with-fluids ((is-class? #t))
490 (let ()
491 (define (filt l)
492 (reverse
493 (fold (lambda (x s)
494 (match x
495 ((or 'fast 'functional) s)
496 (x (cons x s))))
497 '() l)))
498 (define (is-functional l)
499 (fold (lambda (x pred)
500 (if pred
501 pred
502 (match x
503 ('functional #t)
504 (_ #f))))
505 #f l))
506 (define (is-fast l)
507 (fold (lambda (x pred)
508 (if pred
509 pred
510 (match x
511 ('fast #t)
512 (_ #f))))
513 #f l))
514
515
516 (let* ((class (string->symbol class))
517 (parents (match parents
518 (()
519 '())
520 (#f
521 '())
522 ((#:arglist args . _)
523 (map (g vs exp) args))))
524 (is-func (is-functional parents))
525 (is-fast (is-fast parents))
526 (kind (if is-func
527 (if is-fast
528 'mk-pf-class
529 'mk-pyf-class)
530 (if is-fast
531 'mk-p-class
532 'mk-py-class)))
533 (parents (filt parents)))
534 `(define ,class (,(O kind)
535 ,class
536 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
537 #:const
538 ,(match (exp vs defs)
539 (('begin . l)
540 l)
541 ((('begin . l))
542 l)
543 (l l))
544 #:dynamic
545 ())))))))
546
547 (#:import
548 ((_ ((() nm) . #f))
549 `(use-modules (language python module ,(exp vs nm)))))
550
551 (#:for
552 ((_ e in code . #f)
553 (=> next)
554 (match e
555 (((#:power #f (#:identifier x . _) () . #f))
556 (match in
557 (((#:test power . _))
558 (match power
559 ((#:power #f
560 (#:identifier "range" . _)
561 ((#:arglist arglist . _))
562 . _)
563 (match arglist
564 ((arg)
565 (let ((v (gensym "v"))
566 (x (string->symbol x))
567 (lp (gensym "lp")))
568 `(let ((,v ,(exp vs arg)))
569 (let ,lp ((,x 0))
570 (if (< ,x ,v)
571 (begin
572 ,(exp vs code)
573 (,lp (+ ,x 1))))))))
574 ((arg1 arg2)
575 (let ((v1 (gensym "va"))
576 (v2 (gensym "vb"))
577 (lp (gensym "lp")))
578 `(let ((,v1 ,(exp vs arg1))
579 (,v2 ,(exp vs arg2)))
580 (let ,lp ((,x ,v1))
581 (if (< ,x ,v2)
582 (begin
583 ,(exp vs code)
584 (,lp (+ ,x 1))))))))
585 ((arg1 arg2 arg3)
586 (let ((v1 (gensym "va"))
587 (v2 (gensym "vb"))
588 (st (gensym "vs"))
589 (lp (gensym "lp")))
590 `(let ((,v1 ,(exp vs arg1))
591 (,st ,(exp vs arg2))
592 (,v2 ,(exp vs arg3)))
593 (if (> st 0)
594 (let ,lp ((,x ,v1))
595 (if (< ,x ,v2)
596 (begin
597 ,(exp vs code)
598 (,lp (+ ,x ,st)))))
599 (if (< st 0)
600 (let ,lp ((,x ,v1))
601 (if (> ,x ,v2)
602 (begin
603 ,(exp vs code)
604 (,lp (+ ,x ,st)))))
605 (error "range with step 0 not allowed"))))))
606 (_ (next))))
607 (_ (next))))
608 (_ (next))))
609 (_ (next))))
610
611 ((_ es in code . else)
612 (let* ((es2 (map (g vs exp) es))
613 (vs2 (union es2 vs))
614 (code2 (exp vs2 code))
615 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
616 (else2 (if else (exp vs2 else) #f))
617 (in2 (map (g vs exp) in)))
618 (list (C 'for) es2 in2 code2 else2 p))))
619
620
621 (#:while
622 ((_ test code . #f)
623 (let ((lp (gensym "lp")))
624 `(let ,lp ()
625 (if ,(exp vs test)
626 (begin
627 ,(exp vs code)
628 (,lp))))))
629
630 ((_ test code else)
631 (let ((lp (gensym "lp")))
632 `(let ,lp ()
633 (if test
634 (begin
635 ,(exp vs code)
636 (,lp))
637 ,(exp vs else))))))
638
639 (#:try
640 ((_ x (or #f ()) #f . fin)
641 (if fin
642 `(,(T 'try) ,(exp vs x) #:finally (lambda () fin))
643 (exp vs x)))
644
645
646 ((_ x exc else . fin)
647 `(,(T 'try) ,(exp vs x)
648 ,@(let lp ((exc exc) (r (if else (exp vs else) '())))
649 (match exc
650 ((((test . #f) code) . exc)
651 (lp exc (cons `(#:except ,(exp vs code)) r)))
652
653 ((((test . as) code) . exc)
654 (let ((l (gensym "l")))
655 (lp exc
656 (cons
657 `(#:except ,(exp vs test) => (lambda (,(exp vs as) . ,l)
658 ,(exp vs code)))
659 r))))
660 (()
661 (reverse r))))
662 ,@(if fin `(#:finally (lambda () ,(exp vs fin))) '()))))
663
664 (#:subexpr
665 ((_ . l)
666 (exp vs l)))
667
668 (#:raise
669 ((_ #f . #f)
670 `(,(T 'raise) (,(O 'Exception))))
671
672 ((_ code . #f)
673 `(,(T 'raise) ,(exp vs code)))
674
675 ((_ code . from)
676 (let ((o (gensym "o"))
677 (c (gensym "c")))
678 `(,(T 'raise)
679 (let ((,c ,(exp vs code)))
680 (let ((,o (if (,(O 'pyclass?) ,c)
681 (,c)
682 ,c)))
683 (,(O 'set) ,o '__cause__ ,(exp vs from))
684 ,o))))))
685
686
687 (#:yield
688 ((_ args)
689 (let ((f (gensym "f")))
690 `(begin
691 (fluid-set! ,(Y 'in-yield) #t)
692 (let ((,f (scm.yield ,@(gen-yargs vs args))))
693 (,f)))))
694
695
696 ((_ f args)
697 (let ((f (gen-yield (exp vs f)))
698 (g (gensym "f")))
699 `(begin
700 (set! ,(C 'inhibit-finally) #t)
701 (let ((,g (,f ,@(gen-yargs vs args))))
702 (,g))))))
703
704 (#:def
705 ((_ f
706 (#:types-args-list
707 args
708 extra #f)
709 #f
710 code)
711 (let* ((c? (fluid-ref is-class?))
712 (f (exp vs f))
713 (y? (is-yield f #f code))
714 (r (gensym "return"))
715 (dd (match extra
716 (((e . #f) ()) (list (exp vs e)))
717 (#f '())))
718 (dd2 (if (null? dd) dd (car dd)))
719 (as (map (lambda (x) (match x
720 ((((#:identifier x . _) . #f) #f)
721 (string->symbol x))))
722 args))
723 (ab (gensym "ab"))
724 (vs (union dd (union as vs)))
725 (ns (scope code vs))
726 (df (defs code '()))
727 (ex (gensym "ex"))
728 (y 'scm.yield)
729 (y.f (gen-yield f))
730 (ls (diff (diff ns vs) df)))
731
732 (define (mk code)
733 `(let-syntax ((,y (syntax-rules ()
734 ((_ . args)
735 (abort-to-prompt ,ab . args))))
736 (,y.f (syntax-rules ()
737 ((_ . args)
738 (abort-to-prompt ,ab . args)))))
739 ,code))
740
741 (with-fluids ((is-class? #f))
742 (if c?
743 (if y?
744 `(define ,f
745 (,(C 'def-wrap) ,y? ,f ,ab
746 (lambda (,@as ,@dd2)
747 (,(C 'with-return) ,r
748 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
749 ,(with-fluids ((return r))
750 (exp ns code))))))))
751
752 `(define ,f (lambda (,@as ,@dd2)
753 (,(C 'with-return) ,r
754 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
755 ,(with-fluids ((return r))
756 (exp ns code))))))))
757
758 (if y?
759 `(define ,f
760 (,(C 'def-wrap) ,y? ,f ,ab
761 (lambda (,@as ,@dd2)
762 (,(C 'with-return) ,r
763 (let ,(map (lambda (x) (list x #f)) ls)
764 ,(with-fluids ((return r))
765 (mk
766 (exp ns code))))))))
767 `(define ,f
768 (lambda (,@as ,@dd2)
769 (,(C 'with-return) ,r
770 (let ,(map (lambda (x) (list x #f)) ls)
771 ,(with-fluids ((return r))
772 (exp ns code))))))))))))
773
774 (#:global
775 ((_ . _)
776 '(values)))
777
778 (#:list
779 ((_ . l)
780 (list (L 'to-pylist) (let lp ((l l))
781 (match l
782 ((or () #f) ''())
783 (((#:starexpr #:power #f (#:list . l) . _) . _)
784 (lp l))
785 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
786 (lp l))
787 (((#:starexpr . l) . _)
788 `(,(L 'to-list) ,(exp vs l)))
789 ((x . l)
790 `(cons ,(exp vs x) ,(lp l))))))))
791 (#:tuple
792 ((_ . l)
793 (let lp ((l l))
794 (match l
795 (() ''())
796 (((#:starexpr #:power #f (#:list . l) . _) . _)
797 (lp l))
798 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
799 (lp l))
800 (((#:starexpr . l) . _)
801 `(,(L 'to-list) ,(exp vs l)))
802 ((x . l)
803 `(cons ,(exp vs x) ,(lp l)))))))
804
805 (#:lambdef
806 ((_ v e)
807 (list `lambda v (exp vs e))))
808
809 (#:stmt
810 ((_ l)
811 (if (> (length l) 1)
812 (cons 'values (map (g vs exp) l))
813 (exp vs (car l)))))
814
815
816 (#:expr-stmt
817 ((_ (l) (#:assign))
818 (exp vs l))
819
820 ((_ l type)
821 (=> fail)
822 (call-with-values
823 (lambda () (match type
824 ((#:assign u)
825 (values #f u))
826 ((#:augassign op u)
827 (values op u))
828 (_ (fail))))
829
830 (lambda (op u)
831 (cond
832 ((= (length l) (length u))
833 (if (= (length l) 1)
834 (make-set vs op (car l) (exp vs (car u)))
835 (cons 'begin
836 (map (lambda (l u) (make-set vs op l u))
837 l
838 (map (g vs exp) u)))))
839 ((and (= (length u) 1) (not op))
840 (let ((vars (map (lambda (x) (gensym "v")) l)))
841 `(call-with-values (lambda () (exp vs (car u)))
842 (lambda vars
843 ,@(map (lambda (l v) (make-set vs op l v))
844 l vars)))))))))
845
846 ((_
847 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
848 (#:assign (l)))
849 (let ((s (string->symbol v)))
850 `(,s/d ,s ,(exp vs l)))))
851
852
853 (#:return
854 ((_ . x)
855 `(,(fluid-ref return) ,@(map (g vs exp) x))))
856
857
858 (#:comp
859 ((_ x #f)
860 (exp vs x))
861
862 ((_ x (op . y))
863 (define (tr op x y)
864 (match op
865 ((or "<" ">" "<=" ">=")
866 (list (G (string->symbol op)) x y))
867 ("!=" (list 'not (list 'equal? x y)))
868 ("==" (list 'equal? x y))
869 ("is" (list 'eq? x y))
870 ("isnot" (list 'not (list 'eq? x y)))
871 ("in" (list 'member x y))
872 ("notin" (list 'not (list 'member x y)))
873 ("<>" (list 'not (list 'equal? x y)))))
874 (tr op (exp vs x) (exp vs y)))))
875
876 (define (exp vs x)
877 (match (pr x)
878 ((e)
879 (exp vs e))
880 ((tag . l)
881 ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))
882
883 (#:True #t)
884 (#:null ''())
885 (#:False #f)
886 (#:pass `(values))
887 (#:break
888 (C 'break))
889 (#:continue
890 (C 'continue))
891 (x x)))
892
893 (define (comp x)
894 (define start
895 (match (pr 'start x)
896 (((#:stmt
897 ((#:expr-stmt
898 ((#:test
899 (#:power #f
900 (#:identifier "module" . _)
901 ((#:arglist arglist #f #f))
902 . #f) #f))
903 (#:assign)))) . _)
904 (let ()
905 (define args
906 (map (lambda (x)
907 (exp '() x))
908 arglist))
909
910 `((,(G 'define-module)
911 (language python module ,@args)
912 #:use-module (language python module python)))))
913 (x '())))
914
915 (if (fluid-ref (@@ (system base compile) %in-compile))
916 (set! s/d 'set!)
917 (set! s/d 'define))
918
919 (if (pair? start)
920 (set! x (cdr x)))
921
922 (let ((globs (get-globals x)))
923 `(begin
924 ,@start
925 ,(C 'clear-warning-data)
926 (set! (@@ (system base message) %dont-warn-list) '())
927 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
928 ,@(map (g globs exp) x))))
929
930 (define-syntax-parameter break
931 (lambda (x) #'(values)))
932
933 (define-syntax-parameter continue
934 (lambda (x) (error "continue must be bound")))
935
936 (define (is-yield f p x)
937 (match x
938 ((#:def nm args _ code)
939 (is-yield f #t code))
940 ((#:yield x _)
941 (eq? f (exp '() x)))
942 ((#:yield _)
943 (not p))
944 ((a . l)
945 (or
946 (is-yield f p a)
947 (is-yield f p l)))
948 (_
949 #f)))
950
951
952
953 (define-syntax-rule (with-sp ((x v) ...) code ...)
954 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
955
956 (define (is-ec ret x tail tags)
957 (syntax-case (pr 'is-ec x) (begin let if define @@)
958 ((begin a ... b)
959 #t
960 (or
961 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
962 (is-ec ret #'b tail tags)))
963
964 ((let lp ((y x) ...) a ... b)
965 (symbol? (syntax->datum #'lp))
966 (or
967 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
968 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
969 (is-ec ret #'b tail tags)))
970
971 ((let ((y x) ...) a ... b)
972 #t
973 (or
974 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
975 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
976 (is-ec ret #'b tail tags)))
977
978 ((if p a b)
979 #t
980 (or
981 (is-ec ret #'p #f tags)
982 (is-ec ret #'a tail tags)
983 (is-ec ret #'b tail tags)))
984
985 ((define . _)
986 #t
987 #f)
988
989 ((if p a)
990 #t
991 (or
992 (is-ec ret #'p #f tags)
993 (is-ec ret #'a tail tags)))
994
995 ((@@ _ _)
996 #t
997 (if (member (pr (syntax->datum x)) tags)
998 #t
999 #f))
1000
1001 ((a ...)
1002 #t
1003 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
1004
1005 (x
1006 #t
1007 #f)))
1008
1009 (define-syntax with-return
1010 (lambda (x)
1011 (define (analyze ret x)
1012 (syntax-case x (begin let if)
1013 ((begin a ... b)
1014 #`(begin a ... #,(analyze ret #'b)))
1015 ((let lp v a ... b)
1016 (symbol? (syntax->datum #'lp))
1017 #`(let lp v a ... #,(analyze ret #'b)))
1018 ((let v a ... b)
1019 #`(let v a ... #,(analyze ret #'b)))
1020 ((if p a b)
1021 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
1022 ((if p a)
1023 #`(if p #,(analyze ret #'a)))
1024 ((return a b ...)
1025 (equal? (syntax->datum #'return) (syntax->datum ret))
1026 (if (eq? #'(b ...) '())
1027 #'a
1028 #`(values a b ...)))
1029 (x #'x)))
1030
1031 (define (is-ec ret x tail)
1032 (syntax-case x (begin let if define @@)
1033 ((begin a ... b)
1034 #t
1035 (or
1036 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1037 (is-ec ret #'b tail)))
1038
1039 ((let lp ((y x) ...) a ... b)
1040 (symbol? (syntax->datum #'lp))
1041 (or
1042 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1043 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1044 (is-ec ret #'b tail)))
1045
1046 ((let ((y x) ...) a ... b)
1047 #t
1048 (or
1049 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1050 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1051 (is-ec ret #'b tail)))
1052
1053 ((define . _)
1054 #t
1055 #f)
1056
1057 ((if p a b)
1058 #t
1059 (or
1060 (is-ec ret #'p #f)
1061 (is-ec ret #'a tail)
1062 (is-ec ret #'b tail)))
1063
1064 ((if p a)
1065 #t
1066 (or
1067 (is-ec ret #'p #f)
1068 (is-ec ret #'a tail)))
1069
1070 ((return a b ...)
1071 (equal? (syntax->datum #'return) (syntax->datum ret))
1072 (not tail))
1073
1074 ((a ...)
1075 #t
1076 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
1077
1078 (x
1079 #t
1080 #f)))
1081
1082 (syntax-case x ()
1083 ((_ ret l)
1084 (let ((code (analyze #'ret #'l)))
1085 (if (is-ec #'ret #'l #t)
1086 #`(let/ec ret #,code)
1087 code))))))
1088
1089 (define-syntax var
1090 (lambda (x)
1091 (syntax-case x ()
1092 ((_ v)
1093 (begin
1094 (dont-warn (syntax->datum #'v))
1095 #'(if (module-defined? (current-module) 'v)
1096 (values)
1097 (define! 'v #f)))))))
1098
1099 (define-inlinable (non? x) (eq? x #:nil))
1100
1101 (define-syntax for
1102 (syntax-rules ()
1103 ((_ (x) (a) code #f #f)
1104 (if (pair? a)
1105 (let lp ((l a))
1106 (if (pair? l)
1107 (let ((x (car l)))
1108 (with-sp ((continue (lp (cdr l)))
1109 (break (values)))
1110 code
1111 (lp (cdr l))))))
1112 (for/adv1 (x) (a) code #f #f)))
1113
1114 ((_ (x) (a) code #f #t)
1115 (if (pair? a)
1116 (let/ec break-ret
1117 (let lp ((l a))
1118 (if (pair? l)
1119 (begin
1120 (let/ec continue-ret
1121 (let ((x (car l)))
1122 (with-sp ((continue (continue-ret))
1123 (break (break-ret)))
1124 code)))
1125 (lp (cdr l))))))
1126 (for/adv1 (x) (a) code #f #t)))
1127
1128 ((_ (x) (a) code next #f)
1129 (if (pair? a)
1130 (let/ec break-ret
1131 (let ((x (let lp ((l a) (old #f))
1132 (if (pair? l)
1133 (let ((x (car l)))
1134 (let/ec continue-ret
1135 (with-sp ((continue (continue-ret))
1136 (break (break-ret)))
1137 code))
1138 (lp (cdr l)))
1139 old))))
1140 next))
1141 (for/adv1 (x) (a) code next #f)))
1142
1143 ((_ x a code next p)
1144 (for/adv1 x a code next p))))
1145
1146 (define-syntax for/adv1
1147 (lambda (x)
1148 (syntax-case x ()
1149 ((_ (x ...) (in ...) code #f #f)
1150 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1151 #'(let ((inv (wrap-in in)) ...)
1152 (catch StopIteration
1153 (lambda ()
1154 (let lp ()
1155 (call-with-values (lambda () (values (next inv) ...))
1156 (lambda (x ...)
1157 (with-sp ((break (values))
1158 (continue (values)))
1159 code
1160 (lp))))))
1161 (lambda z (values))))))
1162
1163 ((_ (x ...) (in ...) code #f #t)
1164 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1165 #'(let ((inv (wrap-in in)) ...)
1166 (let lp ()
1167 (let/ec break-ret
1168 (catch StopIteration
1169 (lambda ()
1170 (call-with-values (lambda () (values (next inv) ...))
1171 (lambda (x ...)
1172 (let/ec continue-ret
1173 (with-sp ((break (break-ret))
1174 (continue (continue-ret)))
1175 code))
1176 (lp))))
1177 (lambda z (values))))))))
1178
1179 ((_ (x ...) in code else #f)
1180 #'(for-adv (x ...) in code else #f))
1181
1182 ((_ (x ...) in code else #t)
1183 #'(for-adv (x ...) in code else #t)))))
1184
1185
1186 (define-syntax for-adv
1187 (lambda (x)
1188 (define (gen x y)
1189 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
1190 (syntax-case x ()
1191 ((x ...) #'(values (next x) ...)))
1192 (syntax-case x ()
1193 ((x) #'(next x)))))
1194
1195 (syntax-case x ()
1196 ((_ (x ...) (in ...) code else p)
1197 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1198 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
1199 ((xx ...) (generate-temporaries #'(x ...))))
1200 (if (syntax->datum #'p)
1201 #'(let ((inv (wrap-in in)) ...)
1202 (let/ec break-ret
1203 (let ((x #f) ...)
1204 (catch StopIteration
1205 (lambda ()
1206 (let lp ()
1207 (call-with-values (lambda () get)
1208 (lambda (xx ...)
1209 (set! x xx) ...
1210 (let/ec continue-ret
1211 (with-sp ((break (break-ret))
1212 (continue (continue-ret)))
1213 code))
1214 (lp)))))
1215 (lambda q else)))))
1216
1217 #'(let ((inv (wrap-in in)) ...)
1218 (let ((x #f) ...)
1219 (let/ec break-ret
1220 (catch StopIteration
1221 (lambda ()
1222 (let lp ()
1223 (call-with-values (lambda () get)
1224 (lambda (xx ...)
1225 (set! x xx) ...
1226 (with-sp ((break (break-ret))
1227 (continue (values)))
1228 code)
1229 (lp)))))
1230 (lambda e else))))))))))))
1231
1232 (define-syntax def-wrap
1233 (lambda (x)
1234 (syntax-case x ()
1235 ((_ #f f ab x)
1236 (pr 'def-wrap #'f 'false)
1237 #'x)
1238
1239 ((_ #t f ab code)
1240 (pr 'def-wrap #'f 'true)
1241 #'(lambda x
1242 (define obj (make <yield>))
1243 (define ab (make-prompt-tag))
1244 (slot-set! obj 'k #f)
1245 (slot-set! obj 'closed #f)
1246 (slot-set! obj 's
1247 (lambda ()
1248 (call-with-prompt
1249 ab
1250 (lambda ()
1251 (let/ec return
1252 (apply code x))
1253 (slot-set! obj 'closed #t)
1254 (throw StopIteration))
1255 (letrec ((lam
1256 (lambda (k . l)
1257 (fluid-set! in-yield #f)
1258 (slot-set! obj 'k
1259 (lambda (a)
1260 (call-with-prompt
1261 ab
1262 (lambda ()
1263 (k a))
1264 lam)))
1265 (apply values l))))
1266 lam))))
1267 obj)))))
1268
1269 (define-syntax ref-x
1270 (syntax-rules ()
1271 ((_ v)
1272 v)
1273 ((_ v (#:identifier x) . l)
1274 (ref-x (refq v 'x) . l))
1275 ((_ v (#:identifier x) . l)
1276 (ref-x (refq v 'x) . l))
1277 ((_ v (#:call-obj x) . l)
1278 (ref-x (x v) . l))
1279 ((_ v (#:call x ...) . l)
1280 (ref-x (v x ...) . l))
1281 ((_ v (#:apply x ...) . l)
1282 (ref-x (apply v x ...) . l))
1283 ((_ v (#:apply x ...) . l)
1284 (ref-x (apply v x ...) . l))
1285 ((_ v (#:vecref x) . l)
1286 (ref-x (pylist-ref v x) . l))
1287 ((_ v (#:vecsub . x) . l)
1288 (ref-x (pylist-slice v . x) . l))))
1289
1290 (define-syntax set-x
1291 (syntax-rules ()
1292 ((_ v (a ... b) val)
1293 (set-x-2 (ref-x v a ...) b val))))
1294
1295 (define-syntax set-x-2
1296 (syntax-rules ()
1297 ((_ v (#:identifier x) val)
1298 (set v 'x val))
1299 ((_ v (#:vecref n) val)
1300 (pylist-set! v n val))
1301 ((_ v (#:vecsub x ...) val)
1302 (pylist-subset! v x ... val))))
1303