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