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