remove warnings, reordering
[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 format2) #:select (fnm))
22 #:use-module ((language python with) #:select ())
23 #:use-module (ice-9 pretty-print)
24 #:export (comp exit-fluid exit-prompt pks do-pr))
25
26 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
27
28 (define-inlinable (C x) `(@@ (language python compile) ,x))
29 (define-inlinable (F2 x) `(@@ (language python format2) ,x))
30 (define-inlinable (N x) `(@@ (language python number) ,x))
31 (define-inlinable (Y x) `(@@ (language python yield) ,x))
32 (define-inlinable (T x) `(@@ (language python try) ,x))
33 (define-inlinable (F x) `(@@ (language python for) ,x))
34 (define-inlinable (E x) `(@@ (language python exceptions) ,x))
35 (define-inlinable (L x) `(@@ (language python list) ,x))
36 (define-inlinable (S x) `(@@ (language python string) ,x))
37 (define-inlinable (B x) `(@@ (language python bytes) ,x))
38 (define-inlinable (Se x) `(@@ (language python set) ,x))
39 (define-inlinable (D x) `(@@ (language python def) ,x))
40 (define-inlinable (Di x) `(@@ (language python dict) ,x))
41 (define-inlinable (O x) `(@@ (oop pf-objects) ,x))
42 (define-inlinable (G x) `(@ (guile) ,x))
43 (define-inlinable (H x) `(@ (language python hash) ,x))
44 (define-inlinable (W x) `(@ (language python with) ,x))
45
46 (define (mk/ec x) x)
47
48 (define-syntax-rule (let/ecx c a ...)
49 (let/ec c a ...))
50
51 (define-syntax-rule (let/ect c a ...)
52 (let/ec c ((mk/ec (lambda (c) a ...)) c)))
53
54 (eval-when (compile eval load)
55 (if (equal? (effective-version) "3.0")
56 (module-set! (current-module) 'let/ecx
57 (module-ref (current-module) 'let/ect))))
58
59 (define exit-prompt (make-prompt-tag))
60 (define exit-fluid (make-fluid #f))
61
62 (define (formatter . x) "<missing>")
63
64 (define (mk-string vs l)
65 (define (mk-string2 x)
66 (if (string? x)
67 x
68 (let ((l (let lp ((l x))
69 (match l
70 ((x . l)
71 (cons
72 (if (string? x)
73 x
74 (match x
75 ((#:field tag a b)
76 `(,(C 'formatter) ,(exp vs tag) ,a ,b))))
77 (lp l)))
78 (() '())))))
79 (match l
80 ((x) x)
81 ((x . l) (cons* '+ x l))))))
82
83 (let ((r
84 (let lp ((l l))
85 (match l
86 ((x . l)
87 (let ((x (mk-string2 x))
88 (l (lp l)))
89 (if (and (string? x) (= (length l) 1) (string? (car l)))
90 (list (+ x (car l)))
91 (cons x l))))
92 (() (list ""))))))
93 (if (string? r)
94 r
95 (cons '+ r))))
96
97
98
99 (define-syntax-rule (with-exit code ...)
100 (with-fluids ((exit-fluid #t))
101 (call-with-prompt exit-prompt
102 (lambda () code ...)
103 (lambda (k val)
104 (if (not (equal? val 0))
105 (format #t "exit with error ~a~%" val))))))
106
107 (define (get-exported-symbols x)
108 (aif it (resolve-module x)
109 (aif it (module-public-interface it)
110 (let ((l '()))
111 (module-for-each
112 (lambda (k b)
113 (set! l (cons k l)))
114 it)
115 l)
116 '())
117 '()))
118
119 (define cvalues (G 'values))
120
121 (define-syntax-rule (wth code)
122 (let ((old s/d))
123 (set! s/d (C 'qset!))
124 (let ((r code))
125 (set! s/d old)
126 r)))
127
128
129 (define-syntax use-modules--
130 (lambda (x)
131 (define (keyword-like? stx)
132 (let ((dat (syntax->datum stx)))
133 (and (symbol? dat)
134 (eqv? (string-ref (symbol->string dat) 0) #\:))))
135 (define (->keyword sym)
136 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
137
138 (define (quotify-iface args)
139 (let loop ((in args) (out '()))
140 (syntax-case in ()
141 (() (reverse! out))
142 ;; The user wanted #:foo, but wrote :foo. Fix it.
143 ((sym . in) (keyword-like? #'sym)
144 (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
145 ((kw . in) (not (keyword? (syntax->datum #'kw)))
146 (syntax-violation 'define-module "expected keyword arg" x #'kw))
147 ((#:renamer renamer . in)
148 (loop #'in (cons* #'renamer #:renamer out)))
149 ((kw val . in)
150 (loop #'in (cons* #''val #'kw out))))))
151
152 (define (quotify specs)
153 (let lp ((in specs) (out '()))
154 (syntax-case in ()
155 (() (reverse out))
156 (((name name* ...) . in)
157 (and-map symbol? (syntax->datum #'(name name* ...)))
158 (lp #'in (cons #''((name name* ...)) out)))
159 ((((name name* ...) arg ...) . in)
160 (and-map symbol? (syntax->datum #'(name name* ...)))
161 (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
162 (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
163 out)))))))
164
165 (syntax-case x ()
166 ((_ spec ...)
167 (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
168 #'(eval-when (expand)
169 (process-use-modules (list quoted-args ...))
170 *unspecified*))))))
171
172 (define-syntax use-modules-
173 (lambda (x)
174 (define (keyword-like? stx)
175 (let ((dat (syntax->datum stx)))
176 (and (symbol? dat)
177 (eqv? (string-ref (symbol->string dat) 0) #\:))))
178 (define (->keyword sym)
179 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
180
181 (define (quotify-iface args)
182 (let loop ((in args) (out '()))
183 (syntax-case in ()
184 (() (reverse! out))
185 ;; The user wanted #:foo, but wrote :foo. Fix it.
186 ((sym . in) (keyword-like? #'sym)
187 (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
188 ((kw . in) (not (keyword? (syntax->datum #'kw)))
189 (syntax-violation 'define-module "expected keyword arg" x #'kw))
190 ((#:renamer renamer . in)
191 (loop #'in (cons* #'renamer #:renamer out)))
192 ((kw val . in)
193 (loop #'in (cons* #''val #'kw out))))))
194
195 (define (quotify specs)
196 (let lp ((in specs) (out '()))
197 (syntax-case in ()
198 (() (reverse out))
199 (((name name* ...) . in)
200 (and-map symbol? (syntax->datum #'(name name* ...)))
201 (lp #'in (cons #''((name name* ...)) out)))
202 ((((name name* ...) arg ...) . in)
203 (and-map symbol? (syntax->datum #'(name name* ...)))
204 (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
205 (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
206 out)))))))
207
208 (syntax-case x ()
209 ((_ spec ...)
210 (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
211 #'(eval-when (eval load)
212 (process-use-modules (list quoted-args ...))
213 *unspecified*))))))
214
215 (define-syntax-rule (use p l a ...)
216 (begin
217 (eval-when (expand)
218 (catch #t
219 (lambda ()
220 (if (not p) (reload-module (resolve-module 'l)))
221 (use-modules-- a ...))
222 (lambda x
223 #f)))
224 (eval-when (eval load)
225 (catch #t
226 (lambda ()
227 (if (not p) (reload-module (resolve-module 'l)))
228 (use-modules- a ...))
229 (lambda x
230 (raise (ImportError ((@ (guile) format)
231 #f "failed to import ~a ~a" 'l x))))))))
232
233 (define level (make-fluid 0))
234
235 (define (flat x)
236 (let lp ((x (list x)))
237 (if (pair? x)
238 (let ((e (car x)))
239 (if (pair? e)
240 (let ((ee (car e)))
241 (if (equal? ee '(@ (guile) cons))
242 (append (lp (list (cadr e)))
243 (lp (list (caddr e)))
244 (lp (cdr x)))
245 (lp (cdr x))))
246 (if (symbol? e)
247 (cons e (lp (cdr x)))
248 '())))
249 '())))
250
251 (define s/d (C 'qset!))
252
253 (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))"))
254
255 (define (gw-persson x l)
256 (if (or (member x (fluid-ref (@@ (system base message) %dont-warn-list)))
257 (member x l))
258 x
259 #f))
260
261 (define-syntax clear-warning-data
262 (lambda (x)
263 (catch #t
264 (lambda ()
265 (fluid-set! (@@ (system base message) %dont-warn-list) '()))
266 (lambda x (pre)))
267 #f))
268
269 (define-syntax-rule (with-warn code ...)
270 (with-fluids (((@@ (system base message) %dont-warn-list) '()))
271 code ...))
272
273 (define-syntax-rule (with-warn-data x code ...)
274 (with-fluids (((@@ (system base message) %dont-warn-list) x))
275 code ...))
276
277 (define (get-warns)
278 (list (G 'quote) (fluid-ref (@@ (system base message) %dont-warn-list))))
279
280 (define (dont-warn v)
281 (catch #t
282 (lambda ()
283 (fluid-set! (@@ (system base message) %dont-warn-list)
284 (cons v
285 (fluid-ref (@@ (system base message) %dont-warn-list)))))
286 (lambda x (values))))
287
288 (define-syntax call
289 (syntax-rules ()
290 ((_ (f) . l) (f . l))))
291
292 (define (fold f init l)
293 (if (pair? l)
294 (fold f (f (car l) init) (cdr l))
295 init))
296
297 (define do-pr #f)
298
299 (define (pr . x)
300 (if do-pr
301 (let ()
302 (define port (open-file "log.txt" "a"))
303 (with-output-to-port port
304 (lambda ()
305 (pretty-print (syntax->datum x))))
306 (close port)))
307 (car (reverse x)))
308
309 (define (pf x)
310 (define port (open-file "compile.log" "a"))
311 (with-output-to-port port
312 (lambda () (pretty-print (syntax->datum x)) x))
313 (close port)
314 x)
315
316 (define (pp x)
317 (pretty-print (syntax->datum x))
318 x)
319
320 (define (gv x)
321 (if (equal? x '_)
322 (gensym "_")
323 x))
324
325 (define (is-special? vs x)
326 (if (or-map (lambda (x) (match x ((#:starexpr . _) #t) (_ #f))) x)
327 (let lp ((l (map (g vs exp) x)))
328 (if (pair? l)
329 `((@ (guile) cons) ,(car l) ,(lp (cdr l)))
330 `((@ (guile) quote) ())))
331 #f))
332
333 (define (gen-sel vs e item)
334 (match e
335 (#f item)
336 ((#:cfor for-e in-e cont)
337 (let lp ((for-e for-e))
338 (match for-e
339 (((#:sub l))
340 `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) l)
341 : ,(exp vs in-e))) ()
342 ,(gen-sel vs cont item)))
343 (_
344 `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) for-e)
345 : ,(exp vs in-e))) ()
346 ,(gen-sel vs cont item))))))
347 ((#:cif cif cont)
348 `(,(G 'if) ,(exp vs cif)
349 ,(gen-sel vs cont item)))))
350
351 (define (union as vs)
352 (let lp ((as as) (vs vs))
353 (match as
354 ((x . as)
355 (if (member x vs)
356 (lp as vs)
357 (lp as (cons x vs))))
358 (()
359 vs))))
360
361 (define (diff as vs)
362 (let lp ((as as) (rs '()))
363 (match as
364 ((x . as)
365 (if (member x vs)
366 (lp as rs)
367 (lp as (cons x rs))))
368 (()
369 rs))))
370
371 (define (get-globals code)
372 (let lp ((vs (glob code '())) (rs (scope code '())))
373 (match vs
374 ((x . l)
375 (if (member x rs)
376 (lp l rs)
377 (lp l (cons x rs))))
378 (()
379 rs))))
380
381 (define (glob x vs)
382 (match x
383 ((#:global . l)
384 (let lp ((l l) (vs vs))
385 (match l
386 (((#:identifier v . _) . l)
387 (let ((s (string->symbol v)))
388 (if (member s vs)
389 (lp l vs)
390 (lp l (cons s vs)))))
391 (()
392 vs))))
393 ((x . y)
394 (glob y (glob x vs)))
395 (x vs)))
396
397 (define (scope x vs)
398 (match x
399 ((#:def f . _)
400 (union (list (exp '() f)) vs))
401
402 ((#:lambdef . _)
403 vs)
404
405 ((#:comma a)
406 (scope a vs))
407
408 ((#:comma a . l)
409 (union
410 (scope a vs)
411 (scope (cons #:comma l) vs)))
412
413
414 ((#:with (l ...) code)
415 (scope code (union vs
416 (let lp ((l l))
417 (match l
418 (((a b) . l)
419 (cons (exp '() b) (lp l)))
420 ((x . l) (lp l))
421 (() '()))))))
422
423 ((#:classdef f . _)
424 (union (list (exp '() f)) vs))
425
426 ((#:global . _)
427 vs)
428
429 ((#:import (#:name ((_ ids ...) . as) ...) ...)
430 (let lp ((ids ids) (as as) (vs vs))
431 (if (pair? ids)
432 (let lp2 ((ids2 (car ids)) (as2 (car as)) (vs vs))
433 (if (pair? as2)
434 (lp2 (cdr ids2) (cdr as2)
435 (let ((as2 (car as2))
436 (ids2 (car ids2)))
437 (union vs (list (exp '() (if as2 as2 (car ids2)))))))
438 (lp (cdr ids) (cdr as) vs)))
439 vs)))
440
441 ((#:expr-stmt l (#:assign u ... v))
442 (union
443 (fold (lambda (l s)
444 (union
445 s
446 (fold (lambda (x s)
447 (match x
448 ((#:test (#:power v2 v1 () . _) . _)
449 (if v2
450 (union
451 (union (flat (exp '() v1))
452 (flat (exp '() v2)))
453 s)
454 (union (flat (exp '() v1)) s)))
455
456 ((#:starexpr #:power _ v1 . _)
457 (union
458 (flat (exp '() v1))
459 s))
460
461 (_ s)))
462 '()
463 l)))
464 '()
465 (cons l u))
466 vs))
467
468 ((#:for es in code . final)
469 (let ((vs (union
470 vs
471 (let lp ((es es))
472 (match es
473 (((#:sub . l) . u)
474 (union (lp l) (lp u)))
475 (((#:power #f (#:tuple . l) . _) . u)
476 (union (lp l) (lp u)))
477 (((and (#:power . _) x) . u)
478 (union (list (exp vs x)) (lp u)))
479 ((e . es)
480 (union (lp e) (lp es)))
481 (() '()))))))
482 (scope final (scope code vs))))
483
484
485 ((#:expr-stmt l (#:assign k . u))
486 (union
487 (union (fold (lambda (x s)
488 (match x
489 ((#:test (#:power v2 v1 () . _) . _)
490 (if v2
491 (union
492 (union (flat (exp '() v1))
493 (flat (exp '() v2)))
494 s)
495 (union (flat (exp '() v1)) s)))
496 (_ s)))
497 '()
498 l)
499 vs)
500 (scope `(#:expr-stmt ,k (#:asignvs . ,u)) vs)))
501
502 ((x . y)
503 (scope y (scope x vs)))
504 (_ vs)))
505
506 (define ignore (make-fluid '()))
507
508 (define (defs x vs)
509 (match x
510 ((#:def (#:identifier f) . _)
511 (union (list (string->symbol f)) vs))
512 ((#:lambdef . _)
513 vs)
514 ((#:class . _)
515 vs)
516 ((#:global . _)
517 vs)
518 ((#:import (#:name ((_ ids ...) . as)) ...)
519 (let lp ((ids ids) (as as) (vs vs))
520 (if (pair? as)
521 (lp (cdr ids) (cdr as)
522 (let ((as (car as))
523 (ids (car ids)))
524 (union vs (list (exp '() (if as as (car ids)))))))
525 vs)))
526
527 ((x . y)
528 (defs y (defs x vs)))
529 (_ vs)))
530
531 (define (gen-yield f)
532 (string->symbol
533 (string-append
534 (symbol->string f)
535 ".yield")))
536
537 (define (g vs e)
538 (lambda (x) (e vs x)))
539
540 (define return (make-fluid 'error-return))
541
542 (define-syntax-rule (<< x y) (ash x y))
543 (define-syntax-rule (>> x y) (ash x (- y)))
544
545 (define-syntax-rule (mkfast ((a) v) ...)
546 (let ((h (make-hash-table)))
547 (hash-set! h 'a v)
548 ...
549 h))
550
551 (define (fast-ref x)
552 (aif it (assoc x `((__class__ . ,(O 'py-class))))
553 (cdr it)
554 #f))
555
556 (define fasthash
557 (mkfast
558 ;; General
559 ((__init__) (O 'py-init))
560 ((__ne__) (O 'ne))
561 ((__eq__) (O 'equal?))
562 ((__repr__) (O 'repr))
563
564 ;;iterators
565 ((__iter__) (F 'wrap-in))
566 ((__next__) (F 'next))
567 ((__send__) (Y 'send))
568 ((__exception__) (Y 'sendException))
569 ((__close__) (Y 'sendClose))
570
571 ;; Numerics
572 ((__index__) (N 'py-index))
573 ((__add__ ) (N '+))
574 ((__mul__ ) (N '*))
575 ((__sub__ ) (N '-))
576 ((__radd__ ) (N 'r+))
577 ((__rmul__ ) (N 'r*))
578 ((__rsub__ ) (N 'r-))
579 ((__neg__ ) (N '-))
580 ((__le__ ) (N '<))
581 ((__lt__ ) (N '<=))
582 ((__ge__ ) (N '>))
583 ((__gt__ ) (N '>=))
584 ((__abs__ ) (N 'py-abs))
585 ((__pow__ ) (N 'expt))
586 ((__rpow__ ) (N 'rexpt))
587 ((__truediv__) (N 'py-/))
588 ((__rtruediv__) (N 'py-r/))
589 ((__and__) (N 'py-logand))
590 ((__or__) (N 'py-logior))
591 ((__xor__) (N 'py-logxor))
592 ((__rand__) (N 'py-rlogand))
593 ((__ror__) (N 'py-rlogior))
594 ((__rxor__) (N 'py-rlogxor))
595 ((__divmod__) (N 'py-divmod))
596 ((__rdivmod__) (N 'py-rdivmod))
597 ((__invert__) (N 'py-lognot))
598 ((__int__) (N 'mk-int))
599 ((__float__) (N 'mk-float))
600 ((__lshift__) (N 'py-lshift))
601 ((__rshift__) (N 'py-rshift))
602 ((__rlshift__) (N 'py-rlshift))
603 ((__rrshift__) (N 'py-rrshift))
604 ((bit_length) (N 'py-bit-length))
605 ((as_integer_ratio) (N 'py-as-integer-ratio))
606 ((conjugate) (N 'py-conjugate))
607 ((denominator) (N 'py-denominator))
608 ((numerator) (N 'py-numerator))
609 ((to_bytes) (N 'py-to-bytes))
610 ((fromhex) (N 'py-fromhex))
611 ((hex) (N 'py-hex))
612 ((imag) (N 'py-imag))
613 ((is_integer) (N 'py-is-integer))
614 ((real) (N 'py-real))
615 ((__mod__) (N 'py-mod))
616 ((__rmod__) (N 'py-rmod))
617 ((__floordiv__) (N 'py-floordiv))
618 ((__rfloordiv__)(N 'py-rfloordiv))
619 ((__hex__) (N 'hex))
620
621 ;; Lists
622 ((append) (L 'pylist-append!))
623 ((count) (L 'pylist-count))
624 ((extend) (L 'pylist-extend!))
625 ((index) (L 'pylist-index))
626 ((pop) (L 'pylist-pop!))
627 ((insert) (L 'pylist-insert!))
628 ((remove) (L 'pylist-remove!))
629 ((reverse) (L 'pylist-reverse!))
630 ((sort) (L 'pylist-sort!))
631 ((__len__) (L 'len))
632 ((__contains__) (L 'in))
633 ((__delitem__) (L 'pylist-delete!))
634 ((__delslice__) (L 'pylist-delslice))
635 ((__setitem__) (L 'pylist-set!))
636
637 ;; String
638 ((format) (S 'py-strformat))
639 ((format_map) (S 'py-format-map))
640 ((capitalize) (S 'py-capitalize))
641 ((center) (S 'py-center ))
642 ((endswith) (S 'py-endswith))
643 ((expandtabs) (S 'py-expandtabs))
644 ((find) (S 'py-find ))
645 ((rfind) (S 'py-rfind ))
646 ((isalnum) (S 'py-isalnum))
647 ((isalpha) (S 'py-isalpha))
648 ((isdigit) (S 'py-isdigit))
649 ((islower) (S 'py-islower))
650 ((isspace) (S 'py-isspace))
651 ((isupper) (S 'py-isupper))
652 ((istitle) (S 'py-istitle))
653 ((isidentifier) (S 'py-identifier))
654 ((join) (S 'py-join ))
655 ((ljust) (S 'py-join ))
656 ((rljust) (S 'py-rljust ))
657 ((lower) (S 'py-lower ))
658 ((upper) (S 'py-upper ))
659 ((lstrip) (S 'py-lstrip ))
660 ((rstrip) (S 'py-rstrip ))
661 ((partition) (S 'py-partition))
662 ((replace) (S 'py-replace))
663 ((strip) (S 'py-strip ))
664 ((title) (S 'py-title ))
665 ((rpartition) (S 'py-rpartition))
666 ((rindex) (S 'py-rindex ))
667 ((split) (S 'py-split ))
668 ((rsplit) (S 'py-rsplit ))
669 ((splitlines) (S 'py-splitlines))
670 ((startswith) (S 'py-startswith))
671 ((swapcase) (S 'py-swapcase))
672 ((translate) (S 'py-translate))
673 ((zfill) (S 'py-zfill))
674 ((encode) (S 'py-encode))
675
676 ;;Nytevectors
677 ((decode) (B 'py-decode))
678
679 ;;DICTS
680 ((copy) (Di 'py-copy))
681 ((fromkeys) (Di 'py-fromkeys))
682 ((get) (Di 'py-get))
683 ((has_key) (Di 'py-has_key))
684 ((items) (Di 'py-items))
685 ((iteritems) (Di 'py-iteritems))
686 ((iterkeys) (Di 'py-iterkeys))
687 ((itervalues) (Di 'py-itervalues))
688 ((keys) (Di 'py-keys))
689 ((values) (Di 'py-values))
690 ((popitem) (Di 'py-popitem))
691 ((setdefault) (Di 'py-setdefault))
692 ((update) (Di 'py-update))
693 ((clear) (Di 'py-clear))
694 ((__hash__) (H 'py-hash))))
695
696
697 (define (fastfkn x) (hash-ref fasthash x))
698
699 (define (get-kwarg vs arg)
700 (let lp ((arg arg))
701 (match arg
702 (((#:* a) . arg)
703 (cons `(* ,(exp vs a)) (lp arg)))
704 (((#:** a) . arg)
705 (cons `(** ,(exp vs a)) (lp arg)))
706 (((#:= a b) . arg)
707 (cons `(= ,(exp vs a) ,(exp vs b)) (lp arg)))
708 ((x . arg)
709 (cons (exp vs x) (lp arg)))
710 (()
711 '()))))
712
713 (define (getarg x)
714 (match x
715 ((#:tp x . l)
716 x)
717 (x x)))
718
719 (define (get-args_ vs arg)
720 (let lp ((arg arg))
721 (match arg
722 (((#:arg x) . arg)
723 (cons (exp vs (getarg x))
724 (lp arg)))
725 ((x . args)
726 (lp args))
727
728 (()
729 '()))))
730
731 (define (get-args= vs arg)
732 (let lp ((arg arg))
733 (match arg
734 (((#:= x v) . arg)
735 (cons (list '= (exp vs (getarg x)) (exp vs v))
736 (lp arg)))
737
738 ((x . args)
739 (lp args))
740
741 (()
742 '()))))
743
744 (define (get-args* vs arg)
745 (let lp ((arg arg))
746 (match arg
747 (((#:* x) . arg)
748 (cons (list '* (exp vs (getarg x)))
749 (lp arg)))
750
751 ((x . args)
752 (lp args))
753
754 (()
755 '()))))
756
757 (define (get-args** vs arg)
758 (let lp ((arg arg))
759 (match arg
760 (((#:** x) . arg)
761 (cons (list '** (exp vs (getarg x)))
762 (lp arg)))
763
764 ((x . args)
765 (lp args))
766
767 (()
768 '()))))
769
770 (define (kw->li dict)
771 (for ((k v : dict)) ((l '()))
772 (cons* v (symbol->keyword (string->symbol k)) l)
773 #:final
774 (reverse l)))
775
776 (define (arglist->pkw l)
777 (let lp ((l l) (r '()))
778 (if (pair? l)
779 (let ((x (car l)))
780 (if (keyword? x)
781 (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'list) ,@l))
782 (lp (cdr l) (cons x r))))
783 (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'quote) ())))))
784
785 (define (get-addings vs x fast?)
786 (match x
787 (() '())
788 ((x . l)
789 (let ((is-fkn? (match l
790 ((#f) #t)
791 (((#:arglist . _) . _)
792 #t)
793 (_
794 #f))))
795
796 (cons
797 (match x
798 ((#:identifier . _)
799 (let* ((tag (exp vs x))
800 (xs (gensym "xs"))
801 (fast (fastfkn tag))
802 (is-fkn? (aif it (and fast? is-fkn? fast)
803 `(#:call-obj (lambda (e)
804 (lambda ,xs
805 (,(G 'apply) ,it e ,xs))))
806 #f)))
807 (if is-fkn?
808 is-fkn?
809 (if (and fast? fast)
810 `(#:fastfkn-ref ,fast (,(G 'quote) ,tag))
811 (aif it (and fast? (fast-ref tag))
812 `(#:fast-id ,it (,(G 'quote) ,tag))
813 `(#:identifier (,(G 'quote) ,tag)))))))
814
815 ((#:arglist args)
816 `(#:apply ,@(get-kwarg vs args)))
817
818 ((#:subscripts (n #f #f))
819 `(#:vecref ,(exp vs n)))
820
821 ((#:subscripts (n1 n2 n3))
822 (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
823 `(#:vecsub
824 ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3)))))
825
826 ((#:subscripts (n #f #f) ...)
827 `(#:array-ref ,@ (map (lambda (n)
828 (exp vs n))
829 n)))
830
831 ((#:subscripts (n1 n2 n3) ...)
832 (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
833 `(#:arraysub
834 ,@(map (lambda (x y z)
835 `(,(exp vs x) ,(exp vs y) ,(exp vs z)))
836 n1 n2 n3))))
837
838 (_ (error "unhandled addings")))
839 (get-addings vs l fast?))))))
840
841 (define-syntax-rule (setwrap u)
842 (call-with-values (lambda () u)
843 (lambda (x . x*)
844 (if (null? x*)
845 x
846 (cons x x*)))))
847
848 #;
849 (define-syntax-rule (setwrap u)
850 (call-with-values (lambda () u)
851 (case-lambda
852 ((x) x)
853 (x x))))
854
855 (define (make-set vs op x u)
856 (define (tr-op op)
857 (match op
858 ("+=" '+)
859 ("-=" '-)
860 ("*=" '*)
861 ("/=" '/)
862 ("%=" (G 'modulo))
863 ("&=" (G 'logand))
864 ("|=" (G 'logior))
865 ("^=" (G 'logxor))
866 ("**=" (N 'expt))
867 ("<<=" (C '<<))
868 (">>=" (C '>>))
869 ("//=" (G 'floor-quotient))))
870
871 (match x
872 ((#:verb x) x)
873 ((#:test (#:power kind v addings . _) . _)
874 (let* ((v (exp vs v))
875 (fast? (not (eq? v 'super)))
876 (addings (get-addings vs addings fast?))
877 (p.a (match kind
878 (#f (cons #f '()))
879 ((v add)
880 (cons (exp vs v) add))))
881 (p (car p.a))
882 (pa (cdr p.a))
883 (pa (get-addings vs pa fast?)))
884 (define q (lambda (x) `',x))
885 (if kind
886 (if (not p)
887 (if (null? addings)
888 (if op
889 `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
890 `(,s/d ,v (,(C 'setwrap) ,u)))
891 (if op
892 `(,s/d ,(exp vs kind)
893 (,(C 'fset-x) ,v ,addings
894 (,(C 'setwrap)
895 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
896
897 `(,s/d ,(exp vs kind)
898 (,(C 'fset-x) ,v ,addings
899 (,(C 'setwrap) ,u)))))
900
901 (let ((pre (if (equal? p v)
902 (let lp ((pa pa) (ad addings) (r '()))
903 (if (and (pair? pa) (pair? ad))
904 (let ((px (car pa)) (ax (car ad)))
905 (if (equal? px ax)
906 (lp (cdr pa) (cdr ad) (cons px r))
907 #f))
908 (if (pair? pa)
909 #f
910 (reverse r))))
911 #f)))
912 (if (null? addings)
913 (if op
914 `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
915 `(,s/d ,v (,(C 'setwrap) ,u)))
916 (if op
917 `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
918 (,(C 'setwrap)
919 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
920
921 `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
922 (,(C 'setwrap) ,u))))))
923
924 (if (null? addings)
925 (if op
926 `(,s/d ,v (,(C 'setwrap)
927 (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
928 `(,s/d ,v (,(C 'setwrap)
929 ,u)))
930 `(,(C 'set-x)
931 ,v
932 ,addings
933 (,(C 'setwrap)
934 ,(if op
935 `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
936 u)))))))))
937
938 (define is-class? (make-fluid #f))
939 (define (gen-yargs vs x)
940 (match x ((#:list args)
941 (map (g vs exp) args))))
942
943 (define inhibit-finally #f)
944 (define decorations (make-fluid '()))
945 (define tagis (make-hash-table))
946
947 (define (lr as)
948 (lambda (vs x)
949 (define (eval p a b) ((cdr (assoc p as)) a b))
950 (define (expit x)
951 (match x
952 ((#:e e) e)
953 (x (exp vs x))))
954 (let lp ((x x))
955 (match x
956 ((p a b)
957 (if (assoc p as)
958 (match b
959 ((q c d)
960 (if (assoc q as)
961 (lp (list q (list #:e (lp (list p a c))) d))
962 (eval p (expit a) (expit b))))
963 (_ (eval p (expit a) (expit b))))
964 (expit x)))
965 (_ (expit x))))))
966
967 (define (mklr x)
968 (lambda (a b)
969 (list x a b)))
970
971 (define (f% s a)
972 (if (string? s)
973 (list (F2 'format) s a)
974 (list (N 'py-mod) s a)))
975
976 (define lr+ (lr `((#:+ . ,(mklr (G '+))) (#:- . ,(mklr (G '-))))))
977 (define lr* (lr `((#:* . ,(mklr (G '*))) (#:/ . ,(mklr (N 'py-/)))
978 (#:% . ,f%) (#:// . ,(mklr (N 'py-floordiv))))))
979
980 (define lr-or (lr `((#:bor . ,(mklr (N 'py-logior))))))
981 (define lr-and (lr `((#:band . ,(mklr (N 'py-logand))))))
982 (define lr-xor (lr `((#:bxor . ,(mklr (N 'py-logxor))))))
983
984 (define-syntax-rule (gen-table x vs (tag code ...) ...)
985 (begin
986 (hash-set! tagis tag
987 (lambda (x vs)
988 (match x code ...)))
989
990 ...))
991
992 (define *doc* (make-fluid #f))
993 (define (get-doc)
994 (aif it (fluid-ref *doc*)
995 it
996 ""))
997 (define set-doc
998 (case-lambda
999 (() (fluid-set! *doc* #f))
1000 ((x)
1001 (if (not (fluid-ref *doc*))
1002 (fluid-set! *doc* x)))))
1003
1004 (define (u-it m)
1005 (if (and (eq? (list-ref m 0) 'language)
1006 (eq? (list-ref m 1) 'python)
1007 (eq? (list-ref m 0) 'module))
1008 (cddr m)
1009 '()))
1010
1011 (define (tr-comp op x y)
1012 (match op
1013 ((or "<" ">" "<=" ">=")
1014 (list (G (string->symbol op)) x y))
1015 ("!=" (list (G 'not) (list (O 'equal?) x y)))
1016 ("==" (list (O 'equal?) x y))
1017 ("is" (list (G 'eq?) x y))
1018 ("isnot" (list (G 'not) (list (G 'eq?) x y)))
1019 ("in" (list (L 'in) x y))
1020 ("notin" (list (G 'not) (list (L 'in) x y)))
1021 ("<>" (list (G 'not) (list (O 'equal?) x y)))))
1022
1023 (gen-table x vs
1024 (#:power
1025 ((_ _ (x) () . #f)
1026 (exp vs x))
1027
1028 ((_ _ x () . #f)
1029 (exp vs x))
1030
1031 ((_ #f vf trailer . **)
1032 (let* ((vf (exp vs vf))
1033 (fast? (not (eq? vf 'super))))
1034 (define (pw x)
1035 (if **
1036 `(,(N 'expt) ,x ,(exp vs **))
1037 x))
1038 (pw
1039 (let ((trailer (get-addings vs trailer fast?)))
1040 `(,(C 'ref-x) ,vf ,@trailer))))))
1041
1042 (#:identifier
1043 ((#:identifier x . _)
1044 (string->symbol x)))
1045
1046 (#:decorated
1047 ((_ (l ...))
1048 (fluid-set! decorations (map (g vs exp) l))
1049 `(,cvalues)))
1050
1051 (#:string
1052 ((_ l)
1053 (mk-string vs l)))
1054
1055 (#:bytes
1056 ((_ l)
1057 (let* ((b (make-bytevector (length l))))
1058 (let lp ((l l) (i 0))
1059 (if (pair? l)
1060 (begin
1061 (bytevector-u8-set! b i (car l))
1062 (lp (cdr l) (+ i 1)))
1063 `(,(B 'bytes) ,b))))))
1064
1065
1066 (#:+
1067 (x
1068 (lr+ vs x)))
1069
1070 (#:-
1071 (x
1072 (lr+ vs x)))
1073
1074 (#:*
1075 (x
1076 (lr* vs x)))
1077
1078 (#:/
1079 (x
1080 (lr* vs x)))
1081
1082 (#:%
1083 (x
1084 (lr* vs x)))
1085
1086 (#://
1087 (x
1088 (lr* vs x)))
1089
1090 (#:<<
1091 ((_ . l)
1092 (cons (N 'py-lshift) (map (g vs exp) l))))
1093
1094 (#:>>
1095 ((_ . l)
1096 (cons (N 'py-rshift) (map (g vs exp) l))))
1097
1098 (#:u~
1099 ((_ x)
1100 (list (N 'py-lognot) (exp vs x))))
1101
1102 (#:u-
1103 ((_ x)
1104 (list '- (exp vs x))))
1105
1106 (#:u+
1107 ((_ x)
1108 (list '+ (exp vs x))))
1109
1110 (#:band
1111 (x (lr-and vs x)))
1112
1113 (#:bxor
1114 (x (lr-xor vs x)))
1115
1116 (#:bor
1117 (x (lr-or vs x)))
1118
1119 (#:not
1120 ((_ x)
1121 (list (G 'not) (list (C 'boolit) (exp vs x)))))
1122
1123 (#:or
1124 ((_ . x)
1125 (cons (G 'or) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
1126
1127 (#:and
1128 ((_ . x)
1129 (cons (G 'and) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
1130
1131 (#:test
1132 ((_ e1 #f)
1133 (exp vs e1))
1134
1135 ((_ e1 (e2 #f))
1136 (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None)))
1137
1138 ((_ e1 (e2 e3))
1139 (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3))))
1140
1141 (#:del
1142 ;;We don't delete variables
1143 ((_ . l)
1144 `(,(G 'begin)
1145 ,@(let lp ((l l))
1146 (match l
1147 (((#:power #f base () . #f) . l)
1148 (cons `(set! ,(exp vs base) #f)
1149 (lp l)))
1150
1151
1152 (((#:power #f base (l ... fin) . #f) . ll)
1153 (let* ((f (exp vs base))
1154 (fast? (not (eq? f 'super)))
1155 (add (get-addings vs l fast?))
1156 (fin (get-addings vs (list fin) fast?)))
1157 (cons
1158 `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin)
1159 (lp ll))))
1160 (() '()))))))
1161
1162 (#:with
1163 ((_ (l ...) code)
1164 (let* ((l (map (lambda (x)
1165 (match x
1166 ((a b) (list (exp vs b) (gensym "as") (exp vs a)))
1167 ((b) (list (exp vs b)))))
1168 l))
1169 (vs (union vs (let lp ((l l))
1170 (match l
1171 (((x) . l) (lp l))
1172 (((a b c) . l) (cons a (lp l)))
1173 (() '()))))))
1174
1175 (define (f x)
1176 (match x
1177 ((a b c) (list 'set! a b))
1178 ((a) (list (G 'values)))))
1179
1180 (define (g x)
1181 (match x
1182 ((a b c) (list b c))
1183 ((a) (list a))))
1184
1185 `(,(W 'with) ,(map g l)
1186 (,(G 'begin)
1187 ,@(map f l)
1188 ,(exp vs code))))))
1189
1190 (#:if
1191 ((_ test a ((tests . as) ...) . else)
1192 `(,(G 'cond)
1193 (,(list (C 'boolit) (exp vs test)) ,(exp vs a))
1194 ,@(map (lambda (p a) (list (list (C 'boolit) (exp vs p))
1195 (exp vs a))) tests as)
1196 ,@(if else `((else ,(exp vs else))) '()))))
1197
1198 (#:suite
1199 ((_ #:stmt . l) (cons (G 'begin) (map (g vs exp) l)))
1200 ((_ . l) (cons (G 'begin) (map (g vs exp) l))))
1201
1202 (#:classdef
1203 ((_ class parents code)
1204 (with-fluids ((is-class? #t))
1205 (let ()
1206 (define (clean l)
1207 (match l
1208 (((#:apply . l). u) (append (clean l) (clean u)))
1209 (((`= x v ) . l) (cons* (symbol->keyword x) v (clean l)))
1210 ((x . l) (cons x (clean l)))
1211 (() '())))
1212 (let* ((decor (let ((r (fluid-ref decorations)))
1213 (fluid-set! decorations '())
1214 r))
1215 (class (exp vs class))
1216 (vo vs)
1217 (vs (union (list class) vs))
1218 (ns (scope code '()))
1219 (ls ns #;(diff ns vs))
1220
1221 (parents (match parents
1222 (() #f)
1223 (#f #f)
1224 ((#:arglist . _)
1225 (get-addings vs (list parents) #f))))
1226 (cd.doc (with-fluids ((*doc* #f))
1227 (let ((cd (wth (exp vs code))))
1228 (cons cd (get-doc)))))
1229 (cd (car cd.doc))
1230 (doc (cdr cd.doc)))
1231 `(set! ,class
1232 (,(C 'class-decor) ,decor
1233 (,(C 'with-class) ,class
1234 (,(C 'mk-p-class2)
1235 ,class
1236 ,(if parents
1237 (arglist->pkw (clean parents))
1238 `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
1239 ,doc
1240 ,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
1241 ,cd)))))))))
1242 (#:verb
1243 ((_ x) x))
1244
1245 (#:scm
1246 ((_ (#:string _ s)) (with-input-from-string s read)))
1247
1248 (#:comma
1249 ((_
1250 (and x
1251 (#:expr-stmt
1252 ((#:test
1253 (#:power #f (#:string l) () . #f)
1254 #f))
1255 (#:assign))))
1256 (set-doc (mk-string vs l))
1257 (exp vs x))
1258
1259 ((_ a)
1260 (exp vs a))
1261
1262 ((_ (and a
1263 (#:expr-stmt
1264 ((#:test
1265 (#:power #f (#:string ll) () . #f)
1266 #f))
1267 (#:assign))) . l)
1268 (set-doc (mk-string vs ll))
1269 `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l))))
1270
1271 ((_ a . l)
1272 `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l)))))
1273
1274 (#:import
1275 ((_ (#:from (() () . nm) . #f))
1276 (let* ((xl (map (lambda (nm) (exp vs nm)) nm))
1277 (l `(language python module ,@xl)))
1278
1279 ;; Make sure to load the module in
1280 (let ((? (catch #t
1281 (lambda () (Module (reverse l) (reverse xl)) #t)
1282 (lambda x #f))))
1283 (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))
1284 `(,(C 'use) ,? ,l ,l))))
1285
1286 ((_ (#:from (("." . nn) . nm) . #f))
1287 (let* ((u (module-name (current-module)))
1288 (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
1289 (xl (append u (map (lambda (nm) (exp vs nm)) nm)))
1290 (l `(language python module ,@xl)))
1291
1292 ;; Make sure to load the module in
1293 (let ((? (catch #t
1294 (lambda () (Module (reverse l) (reverse xl)) #t)
1295 (lambda x #f))))
1296 (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))
1297 `(,(C 'use) ,? ,l ,l))))
1298
1299 ((_ (#:from ("." . nn) . #f))
1300 (let* ((nm '())
1301 (u (module-name (current-module)))
1302 (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
1303 (xl (append u (map (lambda (nm) (exp vs nm)) nm)))
1304 (l `(language python module ,@xl)))
1305
1306 ;; Make sure to load the module in
1307 (let ((? (catch #t
1308 (lambda () (Module (reverse l) (reverse xl)) #t)
1309 (lambda x #f))))
1310 (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))
1311 `(,(C 'use) ,? ,l ,l))))
1312
1313 ((_ (#:from (() () . nm) l))
1314 ;; Make sure to load the module in
1315 (let* ((xl (map (lambda (nm) (exp vs nm)) nm))
1316 (ll `(language python module ,@xl)))
1317
1318 `(,(C 'use) #t ()
1319 (,ll
1320 #:select
1321 ,(map (lambda (x)
1322 (match x
1323 ((a . #f)
1324 (let ((s (exp vs a)))
1325 (fluid-set! ignore
1326 (cons s (fluid-ref ignore)))
1327 (dont-warn s)
1328 s))
1329
1330 ((a . b)
1331 (let ((s1 (exp vs a))
1332 (s2 (exp vs b)))
1333 (fluid-set! ignore
1334 (cons s2
1335 (fluid-ref ignore)))
1336 (dont-warn s2)
1337 (cons s1 s2)))))
1338 l)))))
1339
1340 ((_ (#:from (("." . nn) . nm) l))
1341 ;; Make sure to load the module in
1342 (let* ((u (module-name (current-module)))
1343 (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
1344 (xl (append u (map (lambda (nm) (exp vs nm)) nm)))
1345 (ll `(language python module ,@xl)))
1346
1347 `(,(C 'use) #t ()
1348 (,ll
1349 #:select
1350 ,(map (lambda (x)
1351 (match x
1352 ((a . #f)
1353 (let ((s (exp vs a)))
1354 (fluid-set! ignore
1355 (cons s (fluid-ref ignore)))
1356 (dont-warn s)
1357 s))
1358
1359 ((a . b)
1360 (let ((s1 (exp vs a))
1361 (s2 (exp vs b)))
1362 (fluid-set! ignore
1363 (cons s2
1364 (fluid-ref ignore)))
1365 (dont-warn s2)
1366 (cons s1 s2)))))
1367 l)))))
1368
1369 ((_ (#:from ("." . nn) l))
1370 ;; Make sure to load the module in
1371 (let* ((nm '())
1372 (u (module-name (current-module)))
1373 (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
1374 (xl (append u (map (lambda (nm) (exp vs nm)) nm)))
1375 (ll `(language python module ,@xl)))
1376
1377 `(,(C 'use) #t ()
1378 (,ll
1379 #:select
1380 ,(map (lambda (x)
1381 (match x
1382 ((a . #f)
1383 (let ((s (exp vs a)))
1384 (fluid-set! ignore
1385 (cons s (fluid-ref ignore)))
1386 (dont-warn s)
1387 s))
1388
1389 ((a . b)
1390 (let ((s1 (exp vs a))
1391 (s2 (exp vs b)))
1392 (fluid-set! ignore
1393 (cons s2
1394 (fluid-ref ignore)))
1395 (dont-warn s2)
1396 (cons s1 s2)))))
1397 l)))))
1398
1399
1400 ((_ (#:name ((dots ids ...) . as) ...) ...)
1401 `(,(G 'begin)
1402 ,@(map
1403 (lambda (dots ids as)
1404 `(,(G 'begin)
1405 ,@(map (lambda (dots ids as)
1406 (let* ((u (module-name (current-module)))
1407 (u (if (null? dots)
1408 '()
1409 (reverse (list-cdr-ref
1410 (reverse (u-it u))
1411 (- (length dots) 1)))))
1412
1413 (path (append (if (null? dots) '() u)
1414 (map (g vs exp) ids))))
1415 (if as
1416 (exp
1417 vs
1418 `(#:expr-stmt
1419 ((#:test (#:power #f ,as ())))
1420 (#:assign
1421 ((#:verb
1422 ((@ (language python module) import)
1423 ((@ (language python module) Module)
1424 (,(G 'quote)
1425 ,(reverse (append
1426 '(language python module)
1427 path)))
1428 (,(G 'quote) ,(reverse path)))
1429 ,(exp vs as)))))))
1430 (exp
1431 vs
1432 `(#:expr-stmt
1433 ((#:test (#:power #f ,(car ids) ())))
1434 (#:assign
1435 ((#:verb
1436 ((@ (language python module) import)
1437 ((@ (language python module) Module)
1438 (,(G 'quote)
1439 ,(append '(language python module)
1440 path)))
1441 ,(exp vs (car ids)))))))))))
1442 dots ids as)))
1443 dots ids as))))
1444
1445 (#:for
1446 ((_ e in code . #f)
1447 (=> next)
1448 (let lp ((e e))
1449 (match e
1450 (((#:power #f (#:tuple . l) . _))
1451 (lp l))
1452
1453 (((#:power #f (#:identifier x . _) () . #f))
1454 (match in
1455 (((#:test power . _))
1456 (match power
1457 ((#:power #f
1458 (#:identifier "range" . _)
1459 ((#:arglist arglist . _))
1460 . _)
1461 (let* ((code2 (exp vs code))
1462 (p (is-ec #t code2 #t (list (C 'continue)))))
1463
1464 (match arglist
1465 ((arg)
1466 (if p
1467 (let ((v (gensym "v"))
1468 (x (string->symbol x))
1469 (lp (gensym "lp")))
1470 `(,(C 'let/ecx) break-ret
1471 (,(G 'let) ((,v ,(exp vs arg)))
1472 (,(G 'let) ,lp ((,x 0))
1473 (,(G 'if) (< ,x ,v)
1474 (,(G 'begin)
1475 (,(C 'let/ecx) continue-ret
1476 (,(C 'with-sp) ((continue (continue-ret))
1477 (break (break-ret)))
1478 ,code2))
1479 (,lp (+ ,x 1))))))))
1480
1481 (let ((v (gensym "v"))
1482 (x (string->symbol x))
1483 (lp (gensym "lp")))
1484 `(,(C 'let/ecx) break-ret
1485 (,(G 'let) ((,v ,(exp vs arg)))
1486 (,(G 'let) ,lp ((,x 0))
1487 (,(G 'if) (< ,x ,v)
1488 (,(G 'begin)
1489 (,(C 'with-sp) ((break (break-ret)))
1490 ,code2)
1491 (,lp (+ ,x 1))))))))))
1492
1493 ((arg1 arg2)
1494 (let ((v1 (gensym "va"))
1495 (v2 (gensym "vb"))
1496 (x (string->symbol x))
1497 (lp (gensym "lp")))
1498 (if p
1499 `(,(C 'let/ecx) break-ret
1500 (,(G 'let) ((,v1 ,(exp vs arg1))
1501 (,v2 ,(exp vs arg2)))
1502 (,(G 'let) ,lp ((,x ,v1))
1503 (,(G 'if) (< ,x ,v2)
1504 (,(G 'begin)
1505 (,(C 'let/ecx) continue-ret
1506 (,(C 'with-sp) ((continue (continue-ret))
1507 (break (break-ret)))
1508 ,code2))
1509 (,lp (+ ,x 1)))))))
1510 `(,(C 'let/ecx) break-ret
1511 (,(G 'let) ((,v1 ,(exp vs arg1))
1512 (,v2 ,(exp vs arg2)))
1513 (,(G 'let) ,lp ((,x ,v1))
1514 (,(G 'if) (< ,x ,v2)
1515 (,(G 'begin)
1516 (,(C 'with-sp) ((break (break-ret)))
1517 ,code2)
1518 (,lp (+ ,x 1))))))))))
1519 ((arg1 arg2 arg3)
1520 (let ((v1 (gensym "va"))
1521 (v2 (gensym "vb"))
1522 (st (gensym "vs"))
1523 (x (string->symbol x))
1524 (lp (gensym "lp")))
1525 (if p
1526 `(,(C 'let/ecx) break-ret
1527 (,(G 'let) ((,v1 ,(exp vs arg1))
1528 (,st ,(exp vs arg3))
1529 (,v2 ,(exp vs arg2)))
1530 (,(G 'if) (> ,st 0)
1531 (,(G 'let) ,lp ((,x ,v1))
1532 (,(G 'if) (< ,x ,v2)
1533 (,(G 'begin)
1534 (,(C 'let/ecx) continue-ret
1535 (,(C 'with-sp)
1536 ((continue (continue-ret))
1537 (break (break-ret)))
1538 ,code2))
1539 (,lp (+ ,x ,st)))))
1540 (,(G 'if) (< ,st 0)
1541 (,(G 'let) ,lp ((,x ,v1))
1542 (,(G 'if) (> ,x ,v2)
1543 (,(G 'begin)
1544 (,(C 'let/ecx) continue-ret
1545 (,(C 'with-sp)
1546 ((continue (continue-ret))
1547 (break (break-ret)))
1548 ,code2))
1549 (,lp (+ ,x ,st)))))
1550 (,(G 'error)
1551 "range with step 0 not allowed")))))
1552 `(,(C 'let/ecx) break-ret
1553 (,(G 'let) ((,v1 ,(exp vs arg1))
1554 (,st ,(exp vs arg3))
1555 (,v2 ,(exp vs arg2)))
1556 (,(G 'if) (> ,st 0)
1557 (,(G 'let) ,lp ((,x ,v1))
1558 (,(G 'if) (< ,x ,v2)
1559 (,(G 'begin)
1560 (,(C 'with-sp)
1561 ((break (break-ret)))
1562 ,code2)
1563 (,lp (+ ,x ,st)))))
1564 (,(G 'if) (< ,st 0)
1565 (,(G 'let) ,lp ((,x ,v1))
1566 (,(G 'if) (> ,x ,v2)
1567 (,(G 'begin)
1568 (,(C 'with-sp)
1569 ((break (break-ret)))
1570 ,code2)
1571 (,lp (+ ,x ,st)))))
1572 (,(G 'error)
1573 "range with step 0 not allowed"))))))))
1574 (_ (next)))))
1575 (_ (next))))
1576 (_ (next))))
1577 (_ (next)))))
1578
1579 ((_ es in code . else)
1580 (let lp ((es es))
1581 (match es
1582 (((#:power #f (#:tuple . l) . _))
1583 (lp l))
1584 (_
1585 (let* ((es2 (map (g vs exp) es))
1586 (vs2 (union es2 vs))
1587 (code2 (exp vs2 code))
1588 (p (is-ec #t code2 #t (list (C 'continue))))
1589 (else2 (if else (exp vs2 else) #f))
1590 (in2 (match in
1591 ((in) (list (exp vs in)))
1592 ((in ...) (list `(,(G 'list)
1593 ,@ (map (g vs exp) in)))))))
1594 (list (C 'cfor) es2 in2 code2 else2 p)))))))
1595
1596 (#:sub
1597 ((_ l)
1598 (map (g vs exp) l)))
1599
1600 (#:while
1601 ((_ test code . #f)
1602 (let* ((lp (gensym "lp"))
1603 (code2 (exp vs code))
1604 (p (is-ec #t code2 #t (list (C 'continue)))))
1605 (if p
1606 `(,(C 'let/ecx) break-ret
1607 (,(G 'let) ,lp ()
1608 (,(G 'if) (,(C 'boolit) ,(exp vs test))
1609 (,(G 'begin)
1610 (,(C 'let/ecx) continue-ret
1611 (,(C 'with-sp) ((continue (continue-ret))
1612 (break (break-ret)))
1613 ,code2))
1614 (,lp)))))
1615
1616 `(,(C 'let/ecx) break-ret
1617 (,(G 'let) ,lp ()
1618 (,(G 'if) (,(C 'boolit) ,(exp vs test))
1619 (,(G 'begin)
1620 (,(C 'with-sp) ((break (break-ret)))
1621 ,code2)
1622 (,lp))))))))
1623
1624 ((_ test code . else)
1625 (let* ((lp (gensym "lp"))
1626 (code2 (exp vs code))
1627 (p (is-ec #t code2 #t (list (C 'continue)))))
1628 (if p
1629 `(,(C 'let/ecx) break-ret
1630 (,(G 'let) ,lp ()
1631 (,(G 'if) (,(C 'boolit) ,(exp vs test))
1632 (,(G 'begin)
1633 (,(C 'let/ecx) ,(C 'continue-ret)
1634 (,(C 'with-sp) ((continue (continue-ret))
1635 (break (break-ret)))
1636 ,code2))
1637 (,lp))
1638 ,(exp vs else))))
1639
1640 `(,(C 'let/ecx) break-ret
1641 (,(G 'let) ,lp ()
1642 (,(G 'if) (,(C 'boolit) ,(exp vs test))
1643 (,(G 'begin)
1644 (,(C 'with-sp) ((break (break-ret)))
1645 ,code2)
1646 (,lp))
1647 ,(exp vs else))))))))
1648
1649 (#:try
1650 ((_ x (or #f ()) #f . fin)
1651 (if fin
1652 `(,(T 'try) (,(G 'lambda) () ,(exp vs x))
1653 #:finally (,(G 'lambda) () ,(exp vs fin)))
1654 `(,(T 'try) (,(G 'lambda) () ,(exp vs x)))))
1655
1656 ((_ x exc else . fin)
1657 `(,(T 'try) (lambda () ,(exp vs x))
1658 ,@(let lp ((exc exc) (r '()))
1659 (match exc
1660 ((((test . #f) code) . exc)
1661 (lp exc (cons `(#:except ,(exp vs test) ,(exp vs code)) r)))
1662
1663 (((#f code) . exc)
1664 (lp exc (cons `(#:except #t ,(exp vs code)) r)))
1665
1666 ((((test . as) code) . exc)
1667 (let ((l (gensym "l")))
1668 (lp exc
1669 (cons
1670 `(#:except ,(exp vs test) => (,(G 'lambda)
1671 (,(exp vs as) . ,l)
1672 ,(exp vs code)))
1673 r))))
1674 (()
1675 (reverse r))))
1676
1677 ,@(if else `((#:except #t ,(exp vs else))) '())
1678 ,@(if fin `(#:finally (,(G 'lambda) () ,(exp vs fin))) '()))))
1679
1680 (#:subexpr
1681 ((_ . l)
1682 (exp vs l)))
1683
1684 (#:raise
1685 ((_ #f . #f)
1686 `(,(T 'raise) (,(O 'Exception))))
1687
1688 ((_ code . #f)
1689 `(,(T 'raise) ,(exp vs code)))
1690
1691 ((_ code . from)
1692 (let ((o (gensym "o"))
1693 (c (gensym "c")))
1694 `(,(T 'raise)
1695 (,(G 'let) ((,c ,(exp vs code)))
1696 (,(G 'let) ((,o (,(G 'if) (,(O 'pyclass?) ,c)
1697 (,c)
1698 ,c)))
1699 (,(O 'set) ,o (,(G 'quote) __cause__) ,(exp vs from))
1700 ,o))))))
1701
1702
1703 (#:yield
1704 ((_ (#:from x))
1705 (let ((y (gensym "y"))
1706 (f (gensym "f")))
1707 `(,(G 'begin)
1708 (fluid-set! ,(Y 'in-yield) #t)
1709 (,(F 'for) ((,y : ,(exp vs x))) ()
1710 (,(G 'let) ((,f (scm.yield ,y)))
1711 (,f))))))
1712
1713 ((_ args)
1714 (let ((f (gensym "f")))
1715 `(,(G 'begin)
1716 (,(G 'fluid-set!) ,(Y 'in-yield) #t)
1717 (,(G 'let) ((,f (scm.yield ,@(gen-yargs vs args))))
1718 (,f)))))
1719
1720
1721 ((_ f args)
1722 (let ((f (gen-yield (exp vs f)))
1723 (g (gensym "f")))
1724 `(,(G 'begin)
1725 (set! ,(C 'inhibit-finally) #t)
1726 (,(G 'let) ((,g (,f ,@(gen-yargs vs args))))
1727 (,g))))))
1728
1729 (#:def
1730 ((_ f
1731 (#:types-args-list . args)
1732 #f
1733 code)
1734 (let* ((decor (let ((r (fluid-ref decorations)))
1735 (fluid-set! decorations '())
1736 r))
1737 (arg_ (get-args_ vs args))
1738 (arg= (get-args= vs args))
1739 (dd= (map cadr arg=))
1740 (c? (fluid-ref is-class?))
1741 (f (exp vs f))
1742 (y? (is-yield f #f code))
1743 (r (gensym "return"))
1744 (*f (get-args* vs args))
1745 (dd* (map cadr *f))
1746 (**f (get-args** vs args))
1747 (dd** (map cadr **f))
1748 (aa `(,@arg_ ,@*f ,@arg= ,@**f))
1749 (ab (gensym "ab"))
1750 (vs (union dd** (union dd* (union dd= (union arg_ vs)))))
1751 (ns (scope code vs))
1752 (df '() #;(defs code '()))
1753 (ex (gensym "ex"))
1754 (y 'scm.yield)
1755 (y.f (gen-yield f))
1756 (ls (diff (diff ns vs) df))
1757 (cd.doc (with-fluids ((is-class? #f)
1758 (*doc* #f)
1759 (return r))
1760 (let ((cd (wth (exp ns code))))
1761 (cons cd (get-doc)))))
1762 (cd (car cd.doc))
1763 (doc (cdr cd.doc))
1764 (docv (gensym "fv"))
1765 (docer (lambda (x) `(,(G 'let) ((,docv ,x))
1766 (,(C 'set) ,docv (,(G 'quote) __doc__) ,doc)
1767 ,docv))))
1768 (define (mk code)
1769 `(let-syntax ((,y (syntax-rules ()
1770 ((_ . args)
1771 (abort-to-prompt ,ab . args))))
1772 (,y.f (syntax-rules ()
1773 ((_ . args)
1774 (abort-to-prompt ,ab . args)))))
1775 ,code))
1776
1777 (if c?
1778 (if y?
1779 `(set! ,f
1780 ,(docer
1781 `(,(C 'def-decor) ,decor
1782 (,(C 'def-wrap) ,y? ,f ,ab
1783 (,(D 'lam) ,aa
1784 (,(C 'with-return) ,r
1785 ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
1786 (,(C 'with-self) ,c? ,aa
1787 ,cd)))))))))
1788
1789 `(set! ,f
1790 ,(docer
1791 `(,(C 'def-decor) ,decor
1792 (,(D 'lam) ,aa
1793 (,(C 'with-return) ,r
1794 ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
1795 (,(C 'with-self) ,c? ,aa
1796 ,cd)))))))))
1797
1798 (if y?
1799 `(set! ,f
1800 ,(docer
1801 `(,(C 'def-decor) ,decor
1802 (,(C 'def-wrap) ,y? ,f ,ab
1803 (,(D 'lam) ,aa
1804 (,(C 'with-return) ,r
1805 (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
1806 (,(C 'with-self) ,c? ,aa
1807 ,(mk cd)))))))))
1808 `(set! ,f
1809 ,(docer
1810 `(,(C 'def-decor) ,decor
1811 (,(D 'lam) ,aa
1812 (,(C 'with-return) ,r
1813 (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
1814 (,(C 'with-self) ,c? ,aa
1815 ,(mk cd)))))))))))))
1816
1817 (#:global
1818 ((_ . _)
1819 `(,cvalues)))
1820
1821 (#:starexpr
1822 ((_ _ _ id . _)
1823 `(#:star ,(exp vs id))))
1824
1825 (#:list
1826 ((_ x (and e (#:cfor . _)))
1827 (let ((l (gensym "l")))
1828 `(,(G 'let) ((,l (,(L 'to-pylist) (,(G 'quote) ()))))
1829 ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
1830 ,l)))
1831
1832 ((_ . l)
1833 (list (L 'to-pylist) (let lp ((l l))
1834 (match l
1835 ((or () #f) `(,(G 'quote) ()))
1836 (((#:starexpr #:power #f (#:list . l) . _) . _)
1837 (lp l))
1838 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1839 (lp l))
1840 (((#:starexpr . l) . _)
1841 `(,(L 'to-list) ,(exp vs l)))
1842 ((x . l)
1843 `(,(G 'cons) ,(exp vs x) ,(lp l))))))))
1844 (#:tuple
1845 ((_ x (and e (#:cfor . _)))
1846 (exp vs (list #:comp x e)))
1847
1848 ((_ . l)
1849 (let lp ((l l))
1850 (match l
1851 (() `(,(G 'quote) ()))
1852 (((#:starexpr #:power #f (#:list . l) . _) . _)
1853 (lp l))
1854 (((#:starexpr #:power #f (#:tuple . l) . _) . _)
1855 (lp l))
1856 (((#:starexpr . l) . _)
1857 `(,(L 'to-list) ,(exp vs l)))
1858 ((x . l)
1859 `(,(G 'cons) ,(exp vs x) ,(lp l)))))))
1860
1861 (#:lambdef
1862 ((_ (#:var-args-list . v) e)
1863 (let ((as (get-args_ vs v))
1864 (a= (get-args= vs v))
1865 (a* (get-args* vs v))
1866 (** (get-args** vs v)))
1867 (list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e))))
1868
1869 ((_ () e)
1870 (list (C `lam) `() (exp vs e))))
1871
1872 (#:stmt
1873 ((_ l)
1874 (exp vs l)))
1875
1876 (#:expr-stmt
1877 ((_ (l ...) (#:assign))
1878 (let ((l (map (g vs exp) l)))
1879 (if (= (length l) 1)
1880 (car l)
1881 `(,(G 'values) ,@l))))
1882
1883 ((_ a (#:assign b c . u))
1884 (let ((z (gensym "x")))
1885 `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u)))))
1886 ,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z))))))))
1887
1888 ((_ l type)
1889 (=> fail)
1890 (call-with-values
1891 (lambda () (match type
1892 ((#:assign u)
1893 (values #f u))
1894 ((#:augassign op u)
1895 (values op u))
1896 (_ (fail))))
1897
1898 (lambda (op u)
1899 (cond
1900 ((= (length l) (length u))
1901 (if (= (length l) 1)
1902 `(,(G 'begin)
1903 ,(make-set vs op (car l) (exp vs (car u)))
1904 (,cvalues))
1905 `(,(G 'begin)
1906 ,@(map (lambda (l u) (make-set vs op l u))
1907 l
1908 (map (g vs exp) u))
1909 (,cvalues))))
1910
1911 ((and (= (length u) 1) (not op))
1912 (let ((vars (map (lambda (x) (gensym "v")) l))
1913 (spec (gensym "special"))
1914 (q (gensym "q"))
1915 (f (gensym "f"))
1916 (a? (is-special? vs l)))
1917 (if a?
1918 `(,(G 'begin)
1919 (call-with-values (lambda () ,(exp vs (car u)))
1920 (,(G 'letrec) ((,f
1921 (case-lambda
1922 ((,q)
1923 (,(G 'if) (pair? ,q)
1924 (,(G 'apply) ,f ,q)
1925 (,(G 'apply) ,f (,(L 'to-list) ,q))))
1926 (,spec
1927 (,(C 'qset!) ,a? ,spec)))))
1928 ,f))
1929 (,cvalues))
1930
1931 `(,(G 'begin)
1932 (call-with-values (lambda () ,(exp vs (car u)))
1933 (,(G 'letrec) ((,f
1934 (case-lambda
1935 ((,q)
1936 (,(G 'if) (pair? ,q)
1937 (,(G 'apply) ,f ,q)
1938 (,(G 'apply) ,f (,(L 'to-list) ,q))))
1939 (,vars
1940 ,@(map (lambda (l v) (make-set vs op l v))
1941 l vars)))))
1942 ,f))
1943 (,cvalues)))))
1944
1945 ((and (= (length l) 1) (not op))
1946 `(,(G 'begin)
1947 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
1948 (,cvalues)))))))
1949
1950 ((_
1951 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
1952 (#:assign (l)))
1953 (let ((s (string->symbol v)))
1954 `(,s/d ,s ,(exp vs l)))))
1955
1956 (#:assert
1957 ((_ x f n m)
1958 `(,(G 'if)
1959 (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
1960 x)))
1961 (,(C 'raise) ,(C 'AssertionError) (,(G 'quote) ,f) ,n ,m))))
1962
1963
1964
1965 (#:expr-stmt1
1966 ((_ a (#:assign b c . u))
1967 (let ((z (gensym "x")))
1968 `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b
1969 (#:assign ,c . ,u)))))
1970 ,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z))))))))
1971
1972 ((_ l type)
1973 (=> fail)
1974 (call-with-values
1975 (lambda () (match type
1976 ((#:assign u)
1977 (values #f u))
1978 ((#:augassign op u)
1979 (values op u))
1980 (_ (fail))))
1981
1982 (lambda (op u)
1983 (cond
1984 ((= (length l) (length u))
1985 (if (= (length l) 1)
1986 `(,(G 'begin)
1987 ,(make-set vs op (car l) (exp vs (car u)))
1988 ,(exp vs (car l)))
1989 `(,(G 'begin)
1990 ,@(map (lambda (l u) (make-set vs op l u))
1991 l
1992 (map (g vs exp) u))
1993 (,cvalues ,@(map (g exp vs) l)))))
1994
1995 ((and (= (length u) 1) (not op))
1996 (let ((vars (map (lambda (x) (gensym "v")) l))
1997 (q (gensym "q"))
1998 (f (gensym "f")))
1999 `(,(G 'begin)
2000 (call-with-values (lambda () ,(exp vs (car u)))
2001 (,(G 'letrec) ((,f
2002 (case-lambda
2003 ((,q)
2004 (,(G 'if) (pair? ,q)
2005 (,(G 'apply) ,f ,q)
2006 (,(G 'apply) ,f (,(L 'to-list) ,q))))
2007 (,vars
2008 ,@(map (lambda (l v) (make-set vs op l v))
2009 l vars)))))
2010 ,f))
2011 (,cvalues ,@(map (g exp vs) l)))))
2012
2013 ((and (= (length l) 1) (not op))
2014 `(,(G 'begin)
2015 ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
2016 (,cvalues ,(exp vs (car l))))))))))
2017
2018 (#:return
2019 ((_ x)
2020 (if x
2021 `(,(fluid-ref return) ,@(map (g vs exp) x))
2022 `(,(fluid-ref return)))))
2023
2024
2025 (#:dict
2026 ((_ . #f)
2027 `(,(Di 'make-py-hashtable)))
2028
2029 ((_ (#:e k . v) (and e (#:cfor . _)))
2030 (let ((dict (gensym "dict")))
2031 `(,(G 'let) ((,dict (,(Di 'make-py-hashtable))))
2032 ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
2033 ,dict)))
2034
2035 ((_ (#:e k . v) ...)
2036 (let ((dict (gensym "dict")))
2037 `(,(G 'let) ((,dict (,(Di 'make-py-hashtable))))
2038 ,@(map (lambda (k v)
2039 `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
2040 k v)
2041 ,dict)))
2042
2043 ((_ k (and e (#:cfor . _)))
2044 (let ((dict (gensym "dict")))
2045 `(,(G 'let) ((,dict (,(Se 'set))))
2046 ,(gen-sel vs e `((,(O 'ref) ,dict (,(G 'quote) add)) ,(exp vs k)))
2047 ,dict)))
2048
2049 ((_ k ...)
2050 (let ((set (gensym "dict")))
2051 `(,(G 'let) ((,set (,(Se 'set))))
2052 ,@(map (lambda (k)
2053 `((,(O 'ref) ,set (,(G 'quote) add)) ,(exp vs k)))
2054 k)
2055 ,set))))
2056
2057
2058 (#:comp
2059 ((_ x (and e (#:cfor . _)) . _)
2060 (let ((yield (gensym "yield")))
2061 `((,(Y 'make-generator) ()
2062 (lambda (,yield)
2063 ,(gen-sel vs e `(,yield ,(exp vs x))))))))
2064
2065 ((_ x #f)
2066 (exp vs x))
2067
2068 ((_ x (op . y))
2069 (tr-comp op (exp vs x) (exp vs y)))
2070
2071 ((_ x (op . y) . l)
2072 (let ((m (gensym "op")))
2073 `(,(G 'let) ((,m ,(exp vs y)))
2074 (,(G 'and) ,(tr-comp op (exp vs x) m)
2075 ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))
2076
2077
2078 (define (exp vs x)
2079 (match (pr 'exp x)
2080 ((e)
2081 (exp vs e))
2082 ((tag . l)
2083 ((hash-ref tagis tag
2084 (lambda y (warn (format #f "not tag in tagis ~a" tag)) x))
2085 x vs))
2086
2087 (#:True #t)
2088 (#:None (E 'None))
2089 (#:null `(,(G 'quote) ()))
2090 (#:False #f)
2091 (#:pass `(,cvalues))
2092 (#:break
2093 (C 'break))
2094 (#:continue
2095 (C 'continue))
2096 (x x)))
2097
2098 (define (comp in x)
2099 (define (strit x)
2100 (if in
2101 x
2102 (with-output-to-string
2103 (lambda ()
2104 (let lp ((x x))
2105 (if (pair? x)
2106 (begin
2107 (format #t "~s~%" (car x))
2108 (lp (cdr x)))))))))
2109
2110 (define start
2111 (match x
2112 (((#:stmt
2113 (#:comma
2114 (#:expr-stmt
2115 ((#:test
2116 (#:power #f
2117 (#:identifier "module" . _)
2118 ((#:arglist arglist))
2119 . #f) #f))
2120 (#:assign)))) . rest)
2121
2122 (let ()
2123 (define args
2124 (map (lambda (x)
2125 (exp '() x))
2126 arglist))
2127
2128 (define name (string-join (map symbol->string args) "."))
2129
2130 `((define-module (language python module ,@args)
2131 #:pure
2132 #:use-module ((guile) #:select
2133 (@ @@ pk let* lambda call-with-values case-lambda
2134 set! = * + - < <= > >= / pair? fluid-set!
2135 fluid-ref
2136 syntax-rules let-syntax abort-to-prompt))
2137 #:use-module (language python module python)
2138 #:use-module ((language python compile) #:select (pks))
2139 #:use-module (language python exceptions)
2140 #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
2141 (,(G 'define) __doc__ #f)
2142 (,(G 'define) __name__ ,name)
2143 (,(G 'define) __module__ (,(G 'quote)
2144 (language python module ,@args))))))
2145 (x '())))
2146
2147 (fluid-set! ignore '())
2148
2149 (strit
2150 (pr
2151 (if (fluid-ref (@@ (system base compile) %in-compile))
2152 (begin
2153 (if (fluid-ref (@@ (system base compile) %in-compile))
2154 (set! s/d (C 'qset!))
2155 (set! s/d (C 'define-)))
2156
2157 (if (pair? start)
2158 (set! x (cdr x)))
2159
2160 (let* ((globs (get-globals x))
2161 (e.doc (with-fluids ((*doc* #f))
2162 (let ((r (map (g globs exp) x)))
2163 (cons r (get-doc)))))
2164 (e (car e.doc))
2165 (doc (cdr e.doc)))
2166
2167 `(,@start
2168 (,(G 'define) ,fnm (,(G 'make-hash-table)))
2169 ,@(map (lambda (s)
2170 (if (member s (fluid-ref ignore))
2171 `(,cvalues)
2172 `(,(C 'var) ,s)))
2173 (cons '__doc__ globs))
2174 (,(G 'set!) __doc__ ,doc)
2175 ,@e
2176 (,(C 'export-all)))))
2177
2178 (begin
2179 (if (fluid-ref (@@ (system base compile) %in-compile))
2180 (set! s/d 'set!)
2181 (set! s/d (C 'define-)))
2182
2183 (if (pair? start)
2184 (set! x (cdr x)))
2185
2186 (let* ((globs (get-globals x))
2187 (res (gensym "res"))
2188 (e (map (g globs exp) x)))
2189 `(begin
2190 ,@start
2191 ,@(map (lambda (s)
2192 (if (member s (fluid-ref ignore))
2193 `(,cvalues)
2194 `(,(C 'var) ,s))) globs)
2195 (,(C 'with-exit) ,@e))))))))
2196
2197 (define-syntax-parameter break
2198 (lambda (x) #'(values)))
2199
2200 (define-syntax-parameter continue
2201 (lambda (x) (error "continue must be bound")))
2202
2203 (define (is-yield f p x)
2204 (match x
2205 ((#:def nm args _ code)
2206 (is-yield f #t code))
2207 ((#:yield x _)
2208 (eq? f (exp '() x)))
2209 ((#:yield _)
2210 (not p))
2211 ((a . l)
2212 (or
2213 (is-yield f p a)
2214 (is-yield f p l)))
2215 (_
2216 #f)))
2217
2218
2219
2220 (define-syntax with-sp
2221 (lambda (x)
2222 (syntax-case x ()
2223 ((_ ((x v)) code ...)
2224 (equal? (syntax->datum #'x) 'break)
2225 #'(syntax-parameterize ((break (lambda (y) #'v))) code ...))
2226
2227 ((_ ((x1 v1) (x2 v2)) code ...)
2228 (and (equal? (syntax->datum #'x1) 'break)
2229 (equal? (syntax->datum #'x2) 'continue))
2230 #'(syntax-parameterize ((break (lambda (y) #'v1))
2231 (continue (lambda (y) #'v2)))
2232 code ...))
2233
2234 ((_ ((x2 v2) (x1 v1)) code ...)
2235 (and (equal? (syntax->datum #'x1) 'break)
2236 (equal? (syntax->datum #'x2) 'continue))
2237 #'(syntax-parameterize ((break (lambda (y) #'v1))
2238 (continue (lambda (y) #'v2)))
2239 code ...)))))
2240
2241
2242 (define (is-ec ret x tail tags)
2243 (match x
2244 ((('@ ('guile) 'cond) (p a ... b) ...)
2245 (or
2246 (or-map (lambda (x) (or-map (lambda (x) (is-ec ret x #f tags)) x))
2247 a)
2248 (or-map (lambda (x) (is-ec ret x tail tags))
2249 b)))
2250
2251 (((_ _ 'with-self) u v a ... b)
2252 (or
2253 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2254 (is-ec ret b tail tags)))
2255
2256 (('let-syntax v a ... b)
2257 (or
2258 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2259 (is-ec ret b tail tags)))
2260
2261 ((('@ ('guile) 'begin) a ... b)
2262 (or
2263 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2264 (is-ec ret b tail tags)))
2265
2266 ((('@ ('guile) 'let) lp ((y x) ...) a ... b) (=> next)
2267 (if (symbol? lp)
2268 (or
2269 (or-map (lambda (x) (is-ec ret x #f tags)) x)
2270 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2271 (is-ec ret b tail tags))
2272 (next)))
2273
2274 ((('@ ('guile) 'let) ((y x) ...) a ... b)
2275 (or
2276 (or-map (lambda (x) (is-ec ret x #f tags)) x)
2277 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2278 (is-ec ret b tail tags)))
2279
2280 (('let* ((y x) ...) a ... b)
2281 (or
2282 (or-map (lambda (x) (is-ec ret x #f tags)) x)
2283 (or-map (lambda (x) (is-ec ret x #f tags)) a)
2284 (is-ec ret b tail tags)))
2285
2286 ((('@ ('guile) 'define) . _)
2287 #f)
2288
2289 ((('@ ('guile) 'if) p a b)
2290 (or
2291 (is-ec ret p #f tags)
2292 (is-ec ret a tail tags)
2293 (is-ec ret b tail tags)))
2294
2295 ((('@ ('guile) 'if) p a)
2296 (or
2297 (is-ec ret #'p #f tags)
2298 (is-ec ret #'a tail tags)))
2299
2300 (('@@ _ _)
2301 (if (member x tags)
2302 #t
2303 #f))
2304
2305
2306 ((a ...)
2307 (or-map (lambda (x) (is-ec ret x #f tags)) a))
2308
2309 (x #f)))
2310
2311 (define-syntax with-return
2312 (lambda (x)
2313 (define (analyze ret x)
2314 (syntax-case x (let-syntax let* @ @@)
2315 ((cond- (p a ... b) ...)
2316 (equal? (syntax->datum #'cond-)
2317 '(@ (guile) cond))
2318 (with-syntax (((bb ...) (map (lambda (x) (analyze ret x)) #'(b ...))))
2319 #'(cond (p a ... bb) ...)))
2320
2321 (((_ _ with-self-) u v a ... b)
2322 (equal? (syntax->datum #'with-self-)
2323 'with-self)
2324 #`(with-self u v a ... #,(analyze ret #'b)))
2325
2326 ((let-syntax v a ... b)
2327 #`(let-syntax v a ... #,(analyze ret #'b)))
2328
2329 (((@ (guile) begin-) a ... b)
2330 (equal? (syntax->datum #'begin-)
2331 'begin)
2332 #`(begin a ... #,(analyze ret #'b)))
2333
2334 (((@ (guile) let-) lp v a ... b)
2335 (and
2336 (equal? (syntax->datum #'let-)
2337 'let)
2338 (symbol? (syntax->datum #'lp)))
2339 #`(let lp v a ... #,(analyze ret #'b)))
2340
2341 (((@ (guile) let-) v a ... b)
2342 (equal? (syntax->datum #'let-)
2343 'let)
2344 #`(let v a ... #,(analyze ret #'b)))
2345
2346 (((@ (guile) if-) p a b)
2347 (equal? (syntax->datum #'if-)
2348 'if)
2349 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
2350
2351 (((@ (guile) if-) p a)
2352 (equal? (syntax->datum #'if-)
2353 'if)
2354 #`(if p #,(analyze ret #'a)))
2355
2356 ((return a b ...)
2357 (equal? (syntax->datum #'return) (syntax->datum ret))
2358 (if (eq? #'(b ...) '())
2359 #'a
2360 #`(values a b ...)))
2361
2362 ((return)
2363 (equal? (syntax->datum #'return) (syntax->datum ret))
2364 #`(values))
2365
2366 (x #'x)))
2367
2368 (define (is-ec ret x tail)
2369 (syntax-case x (let-syntax let* @@ @)
2370 (((@ (guile) cond) (p a ... b) ...)
2371 (equal? (syntax->datum #'cond)
2372 'cond)
2373 (or
2374 (or-map (lambda (x) (is-ec ret x #f))
2375 #'(a ... ...))
2376 (or-map (lambda (x) (is-ec ret x tail))
2377 #'(b ...))))
2378
2379 (((_ _ with-self) u v a ... b)
2380 (equal? (syntax->datum #'with-self)
2381 'with-self)
2382 (or
2383 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2384 (is-ec ret #'b tail)))
2385
2386 ((let-syntax v a ... b)
2387 #t
2388 (or
2389 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2390 (is-ec ret #'b tail)))
2391
2392 (((@ (guile) begin) a ... b)
2393 (equal? (syntax->datum #'begin)
2394 'begin)
2395 (or
2396 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2397 (is-ec ret #'b tail)))
2398
2399 (((@ (guile) let) lp ((y x) ...) a ... b)
2400 (and
2401 (equal? (syntax->datum #'let)
2402 'let)
2403 (symbol? (syntax->datum #'lp)))
2404
2405 (or
2406 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
2407 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2408 (is-ec ret #'b tail)))
2409
2410 (((@ (guile) let) ((y x) ...) a ... b)
2411 (equal? (syntax->datum #'let)
2412 'let)
2413 (or
2414 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
2415 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2416 (is-ec ret #'b tail)))
2417
2418 ((let* ((y x) ...) a ... b)
2419 #t
2420 (or
2421 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
2422 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
2423 (is-ec ret #'b tail)))
2424
2425 (((@ (guile) define) . _)
2426 (equal? (syntax->datum #'define)
2427 'define)
2428 #f)
2429
2430 (((@ (guile) if) p a b)
2431 (equal? (syntax->datum #'if)
2432 'if)
2433 (or
2434 (is-ec ret #'p #f)
2435 (is-ec ret #'a tail)
2436 (is-ec ret #'b tail)))
2437
2438 (((@ (guile) if) p a)
2439 (equal? (syntax->datum #'if)
2440 'if)
2441 (or
2442 (is-ec ret #'p #f)
2443 (is-ec ret #'a tail)))
2444
2445 ((return b ...)
2446 (equal? (syntax->datum #'return) (syntax->datum ret))
2447 (not tail))
2448
2449 ((a ...)
2450 #t
2451 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
2452
2453 (x
2454 #t
2455 #f)))
2456
2457 (syntax-case x ()
2458 ((_ ret l)
2459 (let ((code (analyze #'ret #'l)))
2460 (if (is-ec #'ret #'l #t)
2461 #`(let/ecx ret l)
2462 code))))))
2463
2464 (define void (list 'void))
2465
2466 (define-syntax var
2467 (lambda (x)
2468 (syntax-case x (cons quote)
2469 ((_ '())
2470 #'(values))
2471 ((_ (cons x v))
2472 #'(begin (var x) (var v)))
2473 ((_ v)
2474 (begin
2475 (dont-warn (syntax->datum #'v))
2476 #'(if (module-defined? (current-module) 'v)
2477 (values)
2478 (define! 'v void)))))))
2479
2480 (define-inlinable (non? x) (eq? x #:nil))
2481
2482 (define (gentemp stx) (datum->syntax stx (gensym "x")))
2483
2484 (define-syntax mmatch
2485 (syntax-rules ()
2486 ((_ (a . aa) (b . bb) . code)
2487 (match a (b (mmatch aa bb . code))))
2488 ((_ () () . code)
2489 (begin . code))))
2490
2491 (define (mutewarn x y) (list x y))
2492
2493 (define-syntax clambda
2494 (lambda (x)
2495 (syntax-case x ()
2496 ((_ (x ...) code ...)
2497 (with-syntax ((n (length #'(x ...)))
2498 ((y ...) (generate-temporaries #'(x ...))))
2499 #'(let ((f (lambda (y ... . u)
2500 (mmatch (y ...) (x ...) code ...))))
2501 (if (> n 1)
2502 (case-lambda
2503 ((c)
2504 (if (pair? c)
2505 (let ((cc (cdr c)))
2506 (if (pair? cc)
2507 (apply f c)
2508 (apply f (mutewarn c cc))))
2509 (py-apply f (* c))))
2510 (q (apply f q)))
2511 f)))))))
2512
2513 (define (gen-temp x)
2514 (syntax-case x ()
2515 ((x ...) (map gen-temp #'(x ...)))
2516 (x (car (generate-temporaries (list #'x))))))
2517
2518 (define (replace_ stx l)
2519 (let lp ((l l))
2520 (syntax-case l ()
2521 ((a . l) (cons (lp #'a) (lp #'l)))
2522 (x
2523 (if (equal? (syntax->datum #'x) '_)
2524 (datum->syntax stx (gensym "_"))
2525 #'x)))))
2526
2527 (define-syntax with-syntax*
2528 (syntax-rules ()
2529 ((_ () code) code)
2530 ((_ () . code) (begin . code))
2531 ((_ (x . l) . code)
2532 (with-syntax (x) (with-syntax* l . code)))))
2533
2534 (define-syntax cfor
2535 (lambda (xx)
2536 (syntax-case xx ()
2537 ((_ (x ...) in code next p)
2538 (or-map pair? #'(x ...))
2539 #'(for-adv (x ...) in code next p))
2540
2541 ((_ (x) (a) code #f #f)
2542 (with-syntax ((x (replace_ xx #'x)))
2543 #'(if (pair? a)
2544 (let/ecx break-ret
2545 (let lp ((l a))
2546 (if (pair? l)
2547 (begin
2548 (set! x (car l))
2549 (with-sp ((continue (values))
2550 (break (break-ret)))
2551 code)
2552 (lp (cdr l))))))
2553 (for/adv1 (x) (a) code #f #f))))
2554
2555 ((_ (x) (a) code #f #t)
2556 (with-syntax ((x (replace_ xx #'x)))
2557 #'(if (pair? a)
2558 (let/ecx break-ret
2559 (let lp ((l a))
2560 (if (pair? l)
2561 (begin
2562 (let/ecx continue-ret
2563 (set! x (car l))
2564 (with-sp ((continue (continue-ret))
2565 (break (break-ret)))
2566 code))
2567 (lp (cdr l))))))
2568 (for/adv1 (x) (a) code #f #t))))
2569
2570 ((_ (x) (a) code next #f)
2571 (with-syntax ((x (replace_ xx #'x)))
2572 #'(if (pair? a)
2573 (let/ecx break-ret
2574 (let lp ((l a))
2575 (if (pair? l)
2576 (begin
2577 (set! x (car l))
2578 (with-sp ((continue (values))
2579 (break (break-ret)))
2580 code))
2581 (lp (cdr l))))
2582 next)
2583 (for/adv1 (x) (a) code next #f))))
2584
2585 ((_ (x) (a) code next #t)
2586 (with-syntax ((x (replace_ xx #'x)))
2587 #'(if (pair? a)
2588 (let/ecx break-ret
2589 (let lp ((l a))
2590 (if (pair? l)
2591 (let/ecx continue-ret
2592 (set! x (car l))
2593 (with-sp ((continue (continue-ret))
2594 (break (break-ret)))
2595 code))
2596 (lp (cdr l))))
2597 next)
2598 (for/adv1 (x) (a) code next #f))))
2599
2600 ((_ x a code next p)
2601 #'(for/adv1 x a code next p)))))
2602
2603 (define-syntax for/adv1
2604 (lambda (zz)
2605 (syntax-case zz ()
2606 ((_ (xy ...) (in) code #f #f)
2607 (with-syntax* ((inv (gentemp #'in))
2608 ((yy ...) (replace_ zz #'(xy ...)))
2609 ((xx ...) (gen-temp #'(yy ...))))
2610 #'(let ((inv (wrap-in in)))
2611 (clet (yy ...)
2612 (catch StopIteration
2613 (lambda ()
2614 (let lp ()
2615 (call-with-values (lambda () (next inv))
2616 (clambda (xx ...)
2617 (cset! yy xx) ...
2618 (with-sp ((break (values))
2619 (continue (values)))
2620 code
2621 (lp))))))
2622 (lambda z (values)))))))
2623
2624 ((_ (xy ...) (in ...) code #f #f)
2625 (with-syntax* (((inv ...) (generate-temporaries #'(in ...)))
2626 ((yy ...) (replace_ zz #'(xy ...)))
2627 ((xx ...) (gen-temp #'(yy ...))))
2628 #'(let ((inv (wrap-in in)) ...)
2629 (clet (yy ...)
2630 (catch StopIteration
2631 (lambda ()
2632 (let lp ()
2633 (call-with-values (lambda () (values (next inv) ...))
2634 (clambda (xx ...)
2635 (cset! yy xx) ...
2636 (with-sp ((break (values))
2637 (continue (values)))
2638 code
2639 (lp))))))
2640 (lambda z (values)))))))
2641
2642 ((_ (xy ...) (in) code #f #t)
2643 (with-syntax* ((inv (gentemp #'in))
2644 ((yy ...) (replace_ zz #'(xy ...)))
2645 ((xx ...) (gen-temp #'(yy ...))))
2646 #'(let ((inv (wrap-in in)))
2647 (clet (yy ...)
2648 (let lp ()
2649 (let/ecx break-ret
2650 (catch StopIteration
2651 (lambda ()
2652 (call-with-values (lambda () (next inv))