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