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