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