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