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