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