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