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