Better python semantics is now followed
[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 (ice-9 pretty-print)
7 #:export (comp send sendException sendClose))
8
9 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
10
11 (define-syntax clear-warning-data
12 (lambda (x)
13 (pr 'clear)
14 (set! (@@ (system base message) %dont-warn-list) '())
15 #f))
16
17 (define (dont-warn v)
18 (set! (@@ (system base message) %dont-warn-list)
19 (cons v
20 (@@ (system base message) %dont-warn-list))))
21
22 (define-syntax call
23 (syntax-rules ()
24 ((_ (f) . l) (f . l))))
25
26 (define (fold f init l)
27 (if (pair? l)
28 (fold f (f (car l) init) (cdr l))
29 init))
30
31 (define (pr . x)
32 (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
33 (with-output-to-port port
34 (lambda ()
35 (pretty-print (syntax->datum x))))
36 (close port)
37 (car (reverse x)))
38
39 (define (pf x)
40 (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
41 (with-output-to-port port
42 (lambda () (pretty-print (syntax->datum x)) x))
43 (close port)
44 x)
45
46 (define (C x) `(@@ (language python compile) ,x))
47 (define (O x) `(@@ (oop pf-objects) ,x))
48 (define (G x) `(@ (guile) ,x))
49
50 (define (union as vs)
51 (let lp ((as as) (vs vs))
52 (match as
53 ((x . as)
54 (if (member x vs)
55 (lp as vs)
56 (lp as (cons x vs))))
57 (()
58 vs))))
59
60 (define (diff as vs)
61 (let lp ((as as) (rs '()))
62 (match as
63 ((x . as)
64 (if (member x vs)
65 (lp as rs)
66 (lp as (cons x rs))))
67 (()
68 rs))))
69
70 (define (get-globals code)
71 (let lp ((vs (glob code '())) (rs (scope code '())))
72 (match vs
73 ((x . l)
74 (if (member x rs)
75 (lp l rs)
76 (lp l (cons x rs))))
77 (()
78 rs))))
79
80 (define (glob x vs)
81 (match x
82 ((#:global . l)
83 (let lp ((l l) (vs vs))
84 (match l
85 (((#:identifier v . _) . l)
86 (let ((s (string->symbol v)))
87 (if (member s vs)
88 (lp l vs)
89 (lp l (cons s vs)))))
90 (()
91 vs))))
92 ((x . y)
93 (glob y (glob x vs)))
94 (x vs)))
95
96 (define (scope x vs)
97 (match x
98 ((#:def f . _)
99 (union (list (exp '() f)) vs))
100
101 ((#:lambdef . _)
102 vs)
103
104 ((#:classdef f . _)
105 (union (list (exp '() f)) vs))
106
107 ((#:global . _)
108 vs)
109
110 ((#:expr-stmt l (#:assign u))
111 (union (fold (lambda (x s)
112 (match x
113 ((#:test (#:power v2 v1 () . _) . _)
114 (if v2
115 (union
116 (union (list (exp '() v1))
117 (list (exp '() v2)))
118 s)
119 (union (list (exp '() v1)) s)))
120 (() s)))
121 '()
122 l)
123 vs))
124
125 ((x . y)
126 (scope y (scope x vs)))
127 (_ vs)))
128
129 (define (defs x vs)
130 (match x
131 ((#:def (#:identifier f . _) . _)
132 (union (list (string->symbol f)) vs))
133 ((#:lambdef . _)
134 vs)
135 ((#:class . _)
136 vs)
137 ((#:global . _)
138 vs)
139 ((x . y)
140 (defs y (defs x vs)))
141 (_ vs)))
142
143 (define (gen-yield f)
144 (string->symbol
145 (string-append
146 (symbol->string f)
147 ".yield")))
148
149 (define (g vs e)
150 (lambda (x) (e vs x)))
151
152 (define return (make-fluid 'error-return))
153
154 (define (make-set vs x u)
155 (match x
156 ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
157 (if kind
158 (let ((v (string->symbol v)))
159 (if (null? addings)
160 `(set! ,v ,u)
161 (let ((addings (map (lambda (x) `',(exp vs x)) addings)))
162 `(set! ,(exp vs kind)
163 (,(O 'fset-x) ,v (list ,@addings) ,u)))))
164
165 (let ((v (string->symbol v)))
166 (if (null? addings)
167 `(set! ,v ,u)
168 (let* ((rev (reverse addings))
169 (las (car rev))
170 (new (reverse (cdr rev))))
171 `(,(O 'set) ,(let lp ((v v) (new new))
172 (match new
173 ((x . new)
174 (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
175 (() v)))
176 ',(exp vs las) ,u))))))))
177
178 (define is-class? (make-fluid #f))
179 (define (gen-yargs vs x)
180 (match (pr 'yarg x) ((#:list args)
181 (map (g vs exp) args))))
182
183 (define inhibit-finally #f)
184
185 (define (exp vs x)
186 (match (pr x)
187 ((#:power _ (x) () . #f)
188 (exp vs x))
189 ((#:power _ x () . #f)
190 (exp vs x))
191
192
193 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
194 ((#:power #f vf trailer . #f)
195 (let lp ((e (exp vs vf)) (trailer trailer))
196 (match trailer
197 (()
198 e)
199 ((#f)
200 (list e))
201 ((x . trailer)
202 (match (pr x)
203 ((#:identifier . _)
204 (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
205
206 ((#:arglist args #f #f)
207 (lp `(,e ,@(map (g vs exp) args)) trailer))
208 (_ (error "unhandled trailer")))))))
209
210 ((#:identifier x . _)
211 (string->symbol x))
212
213 ((#:string #f x)
214 x)
215
216 (((and x (or #:+ #:- #:* #:/)) . l)
217 (cons (keyword->symbol x) (map (g vs exp) l)))
218
219 ((#:u~ x)
220 (list 'lognot (exp vs x)))
221
222 ((#:band . l)
223 (cons 'logand (map (g vs exp) l)))
224
225 ((#:bxor . l)
226 (cons 'logxor (map (g vs exp) l)))
227
228 ((#:bor . l)
229 (cons 'logior (map (g vs exp) l)))
230
231 ((#:not x)
232 (list 'not (exp vs x)))
233
234 ((#:or . x)
235 (cons 'or (map (g vs exp) x)))
236
237 ((#:and . x)
238 (cons 'and (map (g vs exp) x)))
239
240 ((#:test e1 #f)
241 (exp vs e1))
242
243 ((#:test e1 e2 e3)
244 (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
245
246 ((#:if test a ((tests . as) ...) . else)
247 `(,(G 'cond)
248 (,(exp vs test) ,(exp vs a))
249 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
250 ,@(if else `((else ,(exp vs else))) '())))
251
252 ((#:suite . l) (cons 'begin (map (g vs exp) l)))
253
254 (#:True #t)
255 (#:False #f)
256
257 ((#:while test code . #f)
258 (let ((lp (gensym "lp")))
259 `(let ,lp ()
260 (if ,(exp vs test)
261 (begin
262 ,(exp vs code)
263 (,lp))))))
264
265 ((#:classdef (#:identifier class . _) parents defs)
266 (with-fluids ((is-class? #t))
267 (let ()
268 (define (filt l)
269 (reverse
270 (fold (lambda (x s)
271 (match x
272 ((or 'fast 'functional) s)
273 (x (cons x s))))
274 '() l)))
275 (define (is-functional l)
276 (fold (lambda (x pred)
277 (if pred
278 pred
279 (match x
280 ('functional #t)
281 (_ #f))))
282 #f l))
283 (define (is-fast l)
284 (fold (lambda (x pred)
285 (if pred
286 pred
287 (match x
288 ('fast #t)
289 (_ #f))))
290 #f l))
291
292
293 (let* ((class (string->symbol class))
294 (parents (match parents
295 (#f
296 '())
297 ((#:arglist args . _)
298 (map (g vs exp) args))))
299 (is-func (is-functional parents))
300 (is-fast (is-fast parents))
301 (kind (if is-func
302 (if is-fast
303 'mk-pf-class
304 'mk-pyf-class)
305 (if is-fast
306 'mk-p-class
307 'mk-py-class)))
308 (parents (filt parents)))
309 `(define ,class (,(O 'wrap)
310 (,(O kind)
311 ,class
312 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
313 #:const
314 ,(match (exp vs defs)
315 (('begin . l)
316 l)
317 ((('begin . l))
318 l)
319 (l l))
320 #:dynamic
321 ())))))))
322
323 ((#:import ((() nm) . #f))
324 `(use-modules (language python module ,(exp vs nm))))
325
326 (#:break
327 (C 'break))
328
329 (#:continue
330 (C 'continue))
331
332 ((#:for e in code . #f)
333 (=> next)
334 (match e
335 (((#:power #f (#:identifier x . _) () . #f))
336 (match in
337 (((#:test power . _))
338 (match power
339 ((#:power #f
340 (#:identifier "range" . _)
341 ((#:arglist arglist . _))
342 . _)
343 (match arglist
344 ((arg)
345 (let ((v (gensym "v"))
346 (x (string->symbol x))
347 (lp (gensym "lp")))
348 `(let ((,v ,(exp vs arg)))
349 (let ,lp ((,x 0))
350 (if (< ,x ,v)
351 (begin
352 ,(exp vs code)
353 (,lp (+ ,x 1))))))))
354 ((arg1 arg2)
355 (let ((v1 (gensym "va"))
356 (v2 (gensym "vb"))
357 (lp (gensym "lp")))
358 `(let ((,v1 ,(exp vs arg1))
359 (,v2 ,(exp vs arg2)))
360 (let ,lp ((,x ,v1))
361 (if (< ,x ,v2)
362 (begin
363 ,(exp vs code)
364 (,lp (+ ,x 1))))))))
365 ((arg1 arg2 arg3)
366 (let ((v1 (gensym "va"))
367 (v2 (gensym "vb"))
368 (st (gensym "vs"))
369 (lp (gensym "lp")))
370 `(let ((,v1 ,(exp vs arg1))
371 (,st ,(exp vs arg2))
372 (,v2 ,(exp vs arg3)))
373 (if (> st 0)
374 (let ,lp ((,x ,v1))
375 (if (< ,x ,v2)
376 (begin
377 ,(exp vs code)
378 (,lp (+ ,x ,st)))))
379 (if (< st 0)
380 (let ,lp ((,x ,v1))
381 (if (> ,x ,v2)
382 (begin
383 ,(exp vs code)
384 (,lp (+ ,x ,st)))))
385 (error "range with step 0 not allowed"))))))
386 (_ (next))))
387 (_ (next))))
388 (_ (next))))
389 (_ (next))))
390
391 ((#:for es in code . else)
392 (let* ((es2 (map (g vs exp) es))
393 (vs2 (union es2 vs))
394 (code2 (exp vs2 code))
395 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
396 (else2 (if else (exp vs2 else) #f))
397 (in2 (map (g vs exp) in)))
398 (list (C 'for) es2 in2 code2 else2 p)))
399
400 ((#:while test code else)
401 (let ((lp (gensym "lp")))
402 `(let ,lp ()
403 (if test
404 (begin
405 ,(exp vs code)
406 (,lp))
407 ,(exp vs else)))))
408
409 ((#:try x (or #f ()) #f . fin)
410 `(dynamic-wind
411 (lambda () #f)
412 (lambda () ,(exp vs x))
413 (lambda ()
414 (if (not ,(C 'inhibit-finally))
415 ,(exp vs fin)))))
416
417 ((#:subexpr . l)
418 (exp vs l))
419
420 ((#:try x exc else . fin)
421 (define (guard x)
422 (if fin
423 `(dynamic-wind
424 (lambda () #f)
425 (lambda () ,x)
426 (lambda ()
427 (if (not ,(C 'inhibit-finally))
428 ,(exp vs fin))))
429 x))
430 (define tag (gensym "tag"))
431 (define o (gensym "o"))
432 (define l (gensym "l"))
433 (guard
434 `(catch #t
435 (lambda () ,(exp vs x))
436 (lambda (,tag ,o . ,l)
437 ,(let lp ((it (if else (exp vs else) `(apply throw 'python
438 ,tag ,o ,l)))
439 (exc exc))
440 (match exc
441 ((((test . #f) code) . exc)
442 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
443 ,(exp vs code)
444 ,it)
445 exc))
446 ((((test . as) code) . exc)
447 (let ((a (exp vs as)))
448 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
449 (let ((,a ,o))
450 (,(O 'set) ,a '__excargs__ ,l)
451 ,(exp vs code))
452 ,it)
453 exc)))
454 (()
455 it)))))))
456
457 ((#:raise #f . #f)
458 `(throw 'python (,(O 'Exception))))
459
460 ((#:raise code . #f)
461 (let ((c (gensym "c")))
462 `(throw 'python
463 (let ((,c ,(exp vs code)))
464 (if (,(O 'pyclass?) ,c)
465 (,c)
466 ,c)))))
467
468 ((#:raise code . from)
469 (let ((o (gensym "o"))
470 (c (gensym "c")))
471 `(throw 'python
472 (let ((,c ,(exp vs code)))
473 (let ((,o (if (,(O 'pyclass?) ,c)
474 (,c)
475 ,c)))
476 (,(O 'set) ,o '__cause__ ,(exp vs from))
477 ,o)))))
478
479
480 ((#:yield args)
481 (let ((f (gensym "f")))
482 `(begin
483 (set! ,(C 'inhibit-finally) #t)
484 (let ((,f (scm.yield ,@(gen-yargs vs args))))
485 (,f)))))
486
487
488 ((#:yield f args)
489 (let ((f (gen-yield (exp vs f)))
490 (g (gensym "f")))
491 `(begin
492 (set! ,(C 'inhibit-finally) #t)
493 (let ((,g (,f ,@(gen-yargs vs args))))
494 (,g)))))
495
496 ((#:def f
497 (#:types-args-list
498 args
499 #f #f)
500 #f
501 code)
502 (let* ((c? (fluid-ref is-class?))
503 (f (exp vs f))
504 (y? (is-yield f #f code))
505 (r (gensym "return"))
506 (as (map (lambda (x) (match x
507 ((((#:identifier x . _) . #f) #f)
508 (string->symbol x))))
509 args))
510 (ab (gensym "ab"))
511 (vs (union as vs))
512 (ns (scope code vs))
513 (df (defs code '()))
514 (ex (gensym "ex"))
515 (y 'scm.yield)
516 (y.f (gen-yield f))
517 (ls (diff (diff ns vs) df)))
518
519 (define (mk code)
520 `(let-syntax ((,y (syntax-rules ()
521 ((_ . args)
522 (abort-to-prompt ,ab . args))))
523 (,y.f (syntax-rules ()
524 ((_ . args)
525 (abort-to-prompt ,ab . args)))))
526 ,code))
527
528 (with-fluids ((is-class? #f))
529 (if c?
530 (if y?
531 `(define ,f
532 (,(C 'def-wrap) ,y? ,f ,ab
533 (lambda (,@as)
534 (,(C 'with-return) ,r
535 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
536 ,(with-fluids ((return r))
537 (exp ns code))))))))
538
539 `(define ,f
540 (letrec ((,f
541 (case-lambda
542 ((,ex ,@as)
543 (,f ,@as))
544 ((,@as)
545 (,(C 'with-return) ,r
546 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
547 ,(with-fluids ((return r))
548 (exp ns code)))))))))
549 ,f)))
550
551 (if y?
552 `(define ,f
553 (,(C 'def-wrap) ,y? ,f ,ab
554 (lambda (,@as)
555 (,(C 'with-return) ,r
556 (let ,(map (lambda (x) (list x #f)) ls)
557 ,(with-fluids ((return r))
558 (mk
559 (exp ns code))))))))
560 `(define ,f
561 (lambda (,@as)
562 (,(C 'with-return) ,r
563 (let ,(map (lambda (x) (list x #f)) ls)
564 ,(with-fluids ((return r))
565 (exp ns code)))))))))))
566
567 ((#:global . _)
568 '(values))
569
570 ((#:lambdef v e)
571 (list `lambda v (exp vs e)))
572
573 ((#:stmt l)
574 (if (> (length l) 1)
575 (cons 'values (map (g vs exp) l))
576 (exp vs (car l))))
577
578
579 ((#:expr-stmt (l) (#:assign))
580 (exp vs l))
581
582 ((#:expr-stmt l (#:assign u))
583 (cond
584 ((= (length l) (length u))
585 (if (= (length l) 1)
586 (make-set vs (car l) (exp vs (car u)))
587 (cons 'begin
588 (map make-set
589 (map (lambda x vs) l)
590 l
591 (map (g vs exp) u)))))
592 ((= (length u) 1)
593 (let ((vars (map (lambda (x) (gensym "v")) l)))
594 `(call-with-values (lambda () (exp vs (car u)))
595 (lambda vars
596 ,@(map make-set l vars)))))))
597
598
599
600 ((#:return . x)
601 `(,(fluid-ref return) ,@(map (g vs exp) x)))
602
603 ((#:expr-stmt
604 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
605 (#:assign (l)))
606 (let ((s (string->symbol v)))
607 `(set! ,s ,(exp vs l))))
608
609 ((#:comp x #f)
610 (exp vs x))
611
612 ((#:comp x (op . y))
613 (define (tr op x y)
614 (match op
615 ((or "<" ">" "<=" ">=")
616 (list (G (string->symbol op)) x y))
617 ("!=" (list 'not (list 'equal? x y)))
618 ("==" (list 'equal? x y))
619 ("is" (list 'eq? x y))
620 ("isnot" (list 'not (list 'eq? x y)))
621 ("in" (list 'member x y))
622 ("notin" (list 'not (list 'member x y)))
623 ("<>" (list 'not (list 'equal? x y)))))
624 (tr op (exp vs x) (exp vs y)))
625
626 (x x)))
627
628 (define (comp x)
629 (define start
630 (match (pr 'start x)
631 (((#:stmt
632 ((#:expr-stmt
633 ((#:test
634 (#:power #f
635 (#:identifier "module" . _)
636 ((#:arglist arglist #f #f))
637 . #f) #f))
638 (#:assign)))) . _)
639 (let ()
640 (define args
641 (map (lambda (x)
642 (exp '() x))
643 arglist))
644
645 `((,(G 'define-module)
646 (language python module ,@args)
647 #:use-module (language python module python)))))
648 (x '())))
649
650 (if (pair? start)
651 (set! x (cdr x)))
652
653 (let ((globs (get-globals x)))
654 `(begin
655 ,@start
656 ,(C 'clear-warning-data)
657 (set! (@@ (system base message) %dont-warn-list) '())
658 ,@(map (lambda (s) `(,(C 'var) ',s)) globs)
659 ,@(map (g globs exp) x))))
660
661 (define-syntax-parameter break
662 (lambda (x) #'(values)))
663
664 (define-syntax-parameter continue
665 (lambda (x) (error "continue must be bound")))
666
667 (define (is-yield f p x)
668 (match x
669 ((#:def nm args _ code)
670 (is-yield f #t code))
671 ((#:yield x _)
672 (eq? f (exp '() x)))
673 ((#:yield _)
674 (not p))
675 ((a . l)
676 (or
677 (is-yield f p a)
678 (is-yield f p l)))
679 (_
680 #f)))
681
682
683
684 (define-syntax-rule (with-sp ((x v) ...) code ...)
685 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
686
687 (define (is-ec ret x tail tags)
688 (syntax-case (pr 'is-ec x) (begin let if define @@)
689 ((begin a ... b)
690 #t
691 (or
692 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
693 (is-ec ret #'b tail tags)))
694
695 ((let lp ((y x) ...) a ... b)
696 (symbol? (syntax->datum #'lp))
697 (or
698 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
699 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
700 (is-ec ret #'b tail tags)))
701
702 ((let ((y x) ...) a ... b)
703 #t
704 (or
705 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
706 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
707 (is-ec ret #'b tail tags)))
708
709 ((if p a b)
710 #t
711 (or
712 (is-ec ret #'p #f tags)
713 (is-ec ret #'a tail tags)
714 (is-ec ret #'b tail tags)))
715
716 ((define . _)
717 #t
718 #f)
719
720 ((if p a)
721 #t
722 (or
723 (is-ec ret #'p #f tags)
724 (is-ec ret #'a tail tags)))
725
726 ((@@ _ _)
727 #t
728 (if (member (pr (syntax->datum x)) tags)
729 #t
730 #f))
731
732 ((a ...)
733 #t
734 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
735
736 (x
737 #t
738 #f)))
739
740 (define-syntax with-return
741 (lambda (x)
742 (define (analyze ret x)
743 (syntax-case x (begin let if)
744 ((begin a ... b)
745 #`(begin a ... #,(analyze ret #'b)))
746 ((let lp v a ... b)
747 (symbol? (syntax->datum #'lp))
748 #`(let lp v a ... #,(analyze ret #'b)))
749 ((let v a ... b)
750 #`(let v a ... #,(analyze ret #'b)))
751 ((if p a b)
752 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
753 ((if p a)
754 #`(if p #,(analyze ret #'a)))
755 ((return a b ...)
756 (equal? (syntax->datum #'return) (syntax->datum ret))
757 (if (eq? #'(b ...) '())
758 #'a
759 #`(values a b ...)))
760 (x #'x)))
761
762 (define (is-ec ret x tail)
763 (syntax-case x (begin let if define @@)
764 ((begin a ... b)
765 #t
766 (or
767 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
768 (is-ec ret #'b tail)))
769
770 ((let lp ((y x) ...) a ... b)
771 (symbol? (syntax->datum #'lp))
772 (or
773 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
774 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
775 (is-ec ret #'b tail)))
776
777 ((let ((y x) ...) a ... b)
778 #t
779 (or
780 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
781 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
782 (is-ec ret #'b tail)))
783
784 ((define . _)
785 #t
786 #f)
787
788 ((if p a b)
789 #t
790 (or
791 (is-ec ret #'p #f)
792 (is-ec ret #'a tail)
793 (is-ec ret #'b tail)))
794
795 ((if p a)
796 #t
797 (or
798 (is-ec ret #'p #f)
799 (is-ec ret #'a tail)))
800
801 ((return a b ...)
802 (equal? (syntax->datum #'return) (syntax->datum ret))
803 (not tail))
804
805 ((a ...)
806 #t
807 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
808
809 (x
810 #t
811 #f)))
812
813 (syntax-case x ()
814 ((_ ret l)
815 (let ((code (analyze #'ret #'l)))
816 (if (is-ec #'ret #'l #t)
817 #`(let/ec ret #,code)
818 code))))))
819
820 (define (var v)
821 (begin
822 (dont-warn v)
823 (if (module-defined? (current-module) v)
824 (values)
825 (define! v #f))))
826
827 (define-inlinable (non? x) (eq? x #:nil))
828
829 (define-syntax for
830 (syntax-rules ()
831 ((_ (x) (a) code #f #f)
832 (if (pair? a)
833 (let lp ((l a))
834 (if (pair? l)
835 (let ((x (car l)))
836 (with-sp ((continue (lp (cdr l)))
837 (break (values)))
838 code
839 (lp (cdr l))))))
840 (for/adv1 (x) (a) code #f #f)))
841
842 ((_ (x) (a) code #f #t)
843 (if (pair? a)
844 (let/ec break-ret
845 (let lp ((l a))
846 (if (pair? l)
847 (begin
848 (let/ec continue-ret
849 (let ((x (car l)))
850 (with-sp ((continue (continue-ret))
851 (break (break-ret)))
852 code)))
853 (lp (cdr l))))))
854 (for/adv1 (x) (a) code #f #t)))
855
856 ((_ (x) (a) code next #f)
857 (if (pair? a)
858 (let/ec break-ret
859 (let ((x (let lp ((l a) (old #f))
860 (if (pair? l)
861 (let ((x (car l)))
862 (let/ec continue-ret
863 (with-sp ((continue (continue-ret))
864 (break (break-ret)))
865 code))
866 (lp (cdr l)))
867 old))))
868 next))
869 (for/adv1 (x) (a) code next #f)))
870
871 ((_ x a code next p)
872 (for/adv1 x a code next p))))
873
874 (define-syntax for/adv1
875 (lambda (x)
876 (syntax-case x ()
877 ((_ (x ...) (in ...) code #f #f)
878 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
879 #'(let ((inv (wrap-in in)) ...)
880 (catch StopIteration
881 (lambda ()
882 (let lp ()
883 (call-with-values (lambda () (values (next inv) ...))
884 (lambda (x ...)
885 (with-sp ((break (values))
886 (continue (values)))
887 code
888 (lp))))))
889 (lambda z (values))))))
890
891 ((_ (x ...) (in ...) code #f #t)
892 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
893 #'(let ((inv (wrap-in in)) ...)
894 (let lp ()
895 (let/ec break-ret
896 (catch StopIteration
897 (lambda ()
898 (call-with-values (lambda () (values (next inv) ...))
899 (lambda (x ...)
900 (let/ec continue-ret
901 (with-sp ((break (break-ret))
902 (continue (continue-ret)))
903 code))
904 (lp))))
905 (lambda z (values))))))))
906
907 ((_ (x ...) in code else #f)
908 #'(for-adv (x ...) in code else #f))
909
910 ((_ (x ...) in code else #t)
911 #'(for-adv (x ...) in code else #t)))))
912
913
914 (define-syntax for-adv
915 (lambda (x)
916 (define (gen x y)
917 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
918 (syntax-case x ()
919 ((x ...) #'(values (next x) ...)))
920 (syntax-case x ()
921 ((x) #'(next x)))))
922
923 (syntax-case x ()
924 ((_ (x ...) (in ...) code else p)
925 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
926 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
927 ((xx ...) (generate-temporaries #'(x ...))))
928 (if (syntax->datum #'p)
929 #'(let ((inv (wrap-in in)) ...)
930 (let/ec break-ret
931 (let ((x #f) ...)
932 (catch StopIteration
933 (lambda ()
934 (let lp ()
935 (call-with-values (lambda () get)
936 (lambda (xx ...)
937 (set! x xx) ...
938 (let/ec continue-ret
939 (with-sp ((break (break-ret))
940 (continue (continue-ret)))
941 code))
942 (lp)))))
943 (lambda q else)))))
944
945 #'(let ((inv (wrap-in in)) ...)
946 (let ((x #f) ...)
947 (let/ec break-ret
948 (catch StopIteration
949 (lambda ()
950 (let lp ()
951 (call-with-values (lambda () get)
952 (lambda (xx ...)
953 (set! x xx) ...
954 (with-sp ((break (break-ret))
955 (continue (values)))
956 code)
957 (lp)))))
958 (lambda e else))))))))))))
959
960
961 (define-class <scm-list> () l)
962 (define-class <scm-string> () s i)
963 (define-class <yield> () s k closed)
964
965 (define-method (next (l <scm-list>))
966 (let ((ll (slot-ref l 'l)))
967 (if (pair? ll)
968 (begin
969 (slot-set! l 'l (cdr ll))
970 (car ll))
971 (throw StopIteration))))
972
973 (define-method (next (l <scm-string>))
974 (let ((s (slot-ref l 's))
975 (i (slot-ref l 'i)))
976 (if (= i (string-length s))
977 (throw StopIteration)
978 (begin
979 (slot-set! l 'i (+ i 1))
980 (string-ref s i)))))
981
982 (define-method (next (l <yield>))
983 (let ((k (slot-ref l 'k))
984 (s (slot-ref l 's)))
985 (if k
986 (k (lambda () 'None))
987 (s))))
988
989 (define-method (send (l <yield>) . u)
990 (let ((k (slot-ref l 'k))
991 (s (slot-ref l 's))
992 (c (slot-ref l 'closed)))
993 (if (not c)
994 (if k
995 (k (lambda ()
996 (if (null? u)
997 'Null
998 (apply values u))))
999 (throw 'python (Exception))))))
1000
1001
1002 (define-method (sendException (l <yield>) e . ls)
1003 (let ((k (slot-ref l 'k))
1004 (s (slot-ref l 's))
1005 (c (slot-ref l 'closed)))
1006 (if (not c)
1007 (if k
1008 (k (lambda () (throw 'python (apply e ls))))
1009 (throw 'python (Exception))))))
1010
1011 (define-method (sendClose (l <yield>))
1012 (let ((k (slot-ref l 'k))
1013 (s (slot-ref l 's))
1014 (c (slot-ref l 'closed)))
1015 (if c
1016 (values)
1017 (if k
1018 (catch #t
1019 (lambda ()
1020 (k (lambda () (throw 'python GeneratorExit)))
1021 (slot-set! l 'closed #t)
1022 (throw 'python RuntimeError))
1023 (lambda (k tag . v)
1024 (slot-set! l 'closed #t)
1025 (if (eq? tag 'python)
1026 (match v
1027 ((tag . l)
1028 (if (eq? tag GeneratorExit)
1029 (values)
1030 (apply throw 'python tag l))))
1031 (apply throw tag v))))
1032 (slot-set! l 'closed #t)))))
1033
1034
1035 (define-method (wrap-in (x <p>))
1036 (aif it (ref x '__iter__ #f)
1037 (it)
1038 x))
1039
1040 (define-method (wrap-in x)
1041 (cond
1042 ((pair? x)
1043 (let ((o (make <scm-list>)))
1044 (slot-set! o 'l x)
1045 o))
1046
1047 ((string? x)
1048 (let ((o (make <scm-string>)))
1049 (slot-set! o 's x)
1050 (slot-set! o 'i 0)
1051 o))
1052
1053 (else
1054 x)))
1055
1056 (define yield-prompt (list 'yield))
1057 (define-syntax def-wrap
1058 (lambda (x)
1059 (syntax-case x ()
1060 ((_ #f f ab x)
1061 (pr 'def-wrap #'f 'false)
1062 #'x)
1063
1064 ((_ #t f ab code)
1065 (pr 'def-wrap #'f 'true)
1066 #'(lambda x
1067 (define obj (make <yield>))
1068 (define ab (make-prompt-tag))
1069 (slot-set! obj 'k #f)
1070 (slot-set! obj 'closed #f)
1071 (slot-set! obj 's
1072 (lambda ()
1073 (call-with-prompt
1074 ab
1075 (lambda ()
1076 (let/ec return
1077 (apply code x))
1078 (slot-set! obj 'closed #t)
1079 (throw StopIteration))
1080 (letrec ((lam
1081 (lambda (k . l)
1082 (set! inhibit-finally #f)
1083 (slot-set! obj 'k
1084 (lambda (a)
1085 (call-with-prompt
1086 ab
1087 (lambda ()
1088 (k a))
1089 lam)))
1090 (apply values l))))
1091 lam))))
1092 obj)))))
1093
1094
1095