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