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