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