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