ab9b8f6d2fb029ee16bc7e53806716b634fc5f28
[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 p x)
601 (if (or (equal? p "r") (equal? p "R"))
602 `((@ (language python str) str) ,x)
603 x)))
604
605 (#:+
606 ((_ . l)
607 (cons '+ (map (g vs exp) l))))
608
609 (#:-
610 ((_ . l)
611 (cons '- (map (g vs exp) l))))
612
613 (#:*
614 ((_ . l)
615 (cons '* (map (g vs exp) l))))
616
617 (#:/
618 ((_ . l)
619 (cons (N 'py-/) (map (g vs exp) l))))
620
621 (#:%
622 ((_ . l)
623 (cons (N 'py-mod) (map (g vs exp) l))))
624
625 (#://
626 ((_ . l)
627 (cons (N 'py-floordiv) (map (g vs exp) l))))
628
629 (#:<<
630 ((_ . l)
631 (cons (N 'py-lshift) (map (g vs exp) l))))
632
633 (#:>>
634 ((_ . l)
635 (cons (N 'py-rshift) (map (g vs exp) l))))
636
637 (#:u~
638 ((_ x)
639 (list (N 'py-lognot) (exp vs x))))
640
641 (#:u-
642 ((_ x)
643 (list '- (exp vs x))))
644
645 (#:u+
646 ((_ x)
647 (list '+ (exp vs x))))
648
649 (#:band
650 ((_ . l)
651 (cons (N 'py-logand) (map (g vs exp) l))))
652
653 (#:bxor
654 ((_ . l)
655 (cons (N 'py-logxor) (map (g vs exp) l))))
656
657 (#:bor
658 ((_ . l)
659 (cons (N 'py-logior) (map (g vs exp) l))))
660
661 (#:not
662 ((_ x)
663 (list 'not (exp vs x))))
664
665 (#:or
666 ((_ . x)
667 (cons 'or (map (g vs exp) x))))
668
669 (#:and
670 ((_ . x)
671 (cons 'and (map (g vs exp) x))))
672
673 (#:test
674 ((_ e1 #f)
675 (exp vs e1))
676
677 ((_ e1 e2 e3)
678 (list 'if (exp vs e2) (exp vs e1) (exp vs e3))))
679
680 (#:del
681 ;;We don't delete variables
682 ((_ (#:power #f base () . #f))
683 '(void))
684
685 ((_ (#:power #f base (l ... fin) . #f))
686 (let ((add (get-addings vs l))
687 (fin (get-addings vs (list fin)))
688 (f (exp vs base)))
689 `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin))))
690
691 (#:if
692 ((_ test a ((tests . as) ...) . else)
693 `(,(G 'cond)
694 (,(exp vs test) ,(exp vs a))
695 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
696 ,@(if else `((else ,(exp vs else))) '()))))
697
698 (#:suite
699 ((_ . l) (cons 'begin (map (g vs exp) l))))
700
701 (#:classdef
702 ((_ (#:identifier class . _) parents defs)
703 (with-fluids ((is-class? #t))
704 (let ()
705 (define (filt l)
706 (reverse
707 (fold (lambda (x s)
708 (match x
709 ((or 'fast 'functional) s)
710 (x (cons x s))))
711 '() l)))
712 (define (is-functional l)
713 (fold (lambda (x pred)
714 (if pred
715 pred
716 (match x
717 ('functional #t)
718 (_ #f))))
719 #f l))
720 (define (is-fast l)
721 (fold (lambda (x pred)
722 (if pred
723 pred
724 (match x
725 ('fast #t)
726 (_ #f))))
727 #f l))
728
729 (let* ((decor (let ((r (fluid-ref decorations)))
730 (fluid-set! decorations '())
731 r))
732 (class (string->symbol class))
733 (parents (match parents
734 (()
735 '())
736 (#f
737 '())
738 ((#:arglist args . _)
739 (map (g vs exp) args))))
740 (is-func (is-functional parents))
741 (is-fast (is-fast parents))
742 (kind (if is-func
743 (if is-fast
744 'mk-pf-class
745 'mk-pyf-class)
746 (if is-fast
747 'mk-p-class
748 'mk-py-class)))
749 (parents (filt parents)))
750 `(define ,class
751 (,(C 'class-decor) ,decor
752 (,(C 'with-class) ,class
753 (,(O kind)
754 ,class
755 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
756 #:const
757 ()
758 #:dynamic
759 ,(match (filter-defs (exp vs defs))
760 (('begin . l)
761 l)
762 ((('begin . l))
763 l)
764 (l l)))))))))))
765
766 (#:scm
767 ((_ (#:string _ s)) (with-input-from-string s read)))
768
769 (#:import
770 ((_ (#:from (() nm) . #f))
771 `(use-modules (language python module ,(exp vs nm))))
772
773 ((_ (#:name ((ids ...) . as) ...))
774 `(begin
775 ,@(map (lambda (ids as)
776 (let* ((syms (map (g vs exp) ids))
777 (id (if as (exp vs as) (car (reverse syms)))))
778 (add-prefix id)
779 `(use-modules ((language python module ,@syms)
780 #:prefix
781 ,(string->symbol
782 (string-append (symbol->string id) "."))))))
783 ids as))))
784
785
786
787
788 (#:for
789 ((_ e in code . #f)
790 (=> next)
791 (match e
792 (((#:power #f (#:identifier x . _) () . #f))
793 (match in
794 (((#:test power . _))
795 (match power
796 ((#:power #f
797 (#:identifier "range" . _)
798 ((#:arglist arglist . _))
799 . _)
800 (match arglist
801 ((arg)
802 (let ((v (gensym "v"))
803 (x (string->symbol x))
804 (lp (gensym "lp")))
805 `(let ((,v ,(exp vs arg)))
806 (let ,lp ((,x 0))
807 (if (< ,x ,v)
808 (begin
809 ,(exp vs code)
810 (,lp (+ ,x 1))))))))
811 ((arg1 arg2)
812 (let ((v1 (gensym "va"))
813 (v2 (gensym "vb"))
814 (lp (gensym "lp")))
815 `(let ((,v1 ,(exp vs arg1))
816 (,v2 ,(exp vs arg2)))
817 (let ,lp ((,x ,v1))
818 (if (< ,x ,v2)
819 (begin
820 ,(exp vs code)
821 (,lp (+ ,x 1))))))))
822 ((arg1 arg2 arg3)
823 (let ((v1 (gensym "va"))
824 (v2 (gensym "vb"))
825 (st (gensym "vs"))
826 (lp (gensym "lp")))
827 `(let ((,v1 ,(exp vs arg1))
828 (,st ,(exp vs arg2))
829 (,v2 ,(exp vs arg3)))
830 (if (> st 0)
831 (let ,lp ((,x ,v1))
832 (if (< ,x ,v2)
833 (begin
834 ,(exp vs code)
835 (,lp (+ ,x ,st)))))
836 (if (< st 0)
837 (let ,lp ((,x ,v1))
838 (if (> ,x ,v2)
839 (begin
840 ,(exp vs code)
841 (,lp (+ ,x ,st)))))
842 (error "range with step 0 not allowed"))))))
843 (_ (next))))
844 (_ (next))))
845 (_ (next))))
846 (_ (next))))
847
848 ((_ es in code . else)
849 (let* ((es2 (map (g vs exp) es))
850 (vs2 (union es2 vs))
851 (code2 (exp vs2 code))
852 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
853 (else2 (if else (exp vs2 else) #f))
854 (in2 (map (g vs exp) in)))
855 (list (C 'for) es2 in2 code2 else2 p))))
856
857
858 (#:while
859 ((_ test code . #f)
860 (let ((lp (gensym "lp")))
861 `(let ,lp ()
862 (if ,(exp vs test)
863 (begin
864 ,(exp vs code)
865 (,lp))))))
866
867 ((_ test code else)
868 (let ((lp (gensym "lp")))
869 `(let ,lp ()
870 (if test
871 (begin
872 ,(exp vs code)
873 (,lp))
874 ,(exp vs else))))))
875
876 (#:try
877 ((_ x (or #f ()) #f . fin)
878 (if fin
879 `(,(T 'try) ,(exp vs x) #:finally (lambda () fin))
880 (exp vs x)))
881
882
883 ((_ x exc else . fin)
884 `(,(T 'try) ,(exp vs x)
885 ,@(let lp ((exc exc) (r (if else (exp vs else) '())))
886 (match exc
887 ((((test . #f) code) . exc)
888 (lp exc (cons `(#:except ,(exp vs code)) r)))
889
890 ((((test . as) code) . exc)
891 (let ((l (gensym "l")))
892 (lp exc
893 (cons
894 `(#:except ,(exp vs test) => (lambda (,(exp vs as) . ,l)
895 ,(exp vs code)))
896 r))))
897 (()
898 (reverse r))))
899 ,@(if fin `(#:finally (lambda () ,(exp vs fin))) '()))))
900
901 (#:subexpr
902 ((_ . l)
903 (exp vs l)))
904
905 (#:raise
906 ((_ #f . #f)
907 `(,(T 'raise) (,(O 'Exception))))
908
909 ((_ code . #f)
910 `(,(T 'raise) ,(exp vs code)))
911
912 ((_ code . from)
913 (let ((o (gensym "o"))
914 (c (gensym "c")))
915 `(,(T 'raise)
916 (let ((,c ,(exp vs code)))
917 (let ((,o (if (,(O 'pyclass?) ,c)
918 (,c)
919 ,c)))
920 (,(O 'set) ,o '__cause__ ,(exp vs from))
921 ,o))))))
922
923
924 (#:yield
925 ((_ args)
926 (let ((f (gensym "f")))
927 `(begin
928 (fluid-set! ,(Y 'in-yield) #t)
929 (let ((,f (scm.yield ,@(gen-yargs vs args))))
930 (,f)))))
931
932
933 ((_ f args)
934 (let ((f (gen-yield (exp vs f)))
935 (g (gensym "f")))
936 `(begin
937 (set! ,(C 'inhibit-finally) #t)
938 (let ((,g (,f ,@(gen-yargs vs args))))
939 (,g))))))
940
941 (#:def
942 ((_ f
943 (#:types-args-list
944 args
945 *e **e)
946 #f
947 code)
948 (let* ((decor (let ((r (fluid-ref decorations)))
949 (fluid-set! decorations '())
950 r))
951 (args (get-kwarg-def vs args))
952 (c? (fluid-ref is-class?))
953 (f (exp vs f))
954 (y? (is-yield f #f code))
955 (r (gensym "return"))
956 (*f (match *e
957 (((e . #f) ()) (list (list '* (exp vs e))))
958 (#f '())))
959 (dd2 (match *e
960 (((e . #f) ()) (list (exp vs e)))
961 (#f '())))
962 (**f (match **e
963 ((e . #f) (list (list '** (exp vs e))))
964 (#f '())))
965 (dd3 (match **e
966 ((e . #f) (list (exp vs e)))
967 (#f '())))
968 (as (map (lambda (x) (match x
969 (('= a _) a)
970 (a a)))
971 args))
972 (ab (gensym "ab"))
973 (vs (union dd3 (union dd2 (union as vs))))
974 (ns (scope code vs))
975 (df (defs code '()))
976 (ex (gensym "ex"))
977 (y 'scm.yield)
978 (y.f (gen-yield f))
979 (ls (diff (diff ns vs) df)))
980
981 (define (mk code)
982 `(let-syntax ((,y (syntax-rules ()
983 ((_ . args)
984 (abort-to-prompt ,ab . args))))
985 (,y.f (syntax-rules ()
986 ((_ . args)
987 (abort-to-prompt ,ab . args)))))
988 ,code))
989
990 (with-fluids ((is-class? #f))
991 (if c?
992 (if y?
993 `(define ,f
994 (,(C 'def-decor) ,decor
995 (,(C 'def-wrap) ,y? ,f ,ab
996 (,(D 'lam) (,@args ,@*f ,@**f)
997 (,(C 'with-return) ,r
998 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
999 (,(C 'with-self) ,c? ,args
1000 ,(with-fluids ((return r))
1001 (exp ns code))))))))))
1002
1003 `(define ,f
1004 (,(C 'def-decor) ,decor
1005 (,(D 'lam) (,@args ,@*f ,@**f)
1006 (,(C 'with-return) ,r
1007 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
1008 (,(C 'with-self) ,c? ,args
1009 ,(with-fluids ((return r))
1010 (exp ns code))))))))))
1011
1012 (if y?
1013 `(define ,f
1014 (,(C 'def-decor) ,decor
1015 (,(C 'def-wrap) ,y? ,f ,ab
1016 (,(D 'lam) (,@args ,@*f ,@**f)
1017 (,(C 'with-return) ,r
1018 (let ,(map (lambda (x) (list x #f)) ls)
1019 (,(C 'with-self) ,c? ,args
1020 ,(with-fluids ((return r))
1021 (mk
1022 (exp ns code))))))))))
1023 `(define ,f
1024 (,(C 'def-decor) ,decor
1025 (,(D 'lam) (,@args ,@*f ,@**f)
1026 (,(C 'with-return) ,r
1027 (let ,(map (lambda (x) (list x #f)) ls)
1028 (,(C 'with-self) ,c? ,args
1029 ,(with-fluids ((return r))
1030 (exp ns code))))))))))))))
1031
1032 (#:global
1033 ((_ . _)
1034 '(values)))
1035
1036 (#:list
1037 ((_ x (and e (#:cfor . _)))
1038 (let ((l (gensym "l")))
1039 `(let ((,l (,(L 'to-pylist) '())))
1040 ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
1041 ,l)))
1042
1043 ((_ . l)
1044 (list (L 'to-pylist) (let lp ((l l))
1045 (match l
1046 ((or () #f) ''())
1047 (((#:starexpr #:power #f (#:list . l) . _) . _)
1048 (lp l))
1049 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1050 (lp l))
1051 (((#:starexpr . l) . _)
1052 `(,(L 'to-list) ,(exp vs l)))
1053 ((x . l)
1054 `(cons ,(exp vs x) ,(lp l))))))))
1055 (#:tuple
1056 ((_ x (and e (#:cfor . _)))
1057 (let ((l (gensym "l")))
1058 `(let ((,l '()))
1059 ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
1060 (reverse ,l))))
1061
1062 ((_ . l)
1063 (let lp ((l l))
1064 (match l
1065 (() ''())
1066 (((#:starexpr #:power #f (#:list . l) . _) . _)
1067 (lp l))
1068 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1069 (lp l))
1070 (((#:starexpr . l) . _)
1071 `(,(L 'to-list) ,(exp vs l)))
1072 ((x . l)
1073 `(cons ,(exp vs x) ,(lp l)))))))
1074
1075 (#:lambdef
1076 ((_ v e)
1077 (list `lambda v (exp vs e))))
1078
1079 (#:stmt
1080 ((_ l)
1081 (if (> (length l) 1)
1082 (cons 'values (map (g vs exp) l))
1083 (exp vs (car l)))))
1084
1085
1086 (#:expr-stmt
1087 ((_ (l ...) (#:assign))
1088 `(,(G 'values) ,@(map (g vs exp) l)))
1089
1090 ((_ l type)
1091 (=> fail)
1092 (call-with-values
1093 (lambda () (match type
1094 ((#:assign u)
1095 (values #f u))
1096 ((#:augassign op u)
1097 (values op u))
1098 (_ (fail))))
1099
1100 (lambda (op u)
1101 (cond
1102 ((= (length l) (length u))
1103 (if (= (length l) 1)
1104 `(begin
1105 ,(make-set vs op (car l) (exp vs (car u)))
1106 (values))
1107 `(begin
1108 @,(map (lambda (l u) (make-set vs op l u))
1109 l
1110 (map (g vs exp) u))
1111 (values))))
1112
1113 ((and (= (length u) 1) (not op))
1114 (let ((vars (map (lambda (x) (gensym "v")) l))
1115 (q (gensym "q"))
1116 (f (gensym "f")))
1117 `(begin
1118 (call-with-values (lambda () ,(exp vs (car u)))
1119 (letrec ((,f
1120 (case-lambda
1121 ((,q)
1122 (if (pair? ,q)
1123 (apply ,f ,q)
1124 (apply ,f (,(L 'to-list) ,q))))
1125 (,vars
1126 ,@(map (lambda (l v) (make-set vs op l v))
1127 l vars)))))
1128 ,f))
1129 (values))))
1130
1131 ((and (= (length l) 1) (not op))
1132 `(begin
1133 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
1134 (values)))))))
1135
1136 ((_
1137 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
1138 (#:assign (l)))
1139 (let ((s (string->symbol v)))
1140 `(,s/d ,s ,(exp vs l)))))
1141
1142
1143 (#:return
1144 ((_ . x)
1145 `(,(fluid-ref return) ,@(map (g vs exp) x))))
1146
1147 (#:dict
1148 ((_ . #f)
1149 `(,(Di 'make-py-hashtable)))
1150
1151 ((_ (#:e k . v) (and e (#:cfor . _)))
1152 (let ((dict (gensym "dict")))
1153 `(let ((,dict (,(Di 'make-py-hashtable))))
1154 ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1155 ,dict)))
1156
1157 ((_ (#:e k . v) ...)
1158 (let ((dict (gensym "dict")))
1159 `(let ((,dict (,(Di 'make-py-hashtable))))
1160 ,@(map (lambda (k v)
1161 `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
1162 k v)
1163 ,dict)))
1164
1165 ((_ k (and e (#:cfor . _)))
1166 (let ((dict (gensym "dict")))
1167 `(let ((,dict (,(Se 'set))))
1168 ,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k)))
1169 ,dict)))
1170
1171 ((_ k ...)
1172 (let ((set (gensym "dict")))
1173 `(let ((,set (,(Se 'set))))
1174 ,@(map (lambda (k)
1175 `((,(O 'ref) ,set 'add) ,(exp vs k)))
1176 k)
1177 ,set))))
1178
1179
1180 (#:comp
1181 ((_ x #f)
1182 (exp vs x))
1183
1184 ((_ x (op . y))
1185 (define (tr op x y)
1186 (match op
1187 ((or "<" ">" "<=" ">=")
1188 (list (G (string->symbol op)) x y))
1189 ("!=" (list (G 'not) (list (O 'equal?) x y)))
1190 ("==" (list (O 'equal?) x y))
1191 ("is" (list (G 'eq?) x y))
1192 ("isnot" (list (G 'not) (list (G 'eq?) x y)))
1193 ("in" (list (L 'in) x y))
1194 ("notin" (list (G 'not) (list (L 'in) x y)))
1195 ("<>" (list (G 'not) (list (O 'equal?) x y)))))
1196 (tr op (exp vs x) (exp vs y)))))
1197
1198 (define (exp vs x)
1199 (match (pr x)
1200 ((e)
1201 (exp vs e))
1202 ((tag . l)
1203 ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))
1204
1205 (#:True #t)
1206 (#:None (E 'None))
1207 (#:null ''())
1208 (#:False #f)
1209 (#:pass `(values))
1210 (#:break
1211 (C 'break))
1212 (#:continue
1213 (C 'continue))
1214 (x x)))
1215
1216 (define-syntax-rule (define- n x) (define! 'n x))
1217
1218 (define (comp x)
1219 (define start
1220 (match (pr 'start x)
1221 (((#:stmt
1222 ((#:expr-stmt
1223 ((#:test
1224 (#:power #f
1225 (#:identifier "module" . _)
1226 ((#:arglist arglist #f #f))
1227 . #f) #f))
1228 (#:assign)))) . _)
1229 (let ()
1230 (define args
1231 (map (lambda (x)
1232 (exp '() x))
1233 arglist))
1234
1235 `((,(G 'define-module)
1236 (language python module ,@args)
1237 #:use-module (language python module python)))))
1238 (x '())))
1239
1240 (if (fluid-ref (@@ (system base compile) %in-compile))
1241 (with-fluids ((*prefixes* '()))
1242 (if (fluid-ref (@@ (system base compile) %in-compile))
1243 (set! s/d 'set!)
1244 (set! s/d (C 'define-)))
1245
1246 (if (pair? start)
1247 (set! x (cdr x)))
1248
1249 (let ((globs (get-globals x)))
1250 `(begin
1251 ,@start
1252 ,(C 'clear-warning-data)
1253 (set! (@@ (system base message) %dont-warn-list) '())
1254 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1255 ,@(map (g globs exp) x))))
1256 (begin
1257 (if (fluid-ref (@@ (system base compile) %in-compile))
1258 (set! s/d 'set!)
1259 (set! s/d (C 'define-)))
1260
1261 (if (pair? start)
1262 (set! x (cdr x)))
1263
1264 (let ((globs (get-globals x)))
1265 `(begin
1266 ,@start
1267 ,(C 'clear-warning-data)
1268 (set! (@@ (system base message) %dont-warn-list) '())
1269 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
1270 ,@(map (g globs exp) x))))))
1271
1272 (define-syntax-parameter break
1273 (lambda (x) #'(values)))
1274
1275 (define-syntax-parameter continue
1276 (lambda (x) (error "continue must be bound")))
1277
1278 (define (is-yield f p x)
1279 (match x
1280 ((#:def nm args _ code)
1281 (is-yield f #t code))
1282 ((#:yield x _)
1283 (eq? f (exp '() x)))
1284 ((#:yield _)
1285 (not p))
1286 ((a . l)
1287 (or
1288 (is-yield f p a)
1289 (is-yield f p l)))
1290 (_
1291 #f)))
1292
1293
1294
1295 (define-syntax-rule (with-sp ((x v) ...) code ...)
1296 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
1297
1298 (define (is-ec ret x tail tags)
1299 (syntax-case (pr 'is-ec x) (begin let if define @@)
1300 ((begin a ... b)
1301 #t
1302 (or
1303 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1304 (is-ec ret #'b tail tags)))
1305
1306 ((let lp ((y x) ...) a ... b)
1307 (symbol? (syntax->datum #'lp))
1308 (or
1309 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1310 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1311 (is-ec ret #'b tail tags)))
1312
1313 ((let ((y x) ...) a ... b)
1314 #t
1315 (or
1316 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
1317 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
1318 (is-ec ret #'b tail tags)))
1319
1320 ((if p a b)
1321 #t
1322 (or
1323 (is-ec ret #'p #f tags)
1324 (is-ec ret #'a tail tags)
1325 (is-ec ret #'b tail tags)))
1326
1327 ((define . _)
1328 #t
1329 #f)
1330
1331 ((if p a)
1332 #t
1333 (or
1334 (is-ec ret #'p #f tags)
1335 (is-ec ret #'a tail tags)))
1336
1337 ((@@ _ _)
1338 #t
1339 (if (member (pr (syntax->datum x)) tags)
1340 #t
1341 #f))
1342
1343 ((a ...)
1344 #t
1345 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
1346
1347 (x
1348 #t
1349 #f)))
1350
1351 (define-syntax with-return
1352 (lambda (x)
1353 (define (analyze ret x)
1354 (syntax-case x (begin let if)
1355 ((begin a ... b)
1356 #`(begin a ... #,(analyze ret #'b)))
1357 ((let lp v a ... b)
1358 (symbol? (syntax->datum #'lp))
1359 #`(let lp v a ... #,(analyze ret #'b)))
1360 ((let v a ... b)
1361 #`(let v a ... #,(analyze ret #'b)))
1362 ((if p a b)
1363 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
1364 ((if p a)
1365 #`(if p #,(analyze ret #'a)))
1366 ((return a b ...)
1367 (equal? (syntax->datum #'return) (syntax->datum ret))
1368 (if (eq? #'(b ...) '())
1369 #'a
1370 #`(values a b ...)))
1371 (x #'x)))
1372
1373 (define (is-ec ret x tail)
1374 (syntax-case x (begin let if define @@)
1375 ((begin a ... b)
1376 #t
1377 (or
1378 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1379 (is-ec ret #'b tail)))
1380
1381 ((let lp ((y x) ...) a ... b)
1382 (symbol? (syntax->datum #'lp))
1383 (or
1384 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1385 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1386 (is-ec ret #'b tail)))
1387
1388 ((let ((y x) ...) a ... b)
1389 #t
1390 (or
1391 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
1392 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
1393 (is-ec ret #'b tail)))
1394
1395 ((define . _)
1396 #t
1397 #f)
1398
1399 ((if p a b)
1400 #t
1401 (or
1402 (is-ec ret #'p #f)
1403 (is-ec ret #'a tail)
1404 (is-ec ret #'b tail)))
1405
1406 ((if p a)
1407 #t
1408 (or
1409 (is-ec ret #'p #f)
1410 (is-ec ret #'a tail)))
1411
1412 ((return a b ...)
1413 (equal? (syntax->datum #'return) (syntax->datum ret))
1414 (not tail))
1415
1416 ((a ...)
1417 #t
1418 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
1419
1420 (x
1421 #t
1422 #f)))
1423
1424 (syntax-case x ()
1425 ((_ ret l)
1426 (let ((code (analyze #'ret #'l)))
1427 (if (is-ec #'ret #'l #t)
1428 #`(let/ec ret #,code)
1429 code))))))
1430
1431 (define-syntax var
1432 (lambda (x)
1433 (syntax-case x ()
1434 ((_ v)
1435 (begin
1436 (dont-warn (syntax->datum #'v))
1437 #'(if (module-defined? (current-module) 'v)
1438 (values)
1439 (define! 'v #f)))))))
1440
1441 (define-inlinable (non? x) (eq? x #:nil))
1442
1443 (define (gentemp stx) (datum->syntax stx (gensym "x")))
1444
1445 (define-syntax for
1446 (syntax-rules ()
1447 ((_ (x) (a) code #f #f)
1448 (if (pair? a)
1449 (let lp ((l a))
1450 (if (pair? l)
1451 (let ((x (car l)))
1452 (with-sp ((continue (lp (cdr l)))
1453 (break (values)))
1454 code
1455 (lp (cdr l))))))
1456 (for/adv1 (x) (a) code #f #f)))
1457
1458 ((_ (x) (a) code #f #t)
1459 (if (pair? a)
1460 (let/ec break-ret
1461 (let lp ((l a))
1462 (if (pair? l)
1463 (begin
1464 (let/ec continue-ret
1465 (let ((x (car l)))
1466 (with-sp ((continue (continue-ret))
1467 (break (break-ret)))
1468 code)))
1469 (lp (cdr l))))))
1470 (for/adv1 (x) (a) code #f #t)))
1471
1472 ((_ (x) (a) code next #f)
1473 (if (pair? a)
1474 (let/ec break-ret
1475 (let ((x (let lp ((l a) (old #f))
1476 (if (pair? l)
1477 (let ((x (car l)))
1478 (let/ec continue-ret
1479 (with-sp ((continue (continue-ret))
1480 (break (break-ret)))
1481 code))
1482 (lp (cdr l)))
1483 old))))
1484 next))
1485 (for/adv1 (x) (a) code next #f)))
1486
1487 ((_ x a code next p)
1488 (for/adv1 x a code next p))))
1489
1490 (define-syntax for/adv1
1491 (lambda (x)
1492 (syntax-case x ()
1493 ((_ (x ...) (in) code #f #f)
1494 (with-syntax ((inv (gentemp #'in)))
1495 #'(let ((inv (wrap-in in)))
1496 (catch StopIteration
1497 (lambda ()
1498 (let lp ()
1499 (call-with-values (lambda () (next inv))
1500 (lambda (x ...)
1501 (with-sp ((break (values))
1502 (continue (values)))
1503 code
1504 (lp))))))
1505 (lambda z (values))))))
1506
1507 ((_ (x ...) (in ...) code #f #f)
1508 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1509 #'(let ((inv (wrap-in in)) ...)
1510 (catch StopIteration
1511 (lambda ()
1512 (let lp ()
1513 (call-with-values (lambda () (values (next inv) ...))
1514 (lambda (x ...)
1515 (with-sp ((break (values))
1516 (continue (values)))
1517 code
1518 (lp))))))
1519 (lambda z (values))))))
1520
1521 ((_ (x ...) (in) code #f #t)
1522 (with-syntax ((inv (gentemp #'in)))
1523 #'(let ((inv (wrap-in in)))
1524 (let lp ()
1525 (let/ec break-ret
1526 (catch StopIteration
1527 (lambda ()
1528 (call-with-values (lambda () (next inv))
1529 (lambda (x ...)
1530 (let/ec continue-ret
1531 (with-sp ((break (break-ret))
1532 (continue (continue-ret)))
1533 code))
1534 (lp))))
1535 (lambda z (values))))))))
1536
1537 ((_ (x ...) (in ...) code #f #t)
1538 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1539 #'(let ((inv (wrap-in in)) ...)
1540 (let lp ()
1541 (let/ec break-ret
1542 (catch StopIteration
1543 (lambda ()
1544 (call-with-values (lambda () (values (next inv) ...))
1545 (lambda (x ...)
1546 (let/ec continue-ret
1547 (with-sp ((break (break-ret))
1548 (continue (continue-ret)))
1549 code))
1550 (lp))))
1551 (lambda z (values))))))))
1552
1553 ((_ (x ...) in code else #f)
1554 #'(for-adv (x ...) in code else #f))
1555
1556 ((_ (x ...) in code else #t)
1557 #'(for-adv (x ...) in code else #t)))))
1558
1559
1560 (define-syntax for-adv
1561 (lambda (x)
1562 (define (gen x y)
1563 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
1564 (syntax-case x ()
1565 ((x ...) #'(values (next x) ...)))
1566 (syntax-case x ()
1567 ((x) #'(next x)))))
1568
1569 (syntax-case x ()
1570 ((_ (x ...) (in) code else p)
1571 (with-syntax ((inv (gentemp #'in)))
1572 (with-syntax (((xx ...) (generate-temporaries #'(x ...))))
1573 (if (syntax->datum #'p)
1574 #'(let ((inv (wrap-in in)))
1575 (let/ec break-ret
1576 (let ((x #f) ...)
1577 (catch StopIteration
1578 (lambda ()
1579 (let lp ()
1580 (call-with-values (lambda () (next inv))
1581 (lambda (xx ...)
1582 (set! x xx) ...
1583 (let/ec continue-ret
1584 (with-sp ((break (break-ret))
1585 (continue (continue-ret)))
1586 code))
1587 (lp)))))
1588 (lambda q else)))))
1589
1590 #'(let ((inv (wrap-in in)))
1591 (let ((x #f) ...)
1592 (let/ec break-ret
1593 (catch StopIteration
1594 (lambda ()
1595 (let lp ()
1596 (call-with-values (lambda () (next inv))
1597 (lambda (xx ...)
1598 (set! x xx) ...
1599 (with-sp ((break (break-ret))
1600 (continue (values)))
1601 code)
1602 (lp)))))
1603 (lambda e else)))))))))
1604
1605 ((_ (x ...) (in ...) code else p)
1606 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
1607 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
1608 ((xx ...) (generate-temporaries #'(x ...))))
1609 (if (syntax->datum #'p)
1610 #'(let ((inv (wrap-in in)) ...)
1611 (let/ec break-ret
1612 (let ((x #f) ...)
1613 (catch StopIteration
1614 (lambda ()
1615 (let lp ()
1616 (call-with-values (lambda () get)
1617 (lambda (xx ...)
1618 (set! x xx) ...
1619 (let/ec continue-ret
1620 (with-sp ((break (break-ret))
1621 (continue (continue-ret)))
1622 code))
1623 (lp)))))
1624 (lambda q else)))))
1625
1626 #'(let ((inv (wrap-in in)) ...)
1627 (let ((x #f) ...)
1628 (let/ec break-ret
1629 (catch StopIteration
1630 (lambda ()
1631 (let lp ()
1632 (call-with-values (lambda () get)
1633 (lambda (xx ...)
1634 (set! x xx) ...
1635 (with-sp ((break (break-ret))
1636 (continue (values)))
1637 code)
1638 (lp)))))
1639 (lambda e else))))))))))))
1640
1641 (define-syntax def-wrap
1642 (lambda (x)
1643 (syntax-case x ()
1644 ((_ #f f ab x)
1645 (pr 'def-wrap #'f 'false)
1646 #'x)
1647
1648 ((_ #t f ab code)
1649 (pr 'def-wrap #'f 'true)
1650 #'(lambda x
1651 (define obj (make <yield>))
1652 (define ab (make-prompt-tag))
1653 (slot-set! obj 'k #f)
1654 (slot-set! obj 'closed #f)
1655 (slot-set! obj 's
1656 (lambda ()
1657 (call-with-prompt
1658 ab
1659 (lambda ()
1660 (let/ec return
1661 (apply code x))
1662 (slot-set! obj 'closed #t)
1663 (throw StopIteration))
1664 (letrec ((lam
1665 (lambda (k . l)
1666 (fluid-set! in-yield #f)
1667 (slot-set! obj 'k
1668 (lambda (a)
1669 (call-with-prompt
1670 ab
1671 (lambda ()
1672 (k a))
1673 lam)))
1674 (apply values l))))
1675 lam))))
1676 obj)))))
1677
1678 (define-syntax ref-x
1679 (syntax-rules ()
1680 ((_ v)
1681 v)
1682 ((_ v (#:fastfkn-ref f _) . l)
1683 (ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l))
1684 ((_ v (#:fast-id f _) . l)
1685 (ref-x (f v) . l))
1686 ((_ v (#:identifier x) . l)
1687 (ref-x (refq v x) . l))
1688 ((_ v (#:identifier x) . l)
1689 (ref-x (refq v x) . l))
1690 ((_ v (#:call-obj x) . l)
1691 (ref-x (x v) . l))
1692 ((_ v (#:call x ...) . l)
1693 (ref-x (v x ...) . l))
1694 ((_ v (#:apply x ...) . l)
1695 (ref-x (apply v x ...) . l))
1696 ((_ v (#:apply x ...) . l)
1697 (ref-x (apply v x ...) . l))
1698 ((_ v (#:vecref x) . l)
1699 (ref-x (pylist-ref v x) . l))
1700 ((_ v (#:vecsub . x) . l)
1701 (ref-x (pylist-slice v . x) . l))))
1702
1703 (define-syntax del-x
1704 (syntax-rules ()
1705 ((_ v (#:identifier x))
1706 (ref-x (refq v 'x)))
1707 ((_ v (#:call-obj x))
1708 (values))
1709 ((_ v (#:call x ...))
1710 (values))
1711 ((_ v (#:apply x ...))
1712 (values))
1713 ((_ v (#:vecref x))
1714 (pylist-delete! v x))
1715 ((_ v (#:vecsub x ...))
1716 (pylist-subset! v x ... pylist-null))))
1717
1718 (define-syntax set-x
1719 (syntax-rules ()
1720 ((_ v (a ... b) val)
1721 (set-x-2 (ref-x v a ...) b val))))
1722
1723 (define-syntax set-x-2
1724 (syntax-rules ()
1725 ((_ v (#:fastfkn-ref f id) val)
1726 (set v id val))
1727 ((_ v (#:fastid-ref f id) val)
1728 (set v id val))
1729 ((_ v (#:identifier x) val)
1730 (set v x val))
1731 ((_ v (#:vecref n) val)
1732 (pylist-set! v n val))
1733 ((_ v (#:vecsub x ...) val)
1734 (pylist-subset! v x ... val))))
1735
1736
1737 (define-syntax class-decor
1738 (syntax-rules ()
1739 ((_ () x) x)
1740 ((_ (f ... r) y)
1741 (class-decor (f ...) (r y)))))
1742
1743 (define-syntax def-decor
1744 (syntax-rules ()
1745 ((_ () x) x)
1746 ((_ (f ... r) y)
1747 (def-decor (f ...) (r y)))))
1748
1749 (define-syntax with-self
1750 (syntax-rules ()
1751 ((_ #f _ c)
1752 c)
1753 ((_ _ (s . b) c)
1754 (syntax-parameterize ((*self* (lambda (x) #'s))) c))))
1755
1756 (define-syntax with-class
1757 (syntax-rules ()
1758 ((_ s c)
1759 (syntax-parameterize ((*class* (lambda (x) #'s))) c))))