378138c8b8a98f932e567511f059339a82371578
[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) ,(exp vs x) #:finally (lambda () fin))
1052 (exp vs x)))
1053
1054
1055 ((_ x exc else . fin)
1056 `(,(T 'try) (lambda () ,(exp vs x))
1057 ,@(let lp ((exc exc) (r (if else (exp vs else) '())))
1058 (match exc
1059 ((((test . #f) code) . exc)
1060 (lp exc (cons `(#:except ,(exp vs test) ,(exp vs code)) r)))
1061
1062 (((#f code) . exc)
1063 (lp exc (cons `(#:except ,(exp vs code)) r)))
1064
1065 ((((test . as) code) . exc)
1066 (let ((l (gensym "l")))
1067 (lp exc
1068 (cons
1069 `(#:except ,(exp vs test) => (lambda (,(exp vs as) . ,l)
1070 ,(exp vs code)))
1071 r))))
1072 (()
1073 (reverse r))))
1074 ,@(if fin `(#:finally (lambda () ,(exp vs fin))) '()))))
1075
1076 (#:subexpr
1077 ((_ . l)
1078 (exp vs l)))
1079
1080 (#:raise
1081 ((_ #f . #f)
1082 `(,(T 'raise) (,(O 'Exception))))
1083
1084 ((_ code . #f)
1085 `(,(T 'raise) ,(exp vs code)))
1086
1087 ((_ code . from)
1088 (let ((o (gensym "o"))
1089 (c (gensym "c")))
1090 `(,(T 'raise)
1091 (let ((,c ,(exp vs code)))
1092 (let ((,o (if (,(O 'pyclass?) ,c)
1093 (,c)
1094 ,c)))
1095 (,(O 'set) ,o '__cause__ ,(exp vs from))
1096 ,o))))))
1097
1098
1099 (#:yield
1100 ((_ args)
1101 (let ((f (gensym "f")))
1102 `(begin
1103 (fluid-set! ,(Y 'in-yield) #t)
1104 (let ((,f (scm.yield ,@(gen-yargs vs args))))
1105 (,f)))))
1106
1107
1108 ((_ f args)
1109 (let ((f (gen-yield (exp vs f)))
1110 (g (gensym "f")))
1111 `(begin
1112 (set! ,(C 'inhibit-finally) #t)
1113 (let ((,g (,f ,@(gen-yargs vs args))))
1114 (,g))))))
1115
1116 (#:def
1117 ((_ f
1118 (#:types-args-list . args)
1119 #f
1120 code)
1121 (let* ((decor (let ((r (fluid-ref decorations)))
1122 (fluid-set! decorations '())
1123 r))
1124 (arg_ (get-args_ vs args))
1125 (arg= (get-args= vs args))
1126 (dd= (map cadr arg=))
1127 (c? (fluid-ref is-class?))
1128 (f (exp vs f))
1129 (y? (is-yield f #f code))
1130 (r (gensym "return"))
1131 (*f (get-args* vs args))
1132 (dd* (map cadr *f))
1133 (**f (get-args** vs args))
1134 (dd** (map cadr **f))
1135 (aa `(,@arg_ ,@*f ,@arg= ,@**f))
1136 (ab (gensym "ab"))
1137 (vs (union dd** (union dd* (union dd= (union arg_ vs)))))
1138 (ns (scope code vs))
1139 (df (defs code '()))
1140 (ex (gensym "ex"))
1141 (y 'scm.yield)
1142 (y.f (gen-yield f))
1143 (ls (diff (diff ns vs) df)))
1144
1145 (define (mk code)
1146 `(let-syntax ((,y (syntax-rules ()
1147 ((_ . args)
1148 (abort-to-prompt ,ab . args))))
1149 (,y.f (syntax-rules ()
1150 ((_ . args)
1151 (abort-to-prompt ,ab . args)))))
1152 ,code))
1153
1154 (with-fluids ((is-class? #f))
1155 (if c?
1156 (if y?
1157 `(set! ,f
1158 (,(C 'def-decor) ,decor
1159 (,(C 'def-wrap) ,y? ,f ,ab
1160 (,(D 'lam) ,aa
1161 (,(C 'with-return) ,r
1162 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
1163 (,(C 'with-self) ,c? ,aa
1164 ,(with-fluids ((return r))
1165 (exp ns code))))))))))
1166
1167 `(set! ,f
1168 (,(C 'def-decor) ,decor
1169 (,(D 'lam) ,aa
1170 (,(C 'with-return) ,r
1171 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
1172 (,(C 'with-self) ,c? ,aa
1173 ,(with-fluids ((return r))
1174 (exp ns code))))))))))
1175
1176 (if y?
1177 `(set! ,f
1178 (,(C 'def-decor) ,decor
1179 (,(C 'def-wrap) ,y? ,f ,ab
1180 (,(D 'lam) ,aa
1181 (,(C 'with-return) ,r
1182 (let ,(map (lambda (x) (list x #f)) ls)
1183 (,(C 'with-self) ,c? ,aa
1184 ,(with-fluids ((return r))
1185 (mk
1186 (exp ns code))))))))))
1187 `(set! ,f
1188 (,(C 'def-decor) ,decor
1189 (,(D 'lam) ,aa
1190 (,(C 'with-return) ,r
1191 (let ,(map (lambda (x) (list x #f)) ls)
1192 (,(C 'with-self) ,c? ,aa
1193 ,(with-fluids ((return r))
1194 (exp ns code))))))))))))))
1195
1196 (#:global
1197 ((_ . _)
1198 '(values)))
1199
1200 (#:list
1201 ((_ x (and e (#:cfor . _)))
1202 (let ((l (gensym "l")))
1203 `(let ((,l (,(L 'to-pylist) '())))
1204 ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
1205 ,l)))
1206
1207 ((_ . l)
1208 (list (L 'to-pylist) (let lp ((l l))
1209 (match l
1210 ((or () #f) ''())
1211 (((#:starexpr #:power #f (#:list . l) . _) . _)
1212 (lp l))
1213 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1214 (lp l))
1215 (((#:starexpr . l) . _)
1216 `(,(L 'to-list) ,(exp vs l)))
1217 ((x . l)
1218 `(cons ,(exp vs x) ,(lp l))))))))
1219 (#:tuple
1220 ((_ x (and e (#:cfor . _)))
1221 (let ((l (gensym "l")))
1222 `(let ((,l '()))
1223 ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
1224 (reverse ,l))))
1225
1226 ((_ . l)
1227 (let lp ((l l))
1228 (match l
1229 (() ''())
1230 (((#:starexpr #:power #f (#:list . l) . _) . _)
1231 (lp l))
1232 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1233 (lp l))
1234 (((#:starexpr . l) . _)
1235 `(,(L 'to-list) ,(exp vs l)))
1236 ((x . l)
1237 `(cons ,(exp vs x) ,(lp l)))))))
1238
1239 (#:lambdef
1240 ((_ (#:var-args-list . v) e)
1241 (let ((as (get-args_ vs v))
1242 (a= (get-args= vs v))
1243 (a* (get-args* vs v))
1244 (** (get-args** vs v)))
1245 (list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))))
1246
1247 (#:stmt
1248 ((_ l)
1249 (if (> (length l) 1)
1250 (cons 'values (map (g vs exp) l))
1251 (exp vs (car l)))))
1252
1253 (#:expr-stmt
1254 ((_ (l ...) (#:assign))
1255 (let ((l (map (g vs exp) l)))
1256 (if (= (length l) 1)
1257 (car l)
1258 `(,(G 'values) ,@l))))
1259
1260 ((_ a (#:assign b c . u))
1261 (let ((z (gensym "x")))
1262 `(let ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u)))))
1263 ,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z))))))))
1264
1265 ((_ l type)
1266 (=> fail)
1267 (call-with-values
1268 (lambda () (match type
1269 ((#:assign u)
1270 (values #f u))
1271 ((#:augassign op u)
1272 (values op u))
1273 (_ (fail))))
1274
1275 (lambda (op u)
1276 (cond
1277 ((= (length l) (length u))
1278 (if (= (length l) 1)
1279 `(begin
1280 ,(make-set vs op (car l) (exp vs (car u)))
1281 (values))
1282 `(begin
1283 ,@(map (lambda (l u) (make-set vs op l u))
1284 l
1285 (map (g vs exp) u))
1286 (values))))
1287
1288 ((and (= (length u) 1) (not op))
1289 (let ((vars (map (lambda (x) (gensym "v")) l))
1290 (q (gensym "q"))
1291 (f (gensym "f")))
1292 `(begin
1293 (call-with-values (lambda () ,(exp vs (car u)))
1294 (letrec ((,f
1295 (case-lambda
1296 ((,q)
1297 (if (pair? ,q)
1298 (apply ,f ,q)
1299 (apply ,f (,(L 'to-list) ,q))))
1300 (,vars
1301 ,@(map (lambda (l v) (make-set vs op l v))
1302 l vars)))))
1303 ,f))
1304 (values))))
1305
1306 ((and (= (length l) 1) (not op))
1307 `(begin
1308 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
1309 (values)))))))
1310
1311 ((_
1312 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
1313 (#:assign (l)))
1314 (let ((s (string->symbol v)))
1315 `(,s/d ,s ,(exp vs l)))))
1316
1317 (#:assert
1318 ((_ x f n m)
1319 `(if (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
1320 x)))
1321 (,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))
1322
1323
1324
1325 (#:expr-stmt1
1326 ((_ a (#:assign b c . u))
1327 (let ((z (gensym "x")))
1328 `(let ((,z ,(exp vs `(#:expr-stmt1 ,b
1329 (#:assign ,c . ,u)))))
1330 ,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z))))))))
1331
1332 ((_ l type)
1333 (=> fail)
1334 (call-with-values
1335 (lambda () (match type
1336 ((#:assign u)
1337 (values #f u))
1338 ((#:augassign op u)
1339 (values op u))
1340 (_ (fail))))
1341
1342 (lambda (op u)
1343 (cond
1344 ((= (length l) (length u))
1345 (if (= (length l) 1)
1346 `(begin
1347 ,(make-set vs op (car l) (exp vs (car u)))
1348 ,(exp vs (car l)))
1349 `(begin
1350 ,@(map (lambda (l u) (make-set vs op l u))
1351 l
1352 (map (g vs exp) u))
1353 (values ,@(map (g exp vs) l)))))
1354
1355 ((and (= (length u) 1) (not op))
1356 (let ((vars (map (lambda (x) (gensym "v")) l))
1357 (q (gensym "q"))
1358 (f (gensym "f")))
1359 `(begin
1360 (call-with-values (lambda () ,(exp vs (car u)))
1361 (letrec ((,f
1362 (case-lambda
1363 ((,q)
1364 (if (pair? ,q)
1365 (apply ,f ,q)
1366 (apply ,f (,(L 'to-list) ,q))))
1367 (,vars
1368 ,@(map (lambda (l v) (make-set vs op l v))
1369 l vars)))))
1370 ,f))
1371 (values ,@(map (g exp vs) l)))))
1372
1373 ((and (= (length l) 1) (not op))
1374 `(begin
1375 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
1376 (values ,(exp vs (car l))))))))))
1377
1378 (#:return
1379 ((_ x)
1380 (if x
1381 `(,(fluid-ref return) ,@(map (g vs exp) x))
1382 `(,(fluid-ref return)))))
1383
1384
1385 (#:dict
1386 ((_ . #f)
1387 `(,(Di 'make-py-hashtable)))
1388
1389 ((_ (#:e k . v) (and e (#:cfor . _)))
1390 (let ((dict (gensym "dict")))
1391 `(let ((,dict (,(Di 'make-py-hashtable))))
1392 ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1393 ,dict)))
1394
1395 ((_ (#:e k . v) ...)
1396 (let ((dict (gensym "dict")))
1397 `(let ((,dict (,(Di 'make-py-hashtable))))
1398 ,@(map (lambda (k v)
1399 `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1400 k v)
1401 ,dict)))
1402
1403 ((_ k (and e (#:cfor . _)))
1404 (let ((dict (gensym "dict")))
1405 `(let ((,dict (,(Se 'set))))
1406 ,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k)))
1407 ,dict)))
1408
1409 ((_ k ...)
1410 (let ((set (gensym "dict")))
1411 `(let ((,set (,(Se 'set))))
1412 ,@(map (lambda (k)
1413 `((,(O 'ref) ,set 'add) ,(exp vs k)))
1414 k)
1415 ,set))))
1416
1417
1418 (#:comp
1419 ((_ x #f)
1420 (exp vs x))
1421
1422 ((_ x (op . y))
1423 (tr-comp op (exp vs x) (exp vs y)))
1424
1425 ((_ x (op . y) . l)
1426 (let ((m (gensym "op")))
1427 `(let ((,m ,(exp vs y)))
1428 (and ,(tr-comp op (exp vs x) m)
1429 ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
1430
1431
1432 (define (exp vs x)
1433 (match (pr x)
1434 ((e)
1435 (exp vs e))
1436 ((tag . l)
1437 ((hash-ref tagis tag
1438 (lambda y (warn (format #f "not tag in tagis ~a" tag)) x))
1439 x vs))
1440
1441 (#:True #t)
1442 (#:None (E 'None))
1443 (#:null ''())
1444 (#:False #f)
1445 (#:pass `(values))
1446 (#:break
1447 (C 'break))
1448 (#:continue
1449 (C 'continue))
1450 (x x)))
1451
1452 (define-syntax-rule (define- n x) (define! 'n x))
1453
1454 (define (comp x)
1455 (define start
1456 (match x
1457 (((#:stmt
1458 ((#:expr-stmt
1459 ((#:test
1460 (#:power #f
1461 (#:identifier "module" . _)
1462 ((#:arglist arglist))
1463 . #f) #f))
1464 (#:assign)))) . rest)
1465
1466 (let ()
1467 (define args
1468 (map (lambda (x)
1469 (exp '() x))
1470 arglist))
1471
1472 `((,(G 'define-module) (language python module ,@args)
1473 #:use-module (language python module python)
1474 #:use-module (language python exceptions))
1475 (define __doc__ #f)
1476 (define __module__ '(language python module ,@args)))))
1477 (x '())))
1478
1479 (if (fluid-ref (@@ (system base compile) %in-compile))
1480 (begin
1481 (if (fluid-ref (@@ (system base compile) %in-compile))
1482 (set! s/d 'set!)
1483 (set! s/d (C 'define-)))
1484
1485 (if (pair? start)
1486 (set! x (cdr x)))
1487
1488 (let ((globs (get-globals x)))
1489 `(begin
1490 ,@start
1491 ,(C 'clear-warning-data)
1492 (fluid-set! (@@ (system base message) %dont-warn-list) '())
1493 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1494 ,@(map (g globs exp) x)
1495 (,(C 'export-all)))))
1496 (begin
1497 (if (fluid-ref (@@ (system base compile) %in-compile))
1498 (set! s/d 'set!)
1499 (set! s/d (C 'define-)))
1500
1501 (if (pair? start)
1502 (set! x (cdr x)))
1503
1504 (let ((globs (get-globals x)))
1505 `(begin
1506 ,@start
1507 ,(C 'clear-warning-data)
1508 (fluid-set! (@@ (system base message) %dont-warn-list) '())
1509 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1510 ,@(map (g globs exp) x))))))
1511
1512
1513 (define-syntax-parameter break
1514 (lambda (x) #'(values)))
1515
1516 (define-syntax-parameter continue
1517 (lambda (x) (error "continue must be bound")))
1518
1519 (define (is-yield f p x)
1520 (match x
1521 ((#:def nm args _ code)
1522 (is-yield f #t code))
1523 ((#:yield x _)
1524 (eq? f (exp '() x)))
1525 ((#:yield _)
1526 (not p))
1527 ((a . l)
1528 (or
1529 (is-yield f p a)
1530 (is-yield f p l)))
1531 (_
1532 #f)))
1533
1534
1535
1536 (define-syntax-rule (with-sp ((x v) ...) code ...)
1537 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
1538
1539 (define (is-ec ret x tail tags)
1540 (syntax-case (pr 'is-ec x) (begin let if define set! @@)
1541 ((begin a ... b)
1542 #t
1543 (or
1544 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1545 (is-ec ret #'b tail tags)))
1546
1547 ((let lp ((y x) ...) a ... b)
1548 (symbol? (syntax->datum #'lp))
1549 (or
1550 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1551 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1552 (is-ec ret #'b tail tags)))
1553
1554 ((let ((y x) ...) a ... b)
1555 #t
1556 (or
1557 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1558 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1559 (is-ec ret #'b tail tags)))
1560
1561 ((if p a b)
1562 #t
1563 (or
1564 (is-ec ret #'p #f tags)
1565 (is-ec ret #'a tail tags)
1566 (is-ec ret #'b tail tags)))
1567
1568 ((define . _)
1569 #t
1570 #f)
1571
1572 ((set! . _)
1573 #t
1574 #f)
1575
1576 ((if p a)
1577 #t
1578 (or
1579 (is-ec ret #'p #f tags)
1580 (is-ec ret #'a tail tags)))
1581
1582 ((@@ _ _)
1583 #t
1584 (if (member (pr (syntax->datum x)) tags)
1585 #t
1586 #f))
1587
1588 ((a ...)
1589 #t
1590 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
1591
1592 (x
1593 #t
1594 #f)))
1595
1596 (define-syntax with-return
1597 (lambda (x)
1598 (define (analyze ret x)
1599 (syntax-case x (begin let if)
1600 ((begin a ... b)
1601 #`(begin a ... #,(analyze ret #'b)))
1602 ((let lp v a ... b)
1603 (symbol? (syntax->datum #'lp))
1604 #`(let lp v a ... #,(analyze ret #'b)))
1605 ((let v a ... b)
1606 #`(let v a ... #,(analyze ret #'b)))
1607 ((if p a b)
1608 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
1609 ((if p a)
1610 #`(if p #,(analyze ret #'a)))
1611 ((return a b ...)
1612 (equal? (syntax->datum #'return) (syntax->datum ret))
1613 (if (eq? #'(b ...) '())
1614 #'a
1615 #`(values a b ...)))
1616 (x #'x)))
1617
1618 (define (is-ec ret x tail)
1619 (syntax-case x (begin let if define @@)
1620 ((begin a ... b)
1621 #t
1622 (or
1623 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1624 (is-ec ret #'b tail)))
1625
1626 ((let lp ((y x) ...) a ... b)
1627 (symbol? (syntax->datum #'lp))
1628 (or
1629 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1630 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1631 (is-ec ret #'b tail)))
1632
1633 ((let ((y x) ...) a ... b)
1634 #t
1635 (or
1636 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1637 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1638 (is-ec ret #'b tail)))
1639
1640 ((define . _)
1641 #t
1642 #f)
1643
1644 ((if p a b)
1645 #t
1646 (or
1647 (is-ec ret #'p #f)
1648 (is-ec ret #'a tail)
1649 (is-ec ret #'b tail)))
1650
1651 ((if p a)
1652 #t
1653 (or
1654 (is-ec ret #'p #f)
1655 (is-ec ret #'a tail)))
1656
1657 ((return a b ...)
1658 (equal? (syntax->datum #'return) (syntax->datum ret))
1659 (not tail))
1660
1661 ((a ...)
1662 #t
1663 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
1664
1665 (x
1666 #t
1667 #f)))
1668
1669 (syntax-case x ()
1670 ((_ ret l)
1671 (let ((code (analyze #'ret #'l)))
1672 (if (is-ec #'ret #'l #t)
1673 #`(let/ec ret #,code)
1674 code))))))
1675
1676 (define-syntax var
1677 (lambda (x)
1678 (syntax-case x ()
1679 ((_ v)
1680 (begin
1681 (dont-warn (syntax->datum #'v))
1682 #'(if (module-defined? (current-module) 'v)
1683 (values)
1684 (define! 'v #f)))))))
1685
1686 (define-inlinable (non? x) (eq? x #:nil))
1687
1688 (define (gentemp stx) (datum->syntax stx (gensym "x")))
1689
1690 (define-syntax clambda
1691 (lambda (x)
1692 (syntax-case x ()
1693 ((_ (x ...) code ...)
1694 (with-syntax ((n (length #'(x ...))))
1695 #'(let ((f (lambda (x ... . u) code ...)))
1696 (if (> n 1)
1697 (case-lambda
1698 ((c)
1699 (if (pair? c)
1700 (let ((cc (cdr c)))
1701 (if (pair? cc)
1702 (apply f c)
1703 (f c cc)))
1704 (py-apply f (* c))))
1705 (q (apply f q)))
1706 f)))))))
1707
1708 (define-syntax cfor
1709 (syntax-rules ()
1710 ((_ (x) (a) code #f #f)
1711 (if (pair? a)
1712 (let/ec break-ret
1713 (let lp ((l a))
1714 (if (pair? l)
1715 (begin
1716 (set! x (car l))
1717 (with-sp ((continue (values))
1718 (break (break-ret)))
1719 code)
1720 (lp (cdr l))))))
1721 (for/adv1 (x) (a) code #f #f)))
1722
1723 ((_ (x) (a) code #f #t)
1724 (if (pair? a)
1725 (let/ec break-ret
1726 (let lp ((l a))
1727 (if (pair? l)
1728 (let/ec continue-ret
1729 (set! x (car l))
1730 (with-sp ((continue (continue-ret))
1731 (break (break-ret)))
1732 code))
1733 (lp (cdr l)))))
1734 (for/adv1 (x) (a) code #f #t)))
1735
1736 ((_ (x) (a) code next #f)
1737 (if (pair? a)
1738 (let/ec break-ret
1739 (let lp ((l a))
1740 (if (pair? l)
1741 (begin
1742 (set! x (car l))
1743 (with-sp ((continue (values))
1744 (break (break-ret)))
1745 code))
1746 (lp (cdr l))))
1747 next)
1748 (for/adv1 (x) (a) code next #f)))
1749
1750 ((_ (x) (a) code next #t)
1751 (if (pair? a)
1752 (let/ec break-ret
1753 (let lp ((l a))
1754 (if (pair? l)
1755 (let/ec continue-ret
1756 (set! x (car l))
1757 (with-sp ((continue (continue-ret))
1758 (break (break-ret)))
1759 code))
1760 (lp (cdr l))))
1761 next)
1762 (for/adv1 (x) (a) code next #f)))
1763
1764 ((_ x a code next p)
1765 (for/adv1 x a code next p))))
1766
1767 (define-syntax for/adv1
1768 (lambda (x)
1769 (syntax-case x ()
1770 ((_ (x ...) (in) code #f #f)
1771 (with-syntax ((inv (gentemp #'in))
1772 ((xx ...) (generate-temporaries #'(x ...))))
1773 #'(let ((inv (wrap-in in)))
1774 (catch StopIteration
1775 (lambda ()
1776 (let lp ()
1777 (call-with-values (lambda () (next inv))
1778 (clambda (xx ...)
1779 (set! x xx) ...
1780 (with-sp ((break (values))
1781 (continue (values)))
1782 code
1783 (lp))))))
1784 (lambda z (values))))))
1785
1786 ((_ (x ...) (in ...) code #f #f)
1787 (with-syntax (((inv ...) (generate-temporaries #'(in ...)))
1788 ((xx ...) (generate-temporaries #'(x ...))))
1789 #'(let ((inv (wrap-in in)) ...)
1790 (catch StopIteration
1791 (lambda ()
1792 (let lp ()
1793 (call-with-values (lambda () (values (next inv) ...))
1794 (clambda (xx ...)
1795 (set! x xx) ...
1796 (with-sp ((break (values))
1797 (continue (values)))
1798 code
1799 (lp))))))
1800 (lambda z (values))))))
1801
1802 ((_ (x ...) (in) code #f #t)
1803 (with-syntax ((inv (gentemp #'in))
1804 ((xx ...) (generate-temporaries #'(x ...))))
1805 #'(let ((inv (wrap-in in)))
1806 (let lp ()
1807 (let/ec break-ret
1808 (catch StopIteration
1809 (lambda ()
1810 (call-with-values (lambda () (next inv))
1811 (clambda (xx ...)
1812 (set! x xx) ...
1813 (let/ec continue-ret
1814 (with-sp ((break (break-ret))
1815 (continue (continue-ret)))
1816 code))
1817 (lp))))
1818 (lambda z (values))))))))
1819
1820 ((_ (x ...) (in ...) code #f #t)
1821 (with-syntax (((inv ...) (generate-temporaries #'(in ...)))
1822 ((xx ...) (generate-temporaries #'(x ...))))
1823 #'(let ((inv (wrap-in in)) ...)
1824 (let lp ()
1825 (let/ec break-ret
1826 (catch StopIteration
1827 (lambda ()
1828 (call-with-values (lambda () (values (next inv) ...))
1829 (clambda (xx ...)
1830 (set! x xx) ...
1831 (let/ec continue-ret
1832 (with-sp ((break (break-ret))
1833 (continue (continue-ret)))
1834 code))
1835 (lp))))
1836 (lambda z (values))))))))
1837
1838 ((_ (x ...) in code else #f)
1839 #'(for-adv (x ...) in code else #f))
1840
1841 ((_ (x ...) in code else #t)
1842 #'(for-adv (x ...) in code else #t)))))
1843
1844
1845 (define-syntax for-adv
1846 (lambda (x)
1847 (define (gen x y)
1848 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
1849 (syntax-case x ()
1850 ((x ...) #'(values (next x) ...)))
1851 (syntax-case x ()
1852 ((x) #'(next x)))))
1853
1854 (syntax-case x ()
1855 ((_ (x ...) (in) code else p)
1856 (with-syntax ((inv (gentemp #'in)))
1857 (with-syntax (((xx ...) (generate-temporaries #'(x ...))))
1858 (if (syntax->datum #'p)
1859 #'(let ((inv (wrap-in in)))
1860 (let/ec break-ret
1861 (catch StopIteration
1862 (lambda ()
1863 (let lp ()
1864 (call-with-values (lambda () (next inv))
1865 (clambda (xx ...)
1866 (set! x xx) ...
1867 (let/ec continue-ret
1868 (with-sp ((break (break-ret))
1869 (continue (continue-ret)))
1870 code))
1871 (lp)))))
1872 (lambda q else))))
1873
1874 #'(let ((inv (wrap-in in)))
1875 (let/ec break-ret
1876 (catch StopIteration
1877 (lambda ()
1878 (let lp ()
1879 (call-with-values (lambda () (next inv))
1880 (clambda (xx ...)
1881 (set! x xx) ...
1882 (with-sp ((break (break-ret))
1883 (continue (values)))
1884 code)
1885 (lp)))))
1886 (lambda e else))))))))
1887
1888 ((_ (x ...) (in ...) code else p)
1889 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1890 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
1891 ((xx ...) (generate-temporaries #'(x ...))))
1892 (if (syntax->datum #'p)
1893 #'(let ((inv (wrap-in in)) ...)
1894 (let/ec break-ret
1895 (catch StopIteration
1896 (lambda ()
1897 (let lp ()
1898 (call-with-values (lambda () get)
1899 (clambda (xx ...)
1900 (set! x xx) ...
1901 (let/ec continue-ret
1902 (with-sp ((break (break-ret))
1903 (continue (continue-ret)))
1904 code))
1905 (lp)))))
1906 (lambda q else))))
1907
1908 #'(let ((inv (wrap-in in)) ...)
1909 (let/ec break-ret
1910 (catch StopIteration
1911 (lambda ()
1912 (let lp ()
1913 (call-with-values (lambda () get)
1914 (clambda (xx ...)
1915 (set! x xx) ...
1916 (with-sp ((break (break-ret))
1917 (continue (values)))
1918 code)
1919 (lp)))))
1920 (lambda e else)))))))))))
1921
1922 (define-syntax def-wrap
1923 (lambda (x)
1924 (syntax-case x ()
1925 ((_ #f f ab x)
1926 (pr 'def-wrap #'f 'false)
1927 #'x)
1928
1929 ((_ #t f ab code)
1930 (pr 'def-wrap #'f 'true)
1931 #'(lambda x
1932 (define obj (make <yield>))
1933 (define ab (make-prompt-tag))
1934 (slot-set! obj 'k #f)
1935 (slot-set! obj 'closed #f)
1936 (slot-set! obj 's
1937 (lambda ()
1938 (call-with-prompt
1939 ab
1940 (lambda ()
1941 (let/ec return
1942 (apply code x))
1943 (slot-set! obj 'closed #t)
1944 (throw StopIteration))
1945 (letrec ((lam
1946 (lambda (k . l)
1947 (fluid-set! in-yield #f)
1948 (slot-set! obj 'k
1949 (lambda (a)
1950 (call-with-prompt
1951 ab
1952 (lambda ()
1953 (k a))
1954 lam)))
1955 (apply values l))))
1956 lam))))
1957 obj)))))
1958
1959 (define miss (list 'miss))
1960 (define-inlinable (wr k x)
1961 (if (eq? x miss)
1962 (raise (AttributeError k))
1963 x))
1964
1965 (define-syntax ref-x
1966 (lambda (x)
1967 (syntax-case x (quote __dict__)
1968 ((_ v)
1969 #'v)
1970 ((_ v (#:fastfkn-ref f _) . l)
1971 #'(ref-x (lambda x (if (pyclass? v) (apply f x) (apply f v x))) . l))
1972 ((_ v (#:fast-id f _) . l)
1973 #'(ref-x (f v) . l))
1974 ((_ v (#:identifier '__dict__) . l)
1975 #'(ref-x (py-dict v) . l))
1976 ((_ v (#:identifier x) . l)
1977 #'(ref-x (wr x (ref v x miss)) . l))
1978 ((_ v (#:call-obj x) . l)
1979 #'(ref-x (x v) . l))
1980 ((_ v (#:call x ...) . l)
1981 #'(ref-x (v x ...) . l))
1982 ((_ v (#:apply x ...) . l)
1983 #'(ref-x (py-apply v x ...) . l))
1984 ((_ v (#:apply x ...) . l)
1985 #'(ref-x (py-apply v x ...) . l))
1986 ((_ v (#:vecref x) . l)
1987 #'(ref-x (pylist-ref v x) . l))
1988 ((_ v (#:vecsub . x) . l)
1989 #'(ref-x (pylist-slice v . x) . l)))))
1990
1991 (define-syntax del-x
1992 (syntax-rules ()
1993 ((_ v (#:identifier x))
1994 (ref-x (wr x (ref v x))))
1995 ((_ v (#:call-obj x))
1996 (values))
1997 ((_ v (#:call x ...))
1998 (values))
1999 ((_ v (#:apply x ...))
2000 (values))
2001 ((_ v (#:vecref x))
2002 (pylist-delete! v x))
2003 ((_ v (#:vecsub x ...))
2004 (pylist-subset! v x ... pylist-null))))
2005
2006 (define-syntax set-x
2007 (syntax-rules ()
2008 ((_ v (a ... b) val)
2009 (set-x-2 (ref-x v a ...) b val))
2010 ((_ v #f p pa a val)
2011 (set-x p pa (fset-x v a val)))
2012 ((_ v pre p pa a val)
2013 (set-c v pre a val))
2014 ((_ v (a ... b) val)
2015 (set-x-2 (ref-x v a ...) b val))))
2016
2017 (define-syntax set-c
2018 (syntax-rules ()
2019 ((_ v (a) (b) val)
2020 (set v a val))
2021 ((_ v () as val)
2022 (tr v (fset-x v as val)))
2023 ((_ v ((#:identifier a) . as) (b . bs) val)
2024 (set-c (ref v a) as bs val))))
2025
2026 (define-syntax fset-x
2027 (syntax-rules ()
2028 ((_ v ((#:identifier x) ...) val)
2029 ((@ (oop pf-objects) fset-x) v (list x ...) val))))
2030
2031 (define-syntax set-x-2
2032 (syntax-rules ()
2033 ((_ v (#:fastfkn-ref f id) val)
2034 (set v id val))
2035 ((_ v (#:fastid-ref f id) val)
2036 (set v id val))
2037 ((_ v (#:identifier x) val)
2038 (set v x val))
2039 ((_ v (#:vecref n) val)
2040 (pylist-set! v n val))
2041 ((_ v (#:vecsub x ...) val)
2042 (pylist-subset! v x ... val))))
2043
2044
2045 (define-syntax class-decor
2046 (syntax-rules ()
2047 ((_ () x) x)
2048 ((_ (f ... r) y)
2049 (class-decor (f ...) (r y)))))
2050
2051 (define-syntax def-decor
2052 (syntax-rules ()
2053 ((_ () x) x)
2054 ((_ (f ... r) y)
2055 (def-decor (f ...) (r y)))))
2056
2057 (define-syntax with-self
2058 (syntax-rules ()
2059 ((_ #f _ c)
2060 c)
2061 ((_ _ (s . b) c)
2062 (syntax-parameterize ((*self* (lambda (x) #'s))) c))))
2063
2064 (define-syntax with-class
2065 (syntax-rules ()
2066 ((_ s c)
2067 (syntax-parameterize ((*class* (lambda (x) #'s))) c))))
2068
2069
2070 (define-syntax boolit
2071 (syntax-rules (and or not < <= > >=)
2072 ((_ (and x y)) (and (boolit x) (boolit y)))
2073 ((_ (or x y)) (or (boolit x) (boolit y)))
2074 ((_ (not x )) (not (boolit x)))
2075 ((_ (< x y)) (< x y))
2076 ((_ (<= x y)) (<= x y))
2077 ((_ (> x y)) (> x y))
2078 ((_ (>= x y)) (>= x y))
2079 ((_ #t) #t)
2080 ((_ #f) #f)
2081 ((_ x ) (bool x))))
2082
2083 (define (export-all)
2084 (define mod (current-module))
2085 (if (module-defined? mod '__all__)
2086 (module-export! mod
2087 (for ((x : (module-ref mod '__all__))) ((l '()))
2088 (cons (string->symbol (scm-str x)) l)
2089 #:final l))))
2090