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