try works
[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 (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 (exp vs x)
184 (match (pr x)
185 ((#:power _ (x) () . #f)
186 (exp vs x))
187 ((#:power _ x () . #f)
188 (exp vs x))
189
190
191 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
192 ((#:power #f vf trailer . #f)
193 (let lp ((e (exp vs vf)) (trailer trailer))
194 (match trailer
195 (()
196 e)
197 ((#f)
198 (list e))
199 ((x . trailer)
200 (match (pr x)
201 ((#:identifier . _)
202 (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
203
204 ((#:arglist args #f #f)
205 (lp `(,e ,@(map (g vs exp) args)) trailer))
206 (_ (error "unhandled trailer")))))))
207
208 ((#:identifier x . _)
209 (string->symbol x))
210
211 ((#:string #f x)
212 x)
213
214 (((and x (or #:+ #:- #:* #:/)) . l)
215 (cons (keyword->symbol x) (map (g vs exp) l)))
216
217 ((#:u~ x)
218 (list 'lognot (exp vs x)))
219
220 ((#:band . l)
221 (cons 'logand (map (g vs exp) l)))
222
223 ((#:bxor . l)
224 (cons 'logxor (map (g vs exp) l)))
225
226 ((#:bor . l)
227 (cons 'logior (map (g vs exp) l)))
228
229 ((#:not x)
230 (list 'not (exp vs x)))
231
232 ((#:or . x)
233 (cons 'or (map (g vs exp) x)))
234
235 ((#:and . x)
236 (cons 'and (map (g vs exp) x)))
237
238 ((#:test e1 #f)
239 (exp vs e1))
240
241 ((#:test e1 e2 e3)
242 (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
243
244 ((#:if test a ((tests . as) ...) . else)
245 `(,(G 'cond)
246 (,(exp vs test) ,(exp vs a))
247 ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
248 ,@(if else `((else ,(exp vs else))) '())))
249
250 ((#:suite . l) (cons 'begin (map (g vs exp) l)))
251
252 ((#:while test code #f)
253 (let ((lp (gensym "lp")))
254 `(let ,lp ()
255 (if test
256 (begin
257 ,(exp vs code)
258 (,lp))))))
259
260 ((#:classdef (#:identifier class . _) parents defs)
261 (with-fluids ((is-class? #t))
262 (let ()
263 (define (filt l)
264 (reverse
265 (fold (lambda (x s)
266 (match x
267 ((or 'fast 'functional) s)
268 (x (cons x s))))
269 '() l)))
270 (define (is-functional l)
271 (fold (lambda (x pred)
272 (if pred
273 pred
274 (match x
275 ('functional #t)
276 (_ #f))))
277 #f l))
278 (define (is-fast l)
279 (fold (lambda (x pred)
280 (if pred
281 pred
282 (match x
283 ('fast #t)
284 (_ #f))))
285 #f l))
286
287
288 (let* ((class (string->symbol class))
289 (parents (match parents
290 (#f
291 '())
292 ((#:arglist args . _)
293 (map (g vs exp) args))))
294 (is-func (is-functional parents))
295 (is-fast (is-fast parents))
296 (kind (if is-func
297 (if is-fast
298 'mk-pf-class
299 'mk-pyf-class)
300 (if is-fast
301 'mk-p-class
302 'mk-py-class)))
303 (parents (filt parents)))
304 `(define ,class (,(O 'wrap)
305 (,(O kind)
306 ,class
307 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
308 #:const
309 ,(match (exp vs defs)
310 (('begin . l)
311 l)
312 ((('begin . l))
313 l)
314 (l l))
315 #:dynamic
316 ())))))))
317
318 ((#:import ((() nm) . #f))
319 `(use-modules (language python module ,(exp vs nm))))
320
321 (#:break
322 (C 'break))
323
324 (#:continue
325 (C 'continue))
326
327 ((#:for e in code . #f)
328 (=> next)
329 (match e
330 (((#:power #f (#:identifier x . _) () . #f))
331 (match in
332 (((#:test power . _))
333 (match power
334 ((#:power #f
335 (#:identifier "range" . _)
336 ((#:arglist arglist . _))
337 . _)
338 (match arglist
339 ((arg)
340 (let ((v (gensym "v"))
341 (x (string->symbol x))
342 (lp (gensym "lp")))
343 `(let ((,v ,(exp vs arg)))
344 (let ,lp ((,x 0))
345 (if (< ,x ,v)
346 (begin
347 ,(exp vs code)
348 (,lp (+ ,x 1))))))))
349 ((arg1 arg2)
350 (let ((v1 (gensym "va"))
351 (v2 (gensym "vb"))
352 (lp (gensym "lp")))
353 `(let ((,v1 ,(exp vs arg1))
354 (,v2 ,(exp vs arg2)))
355 (let ,lp ((,x ,v1))
356 (if (< ,x ,v2)
357 (begin
358 ,(exp vs code)
359 (,lp (+ ,x 1))))))))
360 ((arg1 arg2 arg3)
361 (let ((v1 (gensym "va"))
362 (v2 (gensym "vb"))
363 (st (gensym "vs"))
364 (lp (gensym "lp")))
365 `(let ((,v1 ,(exp vs arg1))
366 (,st ,(exp vs arg2))
367 (,v2 ,(exp vs arg3)))
368 (if (> st 0)
369 (let ,lp ((,x ,v1))
370 (if (< ,x ,v2)
371 (begin
372 ,(exp vs code)
373 (,lp (+ ,x ,st)))))
374 (if (< st 0)
375 (let ,lp ((,x ,v1))
376 (if (> ,x ,v2)
377 (begin
378 ,(exp vs code)
379 (,lp (+ ,x ,st)))))
380 (error "range with step 0 not allowed"))))))
381 (_ (next))))
382 (_ (next))))
383 (_ (next))))
384 (_ (next))))
385
386 ((#:for es in code . else)
387 (let* ((es2 (map (g vs exp) es))
388 (vs2 (union es2 vs))
389 (code2 (exp vs2 code))
390 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
391 (else2 (if else (exp vs2 else) #f))
392 (in2 (map (g vs exp) in)))
393 (list (C 'for) es2 in2 code2 else2 p)))
394
395 ((#:while test code else)
396 (let ((lp (gensym "lp")))
397 `(let ,lp ()
398 (if test
399 (begin
400 ,(exp vs code)
401 (,lp))
402 ,(exp vs else)))))
403
404 ((#:try x (or #f ()) #f . fin)
405 `(dynamic-wind
406 (lambda () #f)
407 (lambda () ,(exp vs x))
408 (lambda () ,(exp vs fin))))
409
410 ((#:try x exc else . fin)
411 (define (guard x)
412 (if fin
413 `(dynamic-wind
414 (lambda () #f)
415 (lambda () ,x)
416 (lambda () ,(exp vs fin)))
417 x))
418 (define tag (gensym "tag"))
419 (define o (gensym "o"))
420 (define l (gensym "l"))
421 (guard
422 `(catch #t
423 (lambda () ,(exp vs x))
424 (lambda (,tag ,o . ,l)
425 ,(let lp ((it (if else (exp vs else) `(apply throw ,tag ,l)))
426 (exc exc))
427 (match exc
428 ((((test . #f) code) . exc)
429 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
430 ,(exp vs code)
431 ,it)
432 exc))
433 ((((test . as) code) . exc)
434 (let ((a (exp vs as)))
435 (lp `(if (,(O 'testex) ,o ,tag ,(exp vs test) ,l)
436 (let ((,a ,o))
437 (,(O 'set) ,a '__excargs__ ,l)
438 ,(exp vs code))
439 ,it)
440 exc)))
441 (()
442 it)))))))
443
444 ((#:raise #f . #f)
445 `(throw 'python (,(O 'Exception))))
446
447 ((#:raise code . #f)
448 (let ((c (gensym "c")))
449 `(throw 'python
450 (let ((,c ,(exp vs code)))
451 (if (,(O 'pyclass?) ,c)
452 (,c)
453 ,c)))))
454
455 ((#:raise code . from)
456 (let ((o (gensym "o"))
457 (c (gensym "c")))
458 `(throw 'python
459 (let ((,c ,(exp vs code)))
460 (let ((,o (if (,(O 'pyclass?) ,c)
461 (,c)
462 ,c)))
463 (,(O 'set) ,o '__cause__ ,(exp vs from))
464 ,o)))))
465
466
467 ((#:yield args)
468 `(scm-yield ,@(gen-yargs vs args)))
469
470
471 ((#:yield f args)
472 (let ((f (gen-yield (exp vs f))))
473 `(,f ,@(gen-yargs vs args))))
474
475 ((#:def f
476 (#:types-args-list
477 args
478 #f #f)
479 #f
480 code)
481 (let* ((c? (fluid-ref is-class?))
482 (f (exp vs f))
483 (y? (is-yield f #f code))
484 (r (gensym "return"))
485 (as (map (lambda (x) (match x
486 ((((#:identifier x . _) . #f) #f)
487 (string->symbol x))))
488 args))
489 (ab (gensym "ab"))
490 (vs (union as vs))
491 (ns (scope code vs))
492 (df (defs code '()))
493 (ex (gensym "ex"))
494 (y 'scm.yield)
495 (y.f (gen-yield f))
496 (ls (diff (diff ns vs) df)))
497
498 (define (mk code)
499 `(let-syntax ((,y (syntax-rules ()
500 ((_ . args)
501 (abort-to-prompt ,ab . args))))
502 (,y.f (syntax-rules ()
503 ((_ . args)
504 (abort-to-prompt ,ab . args)))))
505 ,code))
506
507 (with-fluids ((is-class? #f))
508 (if c?
509 (if y?
510 `(define ,f
511 (,(C 'def-wrap) ,y? ,f ,ab
512 (lambda (,@as)
513 (,(C 'with-return) ,r
514 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
515 ,(with-fluids ((return r))
516 (exp ns code))))))))
517
518 `(define ,f
519 (letrec ((,f
520 (case-lambda
521 ((,ex ,@as)
522 (,f ,@as))
523 ((,@as)
524 (,(C 'with-return) ,r
525 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
526 ,(with-fluids ((return r))
527 (exp ns code)))))))))
528 ,f)))
529
530 (if y?
531 `(define ,f
532 (,(C 'def-wrap) ,y? ,f ,ab
533 (lambda (,@as)
534 (,(C 'with-return) ,r
535 (let ,(map (lambda (x) (list x #f)) ls)
536 ,(with-fluids ((return r))
537 (mk
538 (exp ns code))))))))
539 `(define ,f
540 (lambda (,@as)
541 (,(C 'with-return) ,r
542 (let ,(map (lambda (x) (list x #f)) ls)
543 ,(with-fluids ((return r))
544 (exp ns code)))))))))))
545
546 ((#:global . _)
547 '(values))
548
549 ((#:lambdef v e)
550 (list `lambda v (exp vs e)))
551
552 ((#:stmt l)
553 (if (> (length l) 1)
554 (cons 'values (map (g vs exp) l))
555 (exp vs (car l))))
556
557
558 ((#:expr-stmt (l) (#:assign))
559 (exp vs l))
560
561 ((#:expr-stmt l (#:assign u))
562 (cond
563 ((= (length l) (length u))
564 (if (= (length l) 1)
565 (make-set vs (car l) (exp vs (car u)))
566 (cons 'begin
567 (map make-set
568 (map (lambda x vs) l)
569 l
570 (map (g vs exp) u)))))
571 ((= (length u) 1)
572 (let ((vars (map (lambda (x) (gensym "v")) l)))
573 `(call-with-values (lambda () (exp vs (car u)))
574 (lambda vars
575 ,@(map make-set l vars)))))))
576
577
578
579 ((#:return . x)
580 `(,(fluid-ref return) ,@(map (g vs exp) x)))
581
582 ((#:expr-stmt
583 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
584 (#:assign (l)))
585 (let ((s (string->symbol v)))
586 `(set! ,s ,(exp vs l))))
587
588 ((#:comp x #f)
589 (exp vs x))
590
591 ((#:comp x (op . y))
592 (define (tr op x y)
593 (match op
594 ((or "<" ">" "<=" ">=")
595 (list (G (string->symbol op)) x y))
596 ("!=" (list 'not (list 'equal? x y)))
597 ("==" (list 'equal? x y))
598 ("is" (list 'eq? x y))
599 ("isnot" (list 'not (list 'eq? x y)))
600 ("in" (list 'member x y))
601 ("notin" (list 'not (list 'member x y)))
602 ("<>" (list 'not (list 'equal? x y)))))
603 (tr op (exp vs x) (exp vs y)))
604
605 (x x)))
606
607 (define (comp x)
608 (define start
609 (match (pr 'start x)
610 (((#:stmt
611 ((#:expr-stmt
612 ((#:test
613 (#:power #f
614 (#:identifier "module" . _)
615 ((#:arglist arglist #f #f))
616 . #f) #f))
617 (#:assign)))) . _)
618 (let ()
619 (define args
620 (map (lambda (x)
621 (exp '() x))
622 arglist))
623
624 `((,(G 'define-module)
625 (language python module ,@args)
626 #:use-module (language python module python)))))
627 (x '())))
628
629 (if (pair? start)
630 (set! x (cdr x)))
631
632 (let ((globs (get-globals x)))
633 `(begin
634 ,@start
635 ,(C 'clear-warning-data)
636 (set! (@@ (system base message) %dont-warn-list) '())
637 ,@(map (lambda (s) `(,(C 'var) ',s)) globs)
638 ,@(map (g globs exp) x))))
639
640 (define-syntax-parameter break
641 (lambda (x) #'(values)))
642
643 (define-syntax-parameter continue
644 (lambda (x) (error "continue must be bound")))
645
646 (define (is-yield f p x)
647 (match x
648 ((#:def nm args _ code)
649 (is-yield f #t code))
650 ((#:yield x _)
651 (eq? f (exp '() x)))
652 ((#:yield _)
653 (not p))
654 ((a . l)
655 (or
656 (is-yield f p a)
657 (is-yield f p l)))
658 (_
659 #f)))
660
661
662
663 (define-syntax-rule (with-sp ((x v) ...) code ...)
664 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
665
666 (define (is-ec ret x tail tags)
667 (syntax-case (pr 'is-ec x) (begin let if define @@)
668 ((begin a ... b)
669 #t
670 (or
671 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
672 (is-ec ret #'b tail tags)))
673
674 ((let lp ((y x) ...) a ... b)
675 (symbol? (syntax->datum #'lp))
676 (or
677 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
678 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
679 (is-ec ret #'b tail tags)))
680
681 ((let ((y x) ...) a ... b)
682 #t
683 (or
684 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
685 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
686 (is-ec ret #'b tail tags)))
687
688 ((if p a b)
689 #t
690 (or
691 (is-ec ret #'p #f tags)
692 (is-ec ret #'a tail tags)
693 (is-ec ret #'b tail tags)))
694
695 ((define . _)
696 #t
697 #f)
698
699 ((if p a)
700 #t
701 (or
702 (is-ec ret #'p #f tags)
703 (is-ec ret #'a tail tags)))
704
705 ((@@ _ _)
706 #t
707 (if (member (pr (syntax->datum x)) tags)
708 #t
709 #f))
710
711 ((a ...)
712 #t
713 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
714
715 (x
716 #t
717 #f)))
718
719 (define-syntax with-return
720 (lambda (x)
721 (define (analyze ret x)
722 (syntax-case x (begin let if)
723 ((begin a ... b)
724 #`(begin a ... #,(analyze ret #'b)))
725 ((let lp v a ... b)
726 (symbol? (syntax->datum #'lp))
727 #`(let lp v a ... #,(analyze ret #'b)))
728 ((let v a ... b)
729 #`(let v a ... #,(analyze ret #'b)))
730 ((if p a b)
731 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
732 ((if p a)
733 #`(if p #,(analyze ret #'a)))
734 ((return a b ...)
735 (equal? (syntax->datum #'return) (syntax->datum ret))
736 (if (eq? #'(b ...) '())
737 #'a
738 #`(values a b ...)))
739 (x #'x)))
740
741 (define (is-ec ret x tail)
742 (syntax-case x (begin let if define @@)
743 ((begin a ... b)
744 #t
745 (or
746 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
747 (is-ec ret #'b tail)))
748
749 ((let lp ((y x) ...) a ... b)
750 (symbol? (syntax->datum #'lp))
751 (or
752 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
753 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
754 (is-ec ret #'b tail)))
755
756 ((let ((y x) ...) a ... b)
757 #t
758 (or
759 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
760 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
761 (is-ec ret #'b tail)))
762
763 ((define . _)
764 #t
765 #f)
766
767 ((if p a b)
768 #t
769 (or
770 (is-ec ret #'p #f)
771 (is-ec ret #'a tail)
772 (is-ec ret #'b tail)))
773
774 ((if p a)
775 #t
776 (or
777 (is-ec ret #'p #f)
778 (is-ec ret #'a tail)))
779
780 ((return a b ...)
781 (equal? (syntax->datum #'return) (syntax->datum ret))
782 (not tail))
783
784 ((a ...)
785 #t
786 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
787
788 (x
789 #t
790 #f)))
791
792 (syntax-case x ()
793 ((_ ret l)
794 (let ((code (analyze #'ret #'l)))
795 (if (is-ec #'ret #'l #t)
796 #`(let/ec ret #,code)
797 code))))))
798
799 (define (var v)
800 (begin
801 (dont-warn v)
802 (if (module-defined? (current-module) v)
803 (values)
804 (define! v #f))))
805
806 (define-inlinable (non? x) (eq? x #:nil))
807
808 (define-syntax for
809 (syntax-rules ()
810 ((_ (x) (a) code #f #f)
811 (if (pair? a)
812 (let lp ((l a))
813 (if (pair? l)
814 (let ((x (car l)))
815 (with-sp ((continue (lp (cdr l)))
816 (break (values)))
817 code
818 (lp (cdr l))))))
819 (for/adv1 (x) (a) code #f #f)))
820
821 ((_ (x) (a) code #f #t)
822 (if (pair? a)
823 (let/ec break-ret
824 (let lp ((l a))
825 (if (pair? l)
826 (begin
827 (let/ec continue-ret
828 (let ((x (car l)))
829 (with-sp ((continue (continue-ret))
830 (break (break-ret)))
831 code)))
832 (lp (cdr l))))))
833 (for/adv1 (x) (a) code #f #t)))
834
835 ((_ (x) (a) code next #f)
836 (if (pair? a)
837 (let/ec break-ret
838 (let ((x (let lp ((l a) (old #f))
839 (if (pair? l)
840 (let ((x (car l)))
841 (let/ec continue-ret
842 (with-sp ((continue (continue-ret))
843 (break (break-ret)))
844 code))
845 (lp (cdr l)))
846 old))))
847 next))
848 (for/adv1 (x) (a) code next #f)))
849
850 ((_ x a code next p)
851 (for/adv1 x a code next p))))
852
853 (define-syntax for/adv1
854 (lambda (x)
855 (syntax-case x ()
856 ((_ (x ...) (in ...) code #f #f)
857 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
858 #'(let ((inv (wrap-in in)) ...)
859 (catch StopIteration
860 (lambda ()
861 (let lp ()
862 (call-with-values (lambda () (values (next inv) ...))
863 (lambda (x ...)
864 (with-sp ((break (values))
865 (continue (values)))
866 code
867 (lp))))))
868 (lambda z (values))))))
869
870 ((_ (x ...) (in ...) code #f #t)
871 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
872 #'(let ((inv (wrap-in in)) ...)
873 (let lp ()
874 (let/ec break-ret
875 (catch StopIteration
876 (lambda ()
877 (call-with-values (lambda () (values (next inv) ...))
878 (lambda (x ...)
879 (let/ec continue-ret
880 (with-sp ((break (break-ret))
881 (continue (continue-ret)))
882 code))
883 (lp))))
884 (lambda z (values))))))))
885
886 ((_ (x ...) in code else #f)
887 #'(for-adv (x ...) in code else #f))
888
889 ((_ (x ...) in code else #t)
890 #'(for-adv (x ...) in code else #t)))))
891
892
893 (define-syntax for-adv
894 (lambda (x)
895 (define (gen x y)
896 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
897 (syntax-case x ()
898 ((x ...) #'(values (next x) ...)))
899 (syntax-case x ()
900 ((x) #'(next x)))))
901
902 (syntax-case x ()
903 ((_ (x ...) (in ...) code else p)
904 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
905 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
906 ((xx ...) (generate-temporaries #'(x ...))))
907 (if (syntax->datum #'p)
908 #'(let ((inv (wrap-in in)) ...)
909 (let/ec break-ret
910 (let ((x #f) ...)
911 (catch StopIteration
912 (lambda ()
913 (let lp ()
914 (call-with-values (lambda () get)
915 (lambda (xx ...)
916 (set! x xx) ...
917 (let/ec continue-ret
918 (with-sp ((break (break-ret))
919 (continue (continue-ret)))
920 code))
921 (lp)))))
922 (lambda q else)))))
923
924 #'(let ((inv (wrap-in in)) ...)
925 (let ((x #f) ...)
926 (let/ec break-ret
927 (catch StopIteration
928 (lambda ()
929 (let lp ()
930 (call-with-values (lambda () get)
931 (lambda (xx ...)
932 (set! x xx) ...
933 (with-sp ((break (break-ret))
934 (continue (values)))
935 code)
936 (lp)))))
937 (lambda e else))))))))))))
938
939
940 (define-class <scm-list> () l)
941 (define-class <scm-string> () s i)
942 (define-class <yield> () s k)
943
944 (define-method (next (l <scm-list>))
945 (let ((ll (slot-ref l 'l)))
946 (if (pair? ll)
947 (begin
948 (slot-set! l 'l (cdr ll))
949 (car ll))
950 (throw StopIteration))))
951
952 (define-method (next (l <scm-string>))
953 (let ((s (slot-ref l 's))
954 (i (slot-ref l 'i)))
955 (if (= i (string-length s))
956 (throw StopIteration)
957 (begin
958 (slot-set! l 'i (+ i 1))
959 (string-ref s i)))))
960
961 (define-method (next (l <yield>))
962 (let ((k (slot-ref l 'k))
963 (s (slot-ref l 's)))
964 (if k
965 (k)
966 (s))))
967
968 (define-method (wrap-in (x <p>))
969 (aif it (ref x '__iter__ #f)
970 (it)
971 x))
972
973 (define-method (wrap-in x)
974 (cond
975 ((pair? x)
976 (let ((o (make <scm-list>)))
977 (slot-set! o 'l x)
978 o))
979
980 ((string? x)
981 (let ((o (make <scm-string>)))
982 (slot-set! o 's x)
983 (slot-set! o 'i 0)
984 o))
985
986 (else
987 x)))
988
989 (define yield-prompt (list 'yield))
990 (define-syntax def-wrap
991 (lambda (x)
992 (syntax-case x ()
993 ((_ #f f ab x)
994 (pr 'def-wrap #'f 'false)
995 #'x)
996
997 ((_ #t f ab code)
998 (pr 'def-wrap #'f 'true)
999 #'(lambda x
1000 (define obj (make <yield>))
1001 (define ab (make-prompt-tag))
1002 (slot-set! obj 'k #f)
1003 (slot-set! obj 's
1004 (lambda ()
1005 (let/ec return
1006 (call-with-prompt
1007 ab
1008 (lambda ()
1009 (apply code x)
1010 (throw StopIteration))
1011 (letrec ((lam
1012 (lambda (k . l)
1013 (slot-set! obj 'k
1014 (lambda ()
1015 (call-with-prompt
1016 ab
1017 (lambda ()
1018 (k)
1019 (throw StopIteration))
1020 lam)))
1021 (apply values l))))
1022 lam)))))
1023 obj)))))
1024
1025
1026