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