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