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