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