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