f97597ca8111c1288b2c9753695f0c9b50689a9d
[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 (rnrs bytevectors)
7 #:use-module (language python dict)
8 #:use-module (language python exceptions)
9 #:use-module (language python yield)
10 #:use-module (language python for)
11 #:use-module (language python try)
12 #:use-module (language python list)
13 #:use-module (language python string)
14 #:use-module (language python bytes)
15 #:use-module (language python number)
16 #:use-module (language python def)
17 #:use-module (language python module)
18 #:use-module ((language python with) #:select ())
19 #:use-module (ice-9 pretty-print)
20 #:export (comp))
21
22 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
23
24 (define-inlinable (C x) `(@@ (language python compile) ,x))
25 (define-inlinable (N x) `(@@ (language python number) ,x))
26 (define-inlinable (Y x) `(@@ (language python yield) ,x))
27 (define-inlinable (T x) `(@@ (language python try) ,x))
28 (define-inlinable (F x) `(@@ (language python for) ,x))
29 (define-inlinable (E x) `(@@ (language python exceptions) ,x))
30 (define-inlinable (L x) `(@@ (language python list) ,x))
31 (define-inlinable (S x) `(@@ (language python string) ,x))
32 (define-inlinable (B x) `(@@ (language python bytes) ,x))
33 (define-inlinable (Se x) `(@@ (language python set) ,x))
34 (define-inlinable (D x) `(@@ (language python def) ,x))
35 (define-inlinable (Di x) `(@@ (language python dict) ,x))
36 (define-inlinable (O x) `(@@ (oop pf-objects) ,x))
37 (define-inlinable (G x) `(@ (guile) ,x))
38 (define-inlinable (H x) `(@ (language python hash) ,x))
39 (define-inlinable (W x) `(@ (language python with) ,x))
40
41 (define s/d 'set!)
42
43 (define (pre) (warn "Patching guile will lead to way better experience use 'python.patch' on guile-2.2 e.g. (use-modules (language python guilemod))"))
44
45 (define-syntax clear-warning-data
46 (lambda (x)
47 (catch #t
48 (lambda ()
49 (fluid-set! (@@ (system base message) %dont-warn-list) '()))
50 (lambda x (pre)))
51 #f))
52
53 (define (dont-warn v)
54 (catch #t
55 (lambda ()
56 (fluid-set! (@@ (system base message) %dont-warn-list)
57 (cons v
58 (fluid-ref (@@ (system base message) %dont-warn-list)))))
59 (lambda x (values))))
60
61 (define *prefixes* (make-fluid '()))
62 (define (add-prefix id)
63 (catch #t
64 (lambda ()
65 (if (fluid-ref (@@ (system base compile) %in-compile))
66 (fluid-set! *prefixes* (cons id (fluid-ref *prefixes*)))
67 (begin
68 (when (not (module-defined? (current-module) '__prefixes__))
69 (module-define! (current-module)
70 '__prefixes__ (make-fluid '())))
71
72 (let ((p (module-ref (current-module) '__prefixes__)))
73 (fluid-set! p (cons id (fluid-ref p)))))))
74 (lambda x (values))))
75
76 (define (is-prefix? id)
77 (catch #t
78 (lambda ()
79 (if (fluid-ref (@@ (system base compile) %in-compile))
80 (member id (fluid-ref *prefixes*))
81 (if (not (module-defined? (current-module) '__prefixes__))
82 #f
83 (let ((p (module-ref (current-module) '__prefixes__)))
84 (member id (fluid-ref p))))))
85 (lambda x #f)))
86
87 (define-syntax call
88 (syntax-rules ()
89 ((_ (f) . l) (f . l))))
90
91 (define (fold f init l)
92 (if (pair? l)
93 (fold f (f (car l) init) (cdr l))
94 init))
95
96 (define (pr . x)
97 (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
98 (with-output-to-port port
99 (lambda ()
100 (pretty-print (syntax->datum x))))
101 (close port)
102 (car (reverse x)))
103
104 (define (pf x)
105 (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
106 (with-output-to-port port
107 (lambda () (pretty-print (syntax->datum x)) x))
108 (close port)
109 x)
110
111 (define (pp x)
112 (pretty-print (syntax->datum x))
113 x)
114
115 (define (gen-sel vs e item)
116 (match e
117 (#f item)
118 ((#:cfor for-e in-e cont)
119 `(,(F 'for) ((,@(map (g vs exp) for-e) : ,(exp vs in-e))) ()
120 ,(gen-sel vs cont item)))
121 ((#:cif cif cont)
122 `(if ,(exp vs cif)
123 ,(gen-sel vs cont item)))))
124
125 (define (union as vs)
126 (let lp ((as as) (vs vs))
127 (match as
128 ((x . as)
129 (if (member x vs)
130 (lp as vs)
131 (lp as (cons x vs))))
132 (()
133 vs))))
134
135 (define (diff as vs)
136 (let lp ((as as) (rs '()))
137 (match as
138 ((x . as)
139 (if (member x vs)
140 (lp as rs)
141 (lp as (cons x rs))))
142 (()
143 rs))))
144
145 (define (get-globals code)
146 (let lp ((vs (glob code '())) (rs (scope code '())))
147 (match vs
148 ((x . l)
149 (if (member x rs)
150 (lp l rs)
151 (lp l (cons x rs))))
152 (()
153 rs))))
154
155 (define (glob x vs)
156 (match x
157 ((#:global . l)
158 (let lp ((l l) (vs vs))
159 (match l
160 (((#:identifier v . _) . l)
161 (let ((s (string->symbol v)))
162 (if (member s vs)
163 (lp l vs)
164 (lp l (cons s vs)))))
165 (()
166 vs))))
167 ((x . y)
168 (glob y (glob x vs)))
169 (x vs)))
170
171 (define (scope x vs)
172 (match x
173 ((#:def f . _)
174 (union (list (exp '() f)) vs))
175
176 ((#:lambdef . _)
177 vs)
178
179 ((#:classdef f . _)
180 (union (list (exp '() f)) vs))
181
182 ((#:global . _)
183 vs)
184
185 ((#:import (#:name ((ids ...) . as)) ...)
186 (let lp ((ids ids) (as as) (vs vs))
187 (if (pair? as)
188 (lp (cdr ids) (cdr as)
189 (let ((as (car as))
190 (ids (car ids)))
191 (union vs (list (exp '() (if as as (car ids)))))))
192 vs)))
193
194 ((#:expr-stmt l (#:assign u))
195 (union (fold (lambda (x s)
196 (match x
197 ((#:test (#:power v2 v1 () . _) . _)
198 (if v2
199 (union
200 (union (list (exp '() v1))
201 (list (exp '() v2)))
202 s)
203 (union (list (exp '() v1)) s)))
204 (_ s)))
205 '()
206 l)
207 vs))
208
209 ((x . y)
210 (scope y (scope x vs)))
211 (_ vs)))
212
213 (define (defs x vs)
214 (match x
215 ((#:def (#:identifier f) . _)
216 (union (list (string->symbol f)) vs))
217 ((#:lambdef . _)
218 vs)
219 ((#:class . _)
220 vs)
221 ((#:global . _)
222 vs)
223 ((#:import (#:name ((ids ...) . as)) ...)
224 (let lp ((ids ids) (as as) (vs vs))
225 (if (pair? as)
226 (lp (cdr ids) (cdr as)
227 (let ((as (car as))
228 (ids (car ids)))
229 (union vs (list (exp '() (if as as (car ids)))))))
230 vs)))
231 ((x . y)
232 (defs y (defs x vs)))
233 (_ vs)))
234
235 (define (gen-yield f)
236 (string->symbol
237 (string-append
238 (symbol->string f)
239 ".yield")))
240
241 (define (g vs e)
242 (lambda (x) (e vs x)))
243
244 (define return (make-fluid 'error-return))
245
246 (define-syntax-rule (<< x y) (ash x y))
247 (define-syntax-rule (>> x y) (ash x (- y)))
248
249 (define-syntax-rule (mkfast ((a) v) ...)
250 (let ((h (make-hash-table)))
251 (hash-set! h 'a v)
252 ...
253 h))
254
255 (define (fast-ref x)
256 (aif it (assoc x `((__class__ . ,(O 'py-class))))
257 (cdr it)
258 #f))
259
260 (define fasthash
261 (mkfast
262 ;; General
263 ((__init__) (O 'py-init))
264 ((__getattr__) (O 'getattr))
265 ((__setattr__) (O 'setattr))
266 ((__delattr__) (O 'delattr))
267 ((__ne__) (O 'ne))
268 ((__eq__) (O 'equal?))
269 ((__repr__) (O 'repr))
270
271 ;;iterators
272 ((__iter__) (F 'wrap-in))
273 ((__next__) (F 'next))
274 ((__send__) (Y 'send))
275 ((__exception__) (Y 'sendException))
276 ((__close__) (Y 'sendClose))
277
278 ;; Numerics
279 ((__index__) (N 'py-index))
280 ((__add__ ) (N '+))
281 ((__mul__ ) (N '*))
282 ((__sub__ ) (N '-))
283 ((__radd__ ) (N 'r+))
284 ((__rmul__ ) (N 'r*))
285 ((__rsub__ ) (N 'r-))
286 ((__neg__ ) (N '-))
287 ((__le__ ) (N '<))
288 ((__lt__ ) (N '<=))
289 ((__ge__ ) (N '>))
290 ((__gt__ ) (N '>=))
291 ((__abs__ ) (N 'py-abs))
292 ((__pow__ ) (N 'expt))
293 ((__rpow__ ) (N 'rexpt))
294 ((__truediv__) (N 'py-/))
295 ((__rtruediv__) (N 'py-r/))
296 ((__and__) (N 'py-logand))
297 ((__or__) (N 'py-logior))
298 ((__xor__) (N 'py-logxor))
299 ((__rand__) (N 'py-rlogand))
300 ((__ror__) (N 'py-rlogior))
301 ((__rxor__) (N 'py-rlogxor))
302 ((__divmod__) (N 'py-divmod))
303 ((__rdivmod__) (N 'py-rdivmod))
304 ((__invert__) (N 'py-lognot))
305 ((__int__) (N 'mk-int))
306 ((__float__) (N 'mk-float))
307 ((__lshift__) (N 'py-lshift))
308 ((__rshift__) (N 'py-rshift))
309 ((__rlshift__) (N 'py-rlshift))
310 ((__rrshift__) (N 'py-rrshift))
311 ((as_integer_ratio) (N 'py-as-integer-ratio))
312 ((conjugate) (N 'py-conjugate))
313 ((denominator) (N 'py-denominator))
314 ((numerator) (N 'py-numerator))
315 ((fromhex) (N 'py-fromhex))
316 ((hex) (N 'py-hex))
317 ((imag) (N 'py-imag))
318 ((is_integer) (N 'py-is-integer))
319 ((real) (N 'py-real))
320 ((__mod__) (N 'py-mod))
321 ((__rmod__) (N 'py-rmod))
322 ((__floordiv__) (N 'py-floordiv))
323 ((__rfloordiv__)(N 'py-rfloordiv))
324 ((__hex__) (N 'hex))
325
326 ;; Lists
327 ((append) (L 'pylist-append!))
328 ((count) (L 'pylist-count))
329 ((extend) (L 'pylist-extend!))
330 ((index) (L 'pylist-index))
331 ((pop) (L 'pylist-pop!))
332 ((insert) (L 'pylist-insert!))
333 ((remove) (L 'pylist-remove!))
334 ((reverse) (L 'pylist-reverse!))
335 ((sort) (L 'pylist-sort!))
336 ((__len__) (L 'len))
337 ((__contains__) (L 'in))
338 ((__delitem__) (L 'pylist-delete!))
339 ((__delslice__) (L 'pylist-delslice))
340 ((__setitem__) (L 'pylist-set!))
341
342 ;; String
343 ((format) (S 'py-strformat))
344 ((format_map) (S 'py-format-map))
345 ((capitalize) (S 'py-capitalize))
346 ((center) (S 'py-center ))
347 ((endswith) (S 'py-endswith))
348 ((expandtabs) (S 'py-expandtabs))
349 ((find) (S 'py-find ))
350 ((rfind) (S 'py-rfind ))
351 ((isalnum) (S 'py-isalnum))
352 ((isalpha) (S 'py-isalpha))
353 ((isdigit) (S 'py-isdigit))
354 ((islower) (S 'py-islower))
355 ((isspace) (S 'py-isspace))
356 ((isupper) (S 'py-isupper))
357 ((istitle) (S 'py-istitle))
358 ((isidentifier) (S 'py-identifier))
359 ((join) (S 'py-join ))
360 ((ljust) (S 'py-join ))
361 ((rljust) (S 'py-rljust ))
362 ((lower) (S 'py-lower ))
363 ((upper) (S 'py-upper ))
364 ((lstrip) (S 'py-lstrip ))
365 ((rstrip) (S 'py-rstrip ))
366 ((partition) (S 'py-partition))
367 ((replace) (S 'py-replace))
368 ((strip) (S 'py-strip ))
369 ((title) (S 'py-title ))
370 ((rpartition) (S 'py-rpartition))
371 ((rindex) (S 'py-rindex ))
372 ((split) (S 'py-split ))
373 ((rsplit) (S 'py-rsplit ))
374 ((splitlines) (S 'py-splitlines))
375 ((startswith) (S 'py-startswith))
376 ((swapcase) (S 'py-swapcase))
377 ((translate) (S 'py-translate))
378 ((zfill) (S 'py-zfill))
379
380 ;;DICTS
381 ((copy) (Di 'py-copy))
382 ((fromkeys) (Di 'py-fromkeys))
383 ((get) (Di 'py-get))
384 ((has_key) (Di 'py-has_key))
385 ((items) (Di 'py-items))
386 ((iteritems) (Di 'py-iteritems))
387 ((iterkeys) (Di 'py-iterkeys))
388 ((itervalues) (Di 'py-itervalues))
389 ((keys) (Di 'py-keys))
390 ((values) (Di 'py-values))
391 ((popitem) (Di 'py-popitem))
392 ((setdefault) (Di 'py-setdefault))
393 ((update) (Di 'py-update))
394 ((clear) (Di 'py-clear))
395 ((__hash__) (H 'py-hash))))
396
397
398 (define (fastfkn x) (hash-ref fasthash x))
399
400 (define (get-kwarg vs arg)
401 (let lp ((arg arg) (l '()) (kw '()))
402 (match arg
403 (((#:= a b) . arg)
404 (lp arg
405 l
406 (cons*
407 (exp vs b)
408 (symbol->keyword
409 (exp vs a))
410 kw)))
411 ((x . arg)
412 (lp arg (cons (exp vs x) l) kw))
413 (()
414 (values (reverse l) (reverse kw))))))
415
416 (define (get-kwarg-def vs arg)
417 (let lp ((arg arg))
418 (match arg
419 ((((x . _) #f) . arg)
420 (cons (exp vs x)
421 (lp arg)))
422 ((((a . _) b) . arg)
423 (cons (list '= (exp vs a) (exp vs b))
424 (lp arg)))
425 (()
426 '()))))
427
428 (define (kw->li dict)
429 (for ((k v : dict)) ((l '()))
430 (cons* v (symbol->keyword (string->symbol k)) l)
431 #:final
432 (reverse l)))
433
434 (define (arglist->pkw . l)
435 (let lp ((l l) (r '()))
436 (if (pair? l)
437 (let ((x (car l)))
438 (if (keyword? x)
439 (cons (reverse r) l)
440 (lp (cdr l) (cons x r))))
441 (cons (reverse l) '()))))
442
443 (define (get-addings vs x)
444 (match x
445 (() '())
446 ((x . l)
447 (let ((is-fkn? (match l
448 ((#f) #t)
449 (((#:arglist . _) . _)
450 #t)
451 (_
452 #f))))
453
454 (cons
455 (match x
456 ((#:identifier . _)
457 (let* ((tag (exp vs x))
458 (xs (gensym "xs"))
459 (fast (fastfkn tag))
460 (is-fkn? (aif it (and is-fkn? fast)
461 `(#:call-obj (lambda (e)
462 (lambda ,xs
463 (apply ,it e ,xs))))
464 #f)))
465 (if is-fkn?
466 is-fkn?
467 (if fast
468 `(#:fastfkn-ref ,fast ',tag)
469 (aif it (fast-ref tag)
470 `(#:fast-id ,it ',tag)
471 `(#:identifier ',tag))))))
472
473 ((#:arglist args apply kw)
474 (call-with-values (lambda () (get-kwarg vs args))
475 (lambda (args kwarg)
476 (if (or kw apply)
477 `(#:apply ,@args ,@kwarg
478 ,`(,(L 'to-list)
479 (,(G 'append)
480 (if apply (exp vs apply) ''())
481 (if kw
482 '(,(C 'kw->li) (exp vs kw))
483 ''()))))
484 `(#:call ,@args ,@kwarg)))))
485
486 ((#:subscripts (n #f #f))
487 `(#:vecref ,(exp vs n)))
488
489 ((#:subscripts (n1 n2 n3))
490 (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
491 `(#:vecsub
492 ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3)))))
493
494 ((#:subscripts (n #f #f) ...)
495 `(#:array-ref ,@ (map (lambda (n)
496 (exp vs n))
497 n)))
498
499 ((#:subscripts (n1 n2 n3) ...)
500 (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
501 `(#:arraysub
502 ,@(map (lambda (x y z)
503 `(,(exp vs x) ,(exp vs y) ,(exp vs z)))
504 n1 n2 n3))))
505
506 (_ (error "unhandled addings")))
507 (get-addings vs l))))))
508
509 (define-syntax-rule (setwrap u)
510 (call-with-values (lambda () u)
511 (case-lambda
512 ((x) x)
513 (x x))))
514
515 (define (make-set vs op x u)
516 (define (tr-op op)
517 (match op
518 ("+=" '+)
519 ("-=" '-)
520 ("*=" '*)
521 ("/=" '/)
522 ("%=" 'modulo)
523 ("&=" 'logand)
524 ("|=" 'logior)
525 ("^=" 'logxor)
526 ("**=" 'expt)
527 ("<<=" (C '<<))
528 (">>=" (C '>>))
529 ("//=" 'floor-quotient)))
530
531 (match x
532 ((#:test (#:power kind v addings . _) . _)
533 (let* ((v (exp vs v))
534 (v.add (if (is-prefix? v)
535 (let ((w (symbol->string (exp vs (car addings)))))
536 (cons (string-append (symbol->string v) "." w)
537 (cdr addings)))
538 (cons v addings)))
539 (v (car v.add))
540 (addings (cdr v.add))
541 (addings (get-addings vs addings))
542 (p.a (match kind
543 (#f (cons #f '()))
544 ((v add)
545 (if (is-prefix? v)
546 (let ((w (symbol->string (exp vs (car add)))))
547 (cons (string-append (symbol->string v) "." w)
548 (cdr add)))
549 (cons (exp vs v) add)))))
550 (p (car p.a))
551 (pa (cdr p.a))
552 (pa (get-addings vs pa)))
553 (define q (lambda (x) `',x))
554 (if kind
555 (if (not p)
556 (if (null? addings)
557 (if op
558 `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
559 `(,s/d ,v (,(C 'setwrap) ,u)))
560 (if op
561 `(,s/d ,(exp vs kind)
562 (,(C 'fset-x) ,v ,addings
563 (,(C 'setwrap)
564 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
565
566 `(,s/d ,(exp vs kind)
567 (,(C 'fset-x) ,v ,addings
568 (,(C 'setwrap) ,u)))))
569
570 (let ((pre (if (equal? p v)
571 (let lp ((pa pa) (ad addings) (r '()))
572 (if (and (pair? pa) (pair? ad))
573 (let ((px (car pa)) (ax (car ad)))
574 (if (equal? px ax)
575 (lp (cdr pa) (cdr ad) (cons px r))
576 #f))
577 (if (pair? pa)
578 #f
579 (reverse r))))
580 #f)))
581 (if (null? addings)
582 (if op
583 `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
584 `(,s/d ,v (,(C 'setwrap) ,u)))
585 (if op
586 `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
587 (,(C 'setwrap)
588 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
589
590 `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
591 (,(C 'setwrap) ,u))))))
592
593 (if (null? addings)
594 (if op
595 `(,s/d ,v (,(C 'setwrap)
596 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
597 `(,s/d ,v (,(C 'setwrap)
598 ,u)))
599 `(,(C 'set-x)
600 ,v
601 ,addings
602 (,(C 'setwrap)
603 ,(if op
604 `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
605 u)))))))))
606
607 (define (filter-defs x)
608 (match (let lp ((x x))
609 (match x
610 ((('begin . l))
611 (lp (cons 'begin l)))
612 (('begin . l)
613 (let lp ((l l))
614 (match l
615 ((('values) . l)
616 (lp l))
617 ((x . l)
618 (cons x (lp l)))
619 (x x))))))
620 (('begin)
621 '())
622 (x x)))
623
624 (define is-class? (make-fluid #f))
625 (define (gen-yargs vs x)
626 (match (pr 'yarg x) ((#:list args)
627 (map (g vs exp) args))))
628
629 (define inhibit-finally #f)
630 (define decorations (make-fluid '()))
631 (define tagis (make-hash-table))
632 (define-syntax-rule (gen-table x vs (tag code ...) ...)
633 (begin
634 (hash-set! tagis tag
635 (lambda (x vs)
636 (match x code ...)))
637
638 ...))
639
640 (gen-table x vs
641 (#:power
642 ((_ _ (x) () . #f)
643 (exp vs x))
644
645 ((_ _ x () . #f)
646 (exp vs x))
647
648 ((_ #f vf trailer . **)
649 (let* ((vf (exp vs vf))
650 (vf.tr (if (is-prefix? vf)
651 (cons
652 (string->symbol
653 (string-append
654 (symbol->string vf)
655 "."
656 (symbol->string (exp vs (car trailer)))))
657 (cdr trailer))
658 (cons vf trailer)))
659 (vf (car vf.tr))
660 (trailer (cdr vf.tr)))
661 (define (pw x)
662 (if **
663 `(expt ,x ,(exp vs **))
664 x))
665 (pw
666 (let ((trailer (get-addings vs trailer)))
667 `(,(C 'ref-x) ,vf ,@trailer))))))
668
669 (#:identifier
670 ((#:identifier x . _)
671 (string->symbol x)))
672
673 (#:decorated
674 ((_ (l ...))
675 (fluid-set! decorations (map (g vs exp) l))
676 '(values)))
677
678 (#:string
679 ((_ l)
680 (string-join l "")))
681
682 (#:bytes
683 ((_ l)
684 (let* ((n (let lp ((l l) (s 0))
685 (if (pair? l)
686 (lp (cdr l) (+ s (length (car l))))
687 s)))
688 (b (make-bytevector n)))
689 (let lp ((l l) (i 0))
690 (if (pair? l)
691 (let lp2 ((u (car l)) (i i))
692 (if (pair? u)
693 (begin
694 (bytevector-u8-set! b i (car u))
695 (lp2 (cdr u) (+ i 1)))
696 (lp (cdr l) i)))))
697 `(,(B 'bytes) ,b))))
698
699
700 (#:+
701 ((_ . l)
702 (cons '+ (map (g vs exp) l))))
703
704 (#:-
705 ((_ . l)
706 (cons '- (map (g vs exp) l))))
707
708 (#:*
709 ((_ . l)
710 (cons '* (map (g vs exp) l))))
711
712 (#:/
713 ((_ . l)
714 (cons (N 'py-/) (map (g vs exp) l))))
715
716 (#:%
717 ((_ . l)
718 (cons (N 'py-mod) (map (g vs exp) l))))
719
720 (#://
721 ((_ . l)
722 (cons (N 'py-floordiv) (map (g vs exp) l))))
723
724 (#:<<
725 ((_ . l)
726 (cons (N 'py-lshift) (map (g vs exp) l))))
727
728 (#:>>
729 ((_ . l)
730 (cons (N 'py-rshift) (map (g vs exp) l))))
731
732 (#:u~
733 ((_ x)
734 (list (N 'py-lognot) (exp vs x))))
735
736 (#:u-
737 ((_ x)
738 (list '- (exp vs x))))
739
740 (#:u+
741 ((_ x)
742 (list '+ (exp vs x))))
743
744 (#:band
745 ((_ . l)
746 (cons (N 'py-logand) (map (g vs exp) l))))
747
748 (#:bxor
749 ((_ . l)
750 (cons (N 'py-logxor) (map (g vs exp) l))))
751
752 (#:bor
753 ((_ . l)
754 (cons (N 'py-logior) (map (g vs exp) l))))
755
756 (#:not
757 ((_ x)
758 (list 'not (exp vs x))))
759
760 (#:or
761 ((_ . x)
762 (cons 'or (map (g vs exp) x))))
763
764 (#:and
765 ((_ . x)
766 (cons 'and (map (g vs exp) x))))
767
768 (#:test
769 ((_ e1 #f)
770 (exp vs e1))
771
772 ((_ e1 e2 e3)
773 (list 'if (exp vs e2) (exp vs e1) (exp vs e3))))
774
775 (#:del
776 ;;We don't delete variables
777 ((_ (#:power #f base () . #f))
778 '(void))
779
780 ((_ (#:power #f base (l ... fin) . #f))
781 (let ((add (get-addings vs l))
782 (fin (get-addings vs (list fin)))
783 (f (exp vs base)))
784 `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin))))
785
786 (#:with
787 ((_ (l ...) code)
788 (let ((l (map (lambda (x)
789 (match x
790 ((a b) (list (exp vs a) (exp vs b)))
791 ((b) (list (exp vs b)))))
792 l)))
793 `(,(W 'with) ,l ,(exp vs code)))))
794
795 (#:if
796 ((_ test a ((tests . as) ...) . else)
797 `(,(G 'cond)
798 (,(exp vs test) ,(exp vs a))
799 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
800 ,@(if else `((else ,(exp vs else))) '()))))
801
802 (#:suite
803 ((_ . l) (cons 'begin (map (g vs exp) l))))
804
805 (#:classdef
806 ((_ class parents defs)
807 (with-fluids ((is-class? #t))
808 (let ()
809 (let* ((decor (let ((r (fluid-ref decorations)))
810 (fluid-set! decorations '())
811 r))
812 (class (exp vs class))
813 (parents (match parents
814 (() #f)
815 (#f #f)
816 ((#:arglist . _)
817 (get-addings vs (list parents))))))
818 `(define ,class
819 (,(C 'class-decor) ,decor
820 (,(C 'with-class) ,class
821 (,(C 'mk-p-class)
822 ,class
823 ,(if parents
824 `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents)
825 `(,(G 'cons) '() '()))
826 ,@(match (filter-defs (exp vs defs))
827 (('begin . l)
828 l)
829 ((('begin . l))
830 l)
831 (l l)))))))))))
832
833 (#:verb
834 ((_ x) x))
835
836 (#:scm
837 ((_ (#:string _ s)) (with-input-from-string s read)))
838
839 (#:import
840 ((_ (#:from (() . nm) . #f))
841 `(use-modules (language python module ,@(map (lambda (nm) (exp vs nm))
842 nm))))
843 ((_ (#:from (() . nm) . l))
844 `(use-modules ((language python module ,@(map (lambda (nm) (exp vs nm))
845 nm))
846 #:select ,(map (lambda (x)
847 (match x
848 ((a . #f)
849 (exp vs a))
850 ((a . b)
851 (cons (exp vs a) (exp vs b)))))
852 l))))
853
854
855 ((_ (#:name ((ids ...) . as)) ...)
856 `(begin
857 ,@(map
858 (lambda (ids as)
859 (let ((path (map (g vs exp) ids)))
860 (if as
861 (exp
862 vs
863 `(#:expr-stmt
864 ((#:test (#:power #f ,as ())))
865 (#:assign
866 ((#:verb
867 ((@ (language python module) import)
868 ((@ (language python module) Module)
869 ',(reverse (append '(language python module) path))
870 ',(reverse path))
871 ,(exp vs as)))))))
872 (exp
873 vs
874 `(#:expr-stmt
875 ((#:test (#:power #f ,(car ids) ())))
876 (#:assign
877 ((#:verb
878 ((@ (language python module) import)
879 ((@ (language python module) Module)
880 ',(append '(language python module) path))
881 ,(exp vs (car ids)))))))))))
882 ids as))))
883
884 (#:for
885 ((_ e in code . #f)
886 (=> next)
887 (match e
888 (((#:power #f (#:identifier x . _) () . #f))
889 (match in
890 (((#:test power . _))
891 (match power
892 ((#:power #f
893 (#:identifier "range" . _)
894 ((#:arglist arglist . _))
895 . _)
896 (match arglist
897 ((arg)
898 (let ((v (gensym "v"))
899 (x (string->symbol x))
900 (lp (gensym "lp")))
901 `(let ((,v ,(exp vs arg)))
902 (let ,lp ((,x 0))
903 (if (< ,x ,v)
904 (begin
905 ,(exp vs code)
906 (,lp (+ ,x 1))))))))
907 ((arg1 arg2)
908 (let ((v1 (gensym "va"))
909 (v2 (gensym "vb"))
910 (lp (gensym "lp")))
911 `(let ((,v1 ,(exp vs arg1))
912 (,v2 ,(exp vs arg2)))
913 (let ,lp ((,x ,v1))
914 (if (< ,x ,v2)
915 (begin
916 ,(exp vs code)
917 (,lp (+ ,x 1))))))))
918 ((arg1 arg2 arg3)
919 (let ((v1 (gensym "va"))
920 (v2 (gensym "vb"))
921 (st (gensym "vs"))
922 (lp (gensym "lp")))
923 `(let ((,v1 ,(exp vs arg1))
924 (,st ,(exp vs arg2))
925 (,v2 ,(exp vs arg3)))
926 (if (> st 0)
927 (let ,lp ((,x ,v1))
928 (if (< ,x ,v2)
929 (begin
930 ,(exp vs code)
931 (,lp (+ ,x ,st)))))
932 (if (< st 0)
933 (let ,lp ((,x ,v1))
934 (if (> ,x ,v2)
935 (begin
936 ,(exp vs code)
937 (,lp (+ ,x ,st)))))
938 (error "range with step 0 not allowed"))))))
939 (_ (next))))
940 (_ (next))))
941 (_ (next))))
942 (_ (next))))
943
944 ((_ es in code . else)
945 (let* ((es2 (map (g vs exp) es))
946 (vs2 (union es2 vs))
947 (code2 (exp vs2 code))
948 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
949 (else2 (if else (exp vs2 else) #f))
950 (in2 (map (g vs exp) in)))
951 (list (C 'for) es2 in2 code2 else2 p))))
952
953
954 (#:while
955 ((_ test code . #f)
956 (let ((lp (gensym "lp")))
957 `(let ,lp ()
958 (if ,(exp vs test)
959 (begin
960 ,(exp vs code)
961 (,lp))))))
962
963 ((_ test code else)
964 (let ((lp (gensym "lp")))
965 `(let ,lp ()
966 (if test
967 (begin
968 ,(exp vs code)
969 (,lp))
970 ,(exp vs else))))))
971
972 (#:try
973 ((_ x (or #f ()) #f . fin)
974 (if fin
975 `(,(T 'try) ,(exp vs x) #:finally (lambda () fin))
976 (exp vs x)))
977
978
979 ((_ x exc else . fin)
980 `(,(T 'try) ,(exp vs x)
981 ,@(let lp ((exc exc) (r (if else (exp vs else) '())))
982 (match exc
983 ((((test . #f) code) . exc)
984 (lp exc (cons `(#:except ,(exp vs code)) r)))
985
986 ((((test . as) code) . exc)
987 (let ((l (gensym "l")))
988 (lp exc
989 (cons
990 `(#:except ,(exp vs test) => (lambda (,(exp vs as) . ,l)
991 ,(exp vs code)))
992 r))))
993 (()
994 (reverse r))))
995 ,@(if fin `(#:finally (lambda () ,(exp vs fin))) '()))))
996
997 (#:subexpr
998 ((_ . l)
999 (exp vs l)))
1000
1001 (#:raise
1002 ((_ #f . #f)
1003 `(,(T 'raise) (,(O 'Exception))))
1004
1005 ((_ code . #f)
1006 `(,(T 'raise) ,(exp vs code)))
1007
1008 ((_ code . from)
1009 (let ((o (gensym "o"))
1010 (c (gensym "c")))
1011 `(,(T 'raise)
1012 (let ((,c ,(exp vs code)))
1013 (let ((,o (if (,(O 'pyclass?) ,c)
1014 (,c)
1015 ,c)))
1016 (,(O 'set) ,o '__cause__ ,(exp vs from))
1017 ,o))))))
1018
1019
1020 (#:yield
1021 ((_ args)
1022 (let ((f (gensym "f")))
1023 `(begin
1024 (fluid-set! ,(Y 'in-yield) #t)
1025 (let ((,f (scm.yield ,@(gen-yargs vs args))))
1026 (,f)))))
1027
1028
1029 ((_ f args)
1030 (let ((f (gen-yield (exp vs f)))
1031 (g (gensym "f")))
1032 `(begin
1033 (set! ,(C 'inhibit-finally) #t)
1034 (let ((,g (,f ,@(gen-yargs vs args))))
1035 (,g))))))
1036
1037 (#:def
1038 ((_ f
1039 (#:types-args-list
1040 args
1041 *e **e)
1042 #f
1043 code)
1044 (let* ((decor (let ((r (fluid-ref decorations)))
1045 (fluid-set! decorations '())
1046 r))
1047 (args (get-kwarg-def vs args))
1048 (c? (fluid-ref is-class?))
1049 (f (exp vs f))
1050 (y? (is-yield f #f code))
1051 (r (gensym "return"))
1052 (*f (match *e
1053 (((e . #f) ()) (list (list '* (exp vs e))))
1054 (#f '())))
1055 (dd2 (match *e
1056 (((e . #f) ()) (list (exp vs e)))
1057 (#f '())))
1058 (**f (match **e
1059 ((e . #f) (list (list '** (exp vs e))))
1060 (#f '())))
1061 (dd3 (match **e
1062 ((e . #f) (list (exp vs e)))
1063 (#f '())))
1064 (as (map (lambda (x) (match x
1065 (('= a _) a)
1066 (a a)))
1067 args))
1068 (ab (gensym "ab"))
1069 (vs (union dd3 (union dd2 (union as vs))))
1070 (ns (scope code vs))
1071 (df (defs code '()))
1072 (ex (gensym "ex"))
1073 (y 'scm.yield)
1074 (y.f (gen-yield f))
1075 (ls (diff (diff ns vs) df)))
1076
1077 (define (mk code)
1078 `(let-syntax ((,y (syntax-rules ()
1079 ((_ . args)
1080 (abort-to-prompt ,ab . args))))
1081 (,y.f (syntax-rules ()
1082 ((_ . args)
1083 (abort-to-prompt ,ab . args)))))
1084 ,code))
1085
1086 (with-fluids ((is-class? #f))
1087 (if c?
1088 (if y?
1089 `(define ,f
1090 (,(C 'def-decor) ,decor
1091 (,(C 'def-wrap) ,y? ,f ,ab
1092 (,(D 'lam) (,@args ,@*f ,@**f)
1093 (,(C 'with-return) ,r
1094 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
1095 (,(C 'with-self) ,c? ,args
1096 ,(with-fluids ((return r))
1097 (exp ns code))))))))))
1098
1099 `(define ,f
1100 (,(C 'def-decor) ,decor
1101 (,(D 'lam) (,@args ,@*f ,@**f)
1102 (,(C 'with-return) ,r
1103 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
1104 (,(C 'with-self) ,c? ,args
1105 ,(with-fluids ((return r))
1106 (exp ns code))))))))))
1107
1108 (if y?
1109 `(define ,f
1110 (,(C 'def-decor) ,decor
1111 (,(C 'def-wrap) ,y? ,f ,ab
1112 (,(D 'lam) (,@args ,@*f ,@**f)
1113 (,(C 'with-return) ,r
1114 (let ,(map (lambda (x) (list x #f)) ls)
1115 (,(C 'with-self) ,c? ,args
1116 ,(with-fluids ((return r))
1117 (mk
1118 (exp ns code))))))))))
1119 `(define ,f
1120 (,(C 'def-decor) ,decor
1121 (,(D 'lam) (,@args ,@*f ,@**f)
1122 (,(C 'with-return) ,r
1123 (let ,(map (lambda (x) (list x #f)) ls)
1124 (,(C 'with-self) ,c? ,args
1125 ,(with-fluids ((return r))
1126 (exp ns code))))))))))))))
1127
1128 (#:global
1129 ((_ . _)
1130 '(values)))
1131
1132 (#:list
1133 ((_ x (and e (#:cfor . _)))
1134 (let ((l (gensym "l")))
1135 `(let ((,l (,(L 'to-pylist) '())))
1136 ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
1137 ,l)))
1138
1139 ((_ . l)
1140 (list (L 'to-pylist) (let lp ((l l))
1141 (match l
1142 ((or () #f) ''())
1143 (((#:starexpr #:power #f (#:list . l) . _) . _)
1144 (lp l))
1145 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1146 (lp l))
1147 (((#:starexpr . l) . _)
1148 `(,(L 'to-list) ,(exp vs l)))
1149 ((x . l)
1150 `(cons ,(exp vs x) ,(lp l))))))))
1151 (#:tuple
1152 ((_ x (and e (#:cfor . _)))
1153 (let ((l (gensym "l")))
1154 `(let ((,l '()))
1155 ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
1156 (reverse ,l))))
1157
1158 ((_ . l)
1159 (let lp ((l l))
1160 (match l
1161 (() ''())
1162 (((#:starexpr #:power #f (#:list . l) . _) . _)
1163 (lp l))
1164 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1165 (lp l))
1166 (((#:starexpr . l) . _)
1167 `(,(L 'to-list) ,(exp vs l)))
1168 ((x . l)
1169 `(cons ,(exp vs x) ,(lp l)))))))
1170
1171 (#:lambdef
1172 ((_ v e)
1173 (list `lambda v (exp vs e))))
1174
1175 (#:stmt
1176 ((_ l)
1177 (if (> (length l) 1)
1178 (cons 'values (map (g vs exp) l))
1179 (exp vs (car l)))))
1180
1181 (#:expr-stmt
1182 ((_ (l ...) (#:assign))
1183 (let ((l (map (g vs exp) l)))
1184 (if (= (length l) 1)
1185 (car l)
1186 `(,(G 'values) ,@l))))
1187
1188 ((_ l type)
1189 (=> fail)
1190 (call-with-values
1191 (lambda () (match type
1192 ((#:assign u)
1193 (values #f u))
1194 ((#:augassign op u)
1195 (values op u))
1196 (_ (fail))))
1197
1198 (lambda (op u)
1199 (cond
1200 ((= (length l) (length u))
1201 (if (= (length l) 1)
1202 `(begin
1203 ,(make-set vs op (car l) (exp vs (car u)))
1204 (values))
1205 `(begin
1206 @,(map (lambda (l u) (make-set vs op l u))
1207 l
1208 (map (g vs exp) u))
1209 (values))))
1210
1211 ((and (= (length u) 1) (not op))
1212 (let ((vars (map (lambda (x) (gensym "v")) l))
1213 (q (gensym "q"))
1214 (f (gensym "f")))
1215 `(begin
1216 (call-with-values (lambda () ,(exp vs (car u)))
1217 (letrec ((,f
1218 (case-lambda
1219 ((,q)
1220 (if (pair? ,q)
1221 (apply ,f ,q)
1222 (apply ,f (,(L 'to-list) ,q))))
1223 (,vars
1224 ,@(map (lambda (l v) (make-set vs op l v))
1225 l vars)))))
1226 ,f))
1227 (values))))
1228
1229 ((and (= (length l) 1) (not op))
1230 `(begin
1231 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
1232 (values)))))))
1233
1234 ((_
1235 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
1236 (#:assign (l)))
1237 (let ((s (string->symbol v)))
1238 `(,s/d ,s ,(exp vs l)))))
1239
1240
1241 (#:return
1242 ((_ . x)
1243 `(,(fluid-ref return) ,@(map (g vs exp) x))))
1244
1245 (#:dict
1246 ((_ . #f)
1247 `(,(Di 'make-py-hashtable)))
1248
1249 ((_ (#:e k . v) (and e (#:cfor . _)))
1250 (let ((dict (gensym "dict")))
1251 `(let ((,dict (,(Di 'make-py-hashtable))))
1252 ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1253 ,dict)))
1254
1255 ((_ (#:e k . v) ...)
1256 (let ((dict (gensym "dict")))
1257 `(let ((,dict (,(Di 'make-py-hashtable))))
1258 ,@(map (lambda (k v)
1259 `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1260 k v)
1261 ,dict)))
1262
1263 ((_ k (and e (#:cfor . _)))
1264 (let ((dict (gensym "dict")))
1265 `(let ((,dict (,(Se 'set))))
1266 ,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k)))
1267 ,dict)))
1268
1269 ((_ k ...)
1270 (let ((set (gensym "dict")))
1271 `(let ((,set (,(Se 'set))))
1272 ,@(map (lambda (k)
1273 `((,(O 'ref) ,set 'add) ,(exp vs k)))
1274 k)
1275 ,set))))
1276
1277
1278 (#:comp
1279 ((_ x #f)
1280 (exp vs x))
1281
1282 ((_ x (op . y))
1283 (define (tr op x y)
1284 (match op
1285 ((or "<" ">" "<=" ">=")
1286 (list (G (string->symbol op)) x y))
1287 ("!=" (list (G 'not) (list (O 'equal?) x y)))
1288 ("==" (list (O 'equal?) x y))
1289 ("is" (list (G 'eq?) x y))
1290 ("isnot" (list (G 'not) (list (G 'eq?) x y)))
1291 ("in" (list (L 'in) x y))
1292 ("notin" (list (G 'not) (list (L 'in) x y)))
1293 ("<>" (list (G 'not) (list (O 'equal?) x y)))))
1294 (tr op (exp vs x) (exp vs y)))))
1295
1296 (define (exp vs x)
1297 (match (pr x)
1298 ((e)
1299 (exp vs e))
1300 ((tag . l)
1301 ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))
1302
1303 (#:True #t)
1304 (#:None (E 'None))
1305 (#:null ''())
1306 (#:False #f)
1307 (#:pass `(values))
1308 (#:break
1309 (C 'break))
1310 (#:continue
1311 (C 'continue))
1312 (x x)))
1313
1314 (define-syntax-rule (define- n x) (define! 'n x))
1315
1316 (define (comp x)
1317 (define start
1318 (match (pr 'start x)
1319 (((#:stmt
1320 ((#:expr-stmt
1321 ((#:test
1322 (#:power #f
1323 (#:identifier "module" . _)
1324 ((#:arglist arglist #f #f))
1325 . #f) #f))
1326 (#:assign)))) . _)
1327 (let ()
1328 (define args
1329 (map (lambda (x)
1330 (exp '() x))
1331 arglist))
1332
1333 `((,(G 'define-module)
1334 (language python module ,@args)
1335 #:use-module (language python module python)))))
1336 (x '())))
1337
1338 (if (fluid-ref (@@ (system base compile) %in-compile))
1339 (with-fluids ((*prefixes* '()))
1340 (if (fluid-ref (@@ (system base compile) %in-compile))
1341 (set! s/d 'set!)
1342 (set! s/d (C 'define-)))
1343
1344 (if (pair? start)
1345 (set! x (cdr x)))
1346
1347 (let ((globs (get-globals x)))
1348 `(begin
1349 ,@start
1350 ,(C 'clear-warning-data)
1351 (fluid-set! (@@ (system base message) %dont-warn-list) '())
1352 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1353 ,@(map (g globs exp) x))))
1354 (begin
1355 (if (fluid-ref (@@ (system base compile) %in-compile))
1356 (set! s/d 'set!)
1357 (set! s/d (C 'define-)))
1358
1359 (if (pair? start)
1360 (set! x (cdr x)))
1361
1362 (let ((globs (get-globals x)))
1363 `(begin
1364 ,@start
1365 ,(C 'clear-warning-data)
1366 (fluid-set! (@@ (system base message) %dont-warn-list) '())
1367 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1368 ,@(map (g globs exp) x))))))
1369
1370 (define-syntax-parameter break
1371 (lambda (x) #'(values)))
1372
1373 (define-syntax-parameter continue
1374 (lambda (x) (error "continue must be bound")))
1375
1376 (define (is-yield f p x)
1377 (match x
1378 ((#:def nm args _ code)
1379 (is-yield f #t code))
1380 ((#:yield x _)
1381 (eq? f (exp '() x)))
1382 ((#:yield _)
1383 (not p))
1384 ((a . l)
1385 (or
1386 (is-yield f p a)
1387 (is-yield f p l)))
1388 (_
1389 #f)))
1390
1391
1392
1393 (define-syntax-rule (with-sp ((x v) ...) code ...)
1394 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
1395
1396 (define (is-ec ret x tail tags)
1397 (syntax-case (pr 'is-ec x) (begin let if define @@)
1398 ((begin a ... b)
1399 #t
1400 (or
1401 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1402 (is-ec ret #'b tail tags)))
1403
1404 ((let lp ((y x) ...) a ... b)
1405 (symbol? (syntax->datum #'lp))
1406 (or
1407 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1408 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1409 (is-ec ret #'b tail tags)))
1410
1411 ((let ((y x) ...) a ... b)
1412 #t
1413 (or
1414 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1415 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1416 (is-ec ret #'b tail tags)))
1417
1418 ((if p a b)
1419 #t
1420 (or
1421 (is-ec ret #'p #f tags)
1422 (is-ec ret #'a tail tags)
1423 (is-ec ret #'b tail tags)))
1424
1425 ((define . _)
1426 #t
1427 #f)
1428
1429 ((if p a)
1430 #t
1431 (or
1432 (is-ec ret #'p #f tags)
1433 (is-ec ret #'a tail tags)))
1434
1435 ((@@ _ _)
1436 #t
1437 (if (member (pr (syntax->datum x)) tags)
1438 #t
1439 #f))
1440
1441 ((a ...)
1442 #t
1443 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
1444
1445 (x
1446 #t
1447 #f)))
1448
1449 (define-syntax with-return
1450 (lambda (x)
1451 (define (analyze ret x)
1452 (syntax-case x (begin let if)
1453 ((begin a ... b)
1454 #`(begin a ... #,(analyze ret #'b)))
1455 ((let lp v a ... b)
1456 (symbol? (syntax->datum #'lp))
1457 #`(let lp v a ... #,(analyze ret #'b)))
1458 ((let v a ... b)
1459 #`(let v a ... #,(analyze ret #'b)))
1460 ((if p a b)
1461 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
1462 ((if p a)
1463 #`(if p #,(analyze ret #'a)))
1464 ((return a b ...)
1465 (equal? (syntax->datum #'return) (syntax->datum ret))
1466 (if (eq? #'(b ...) '())
1467 #'a
1468 #`(values a b ...)))
1469 (x #'x)))
1470
1471 (define (is-ec ret x tail)
1472 (syntax-case x (begin let if define @@)
1473 ((begin a ... b)
1474 #t
1475 (or
1476 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1477 (is-ec ret #'b tail)))
1478
1479 ((let lp ((y x) ...) a ... b)
1480 (symbol? (syntax->datum #'lp))
1481 (or
1482 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1483 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1484 (is-ec ret #'b tail)))
1485
1486 ((let ((y x) ...) a ... b)
1487 #t
1488 (or
1489 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1490 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1491 (is-ec ret #'b tail)))
1492
1493 ((define . _)
1494 #t
1495 #f)
1496
1497 ((if p a b)
1498 #t
1499 (or
1500 (is-ec ret #'p #f)
1501 (is-ec ret #'a tail)
1502 (is-ec ret #'b tail)))
1503
1504 ((if p a)
1505 #t
1506 (or
1507 (is-ec ret #'p #f)
1508 (is-ec ret #'a tail)))
1509
1510 ((return a b ...)
1511 (equal? (syntax->datum #'return) (syntax->datum ret))
1512 (not tail))
1513
1514 ((a ...)
1515 #t
1516 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
1517
1518 (x
1519 #t
1520 #f)))
1521
1522 (syntax-case x ()
1523 ((_ ret l)
1524 (let ((code (analyze #'ret #'l)))
1525 (if (is-ec #'ret #'l #t)
1526 #`(let/ec ret #,code)
1527 code))))))
1528
1529 (define-syntax var
1530 (lambda (x)
1531 (syntax-case x ()
1532 ((_ v)
1533 (begin
1534 (dont-warn (syntax->datum #'v))
1535 #'(if (module-defined? (current-module) 'v)
1536 (values)
1537 (define! 'v #f)))))))
1538
1539 (define-inlinable (non? x) (eq? x #:nil))
1540
1541 (define (gentemp stx) (datum->syntax stx (gensym "x")))
1542
1543 (define-syntax for
1544 (syntax-rules ()
1545 ((_ (x) (a) code #f #f)
1546 (if (pair? a)
1547 (let lp ((l a))
1548 (if (pair? l)
1549 (let ((x (car l)))
1550 (with-sp ((continue (lp (cdr l)))
1551 (break (values)))
1552 code
1553 (lp (cdr l))))))
1554 (for/adv1 (x) (a) code #f #f)))
1555
1556 ((_ (x) (a) code #f #t)
1557 (if (pair? a)
1558 (let/ec break-ret
1559 (let lp ((l a))
1560 (if (pair? l)
1561 (begin
1562 (let/ec continue-ret
1563 (let ((x (car l)))
1564 (with-sp ((continue (continue-ret))
1565 (break (break-ret)))
1566 code)))
1567 (lp (cdr l))))))
1568 (for/adv1 (x) (a) code #f #t)))
1569
1570 ((_ (x) (a) code next #f)
1571 (if (pair? a)
1572 (let/ec break-ret
1573 (let ((x (let lp ((l a) (old #f))
1574 (if (pair? l)
1575 (let ((x (car l)))
1576 (let/ec continue-ret
1577 (with-sp ((continue (continue-ret))
1578 (break (break-ret)))
1579 code))
1580 (lp (cdr l)))
1581 old))))
1582 next))
1583 (for/adv1 (x) (a) code next #f)))
1584
1585 ((_ x a code next p)
1586 (for/adv1 x a code next p))))
1587
1588 (define-syntax for/adv1
1589 (lambda (x)
1590 (syntax-case x ()
1591 ((_ (x ...) (in) code #f #f)
1592 (with-syntax ((inv (gentemp #'in)))
1593 #'(let ((inv (wrap-in in)))
1594 (catch StopIteration
1595 (lambda ()
1596 (let lp ()
1597 (call-with-values (lambda () (next inv))
1598 (lambda (x ...)
1599 (with-sp ((break (values))
1600 (continue (values)))
1601 code
1602 (lp))))))
1603 (lambda z (values))))))
1604
1605 ((_ (x ...) (in ...) code #f #f)
1606 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1607 #'(let ((inv (wrap-in in)) ...)
1608 (catch StopIteration
1609 (lambda ()
1610 (let lp ()
1611 (call-with-values (lambda () (values (next inv) ...))
1612 (lambda (x ...)
1613 (with-sp ((break (values))
1614 (continue (values)))
1615 code
1616 (lp))))))
1617 (lambda z (values))))))
1618
1619 ((_ (x ...) (in) code #f #t)
1620 (with-syntax ((inv (gentemp #'in)))
1621 #'(let ((inv (wrap-in in)))
1622 (let lp ()
1623 (let/ec break-ret
1624 (catch StopIteration
1625 (lambda ()
1626 (call-with-values (lambda () (next inv))
1627 (lambda (x ...)
1628 (let/ec continue-ret
1629 (with-sp ((break (break-ret))
1630 (continue (continue-ret)))
1631 code))
1632 (lp))))
1633 (lambda z (values))))))))
1634
1635 ((_ (x ...) (in ...) code #f #t)
1636 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1637 #'(let ((inv (wrap-in in)) ...)
1638 (let lp ()
1639 (let/ec break-ret
1640 (catch StopIteration
1641 (lambda ()
1642 (call-with-values (lambda () (values (next inv) ...))
1643 (lambda (x ...)
1644 (let/ec continue-ret
1645 (with-sp ((break (break-ret))
1646 (continue (continue-ret)))
1647 code))
1648 (lp))))
1649 (lambda z (values))))))))
1650
1651 ((_ (x ...) in code else #f)
1652 #'(for-adv (x ...) in code else #f))
1653
1654 ((_ (x ...) in code else #t)
1655 #'(for-adv (x ...) in code else #t)))))
1656
1657
1658 (define-syntax for-adv
1659 (lambda (x)
1660 (define (gen x y)
1661 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
1662 (syntax-case x ()
1663 ((x ...) #'(values (next x) ...)))
1664 (syntax-case x ()
1665 ((x) #'(next x)))))
1666
1667 (syntax-case x ()
1668 ((_ (x ...) (in) code else p)
1669 (with-syntax ((inv (gentemp #'in)))
1670 (with-syntax (((xx ...) (generate-temporaries #'(x ...))))
1671 (if (syntax->datum #'p)
1672 #'(let ((inv (wrap-in in)))
1673 (let/ec break-ret
1674 (let ((x #f) ...)
1675 (catch StopIteration
1676 (lambda ()
1677 (let lp ()
1678 (call-with-values (lambda () (next inv))
1679 (lambda (xx ...)
1680 (set! x xx) ...
1681 (let/ec continue-ret
1682 (with-sp ((break (break-ret))
1683 (continue (continue-ret)))
1684 code))
1685 (lp)))))
1686 (lambda q else)))))
1687
1688 #'(let ((inv (wrap-in in)))
1689 (let ((x #f) ...)
1690 (let/ec break-ret
1691 (catch StopIteration
1692 (lambda ()
1693 (let lp ()
1694 (call-with-values (lambda () (next inv))
1695 (lambda (xx ...)
1696 (set! x xx) ...
1697 (with-sp ((break (break-ret))
1698 (continue (values)))
1699 code)
1700 (lp)))))
1701 (lambda e else)))))))))
1702
1703 ((_ (x ...) (in ...) code else p)
1704 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1705 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
1706 ((xx ...) (generate-temporaries #'(x ...))))
1707 (if (syntax->datum #'p)
1708 #'(let ((inv (wrap-in in)) ...)
1709 (let/ec break-ret
1710 (let ((x #f) ...)
1711 (catch StopIteration
1712 (lambda ()
1713 (let lp ()
1714 (call-with-values (lambda () get)
1715 (lambda (xx ...)
1716 (set! x xx) ...
1717 (let/ec continue-ret
1718 (with-sp ((break (break-ret))
1719 (continue (continue-ret)))
1720 code))
1721 (lp)))))
1722 (lambda q else)))))
1723
1724 #'(let ((inv (wrap-in in)) ...)
1725 (let ((x #f) ...)
1726 (let/ec break-ret
1727 (catch StopIteration
1728 (lambda ()
1729 (let lp ()
1730 (call-with-values (lambda () get)
1731 (lambda (xx ...)
1732 (set! x xx) ...
1733 (with-sp ((break (break-ret))
1734 (continue (values)))
1735 code)
1736 (lp)))))
1737 (lambda e else))))))))))))
1738
1739 (define-syntax def-wrap
1740 (lambda (x)
1741 (syntax-case x ()
1742 ((_ #f f ab x)
1743 (pr 'def-wrap #'f 'false)
1744 #'x)
1745
1746 ((_ #t f ab code)
1747 (pr 'def-wrap #'f 'true)
1748 #'(lambda x
1749 (define obj (make <yield>))
1750 (define ab (make-prompt-tag))
1751 (slot-set! obj 'k #f)
1752 (slot-set! obj 'closed #f)
1753 (slot-set! obj 's
1754 (lambda ()
1755 (call-with-prompt
1756 ab
1757 (lambda ()
1758 (let/ec return
1759 (apply code x))
1760 (slot-set! obj 'closed #t)
1761 (throw StopIteration))
1762 (letrec ((lam
1763 (lambda (k . l)
1764 (fluid-set! in-yield #f)
1765 (slot-set! obj 'k
1766 (lambda (a)
1767 (call-with-prompt
1768 ab
1769 (lambda ()
1770 (k a))
1771 lam)))
1772 (apply values l))))
1773 lam))))
1774 obj)))))
1775
1776 (define-syntax ref-x
1777 (syntax-rules ()
1778 ((_ v)
1779 v)
1780 ((_ v (#:fastfkn-ref f _) . l)
1781 (ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l))
1782 ((_ v (#:fast-id f _) . l)
1783 (ref-x (f v) . l))
1784 ((_ v (#:identifier x) . l)
1785 (ref-x (ref v x) . l))
1786 ((_ v (#:identifier x) . l)
1787 (ref-x (ref v x) . l))
1788 ((_ v (#:call-obj x) . l)
1789 (ref-x (x v) . l))
1790 ((_ v (#:call x ...) . l)
1791 (ref-x (v x ...) . l))
1792 ((_ v (#:apply x ...) . l)
1793 (ref-x (apply v x ...) . l))
1794 ((_ v (#:apply x ...) . l)
1795 (ref-x (apply v x ...) . l))
1796 ((_ v (#:vecref x) . l)
1797 (ref-x (pylist-ref v x) . l))
1798 ((_ v (#:vecsub . x) . l)
1799 (ref-x (pylist-slice v . x) . l))))
1800
1801 (define-syntax del-x
1802 (syntax-rules ()
1803 ((_ v (#:identifier x))
1804 (ref-x (ref v 'x)))
1805 ((_ v (#:call-obj x))
1806 (values))
1807 ((_ v (#:call x ...))
1808 (values))
1809 ((_ v (#:apply x ...))
1810 (values))
1811 ((_ v (#:vecref x))
1812 (pylist-delete! v x))
1813 ((_ v (#:vecsub x ...))
1814 (pylist-subset! v x ... pylist-null))))
1815
1816 (define-syntax set-x
1817 (syntax-rules ()
1818 ((_ v (a ... b) val)
1819 (set-x-2 (ref-x v a ...) b val))
1820 ((_ v #f p pa a val)
1821 (set-x p pa (fset-x v a val)))
1822 ((_ v pre p pa a val)
1823 (set-c v pre a val))
1824 ((_ v (a ... b) val)
1825 (set-x-2 (ref-x v a ...) b val))))
1826
1827 (define-syntax set-c
1828 (syntax-rules ()
1829 ((_ v (a) (b) val)
1830 (set v a val))
1831 ((_ v () as val)
1832 (tr v (fset-x v as val)))
1833 ((_ v ((#:identifier a) . as) (b . bs) val)
1834 (set-c (ref v a) as bs val))))
1835
1836 (define-syntax fset-x
1837 (syntax-rules ()
1838 ((_ v ((#:identifier x) ...) val)
1839 ((@ (oop pf-objects) fset-x) v (list x ...) val))))
1840
1841 (define-syntax set-x-2
1842 (syntax-rules ()
1843 ((_ v (#:fastfkn-ref f id) val)
1844 (set v id val))
1845 ((_ v (#:fastid-ref f id) val)
1846 (set v id val))
1847 ((_ v (#:identifier x) val)
1848 (set v x val))
1849 ((_ v (#:vecref n) val)
1850 (pylist-set! v n val))
1851 ((_ v (#:vecsub x ...) val)
1852 (pylist-subset! v x ... val))))
1853
1854
1855 (define-syntax class-decor
1856 (syntax-rules ()
1857 ((_ () x) x)
1858 ((_ (f ... r) y)
1859 (class-decor (f ...) (r y)))))
1860
1861 (define-syntax def-decor
1862 (syntax-rules ()
1863 ((_ () x) x)
1864 ((_ (f ... r) y)
1865 (def-decor (f ...) (r y)))))
1866
1867 (define-syntax with-self
1868 (syntax-rules ()
1869 ((_ #f _ c)
1870 c)
1871 ((_ _ (s . b) c)
1872 (syntax-parameterize ((*self* (lambda (x) #'s))) c))))
1873
1874 (define-syntax with-class
1875 (syntax-rules ()
1876 ((_ s c)
1877 (syntax-parameterize ((*class* (lambda (x) #'s))) c))))
1878