projects / software / python-on-guile.git / blob
? search:


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