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