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