applicable structs used
[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 kind)
365 ,class
366 ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
367 #:const
368 ,(match (exp vs defs)
369 (('begin . l)
370 l)
371 ((('begin . l))
372 l)
373 (l l))
374 #:dynamic
375 ()))))))
376
377 ((#:import ((() nm) . #f))
378 `(use-modules (language python module ,(exp vs nm))))
379
380 (#:break
381 (C 'break))
382
383 (#:continue
384 (C 'continue))
385
386 ((#:for e in code . #f)
387 (=> next)
388 (match e
389 (((#:power #f (#:identifier x . _) () . #f))
390 (match in
391 (((#:test power . _))
392 (match power
393 ((#:power #f
394 (#:identifier "range" . _)
395 ((#:arglist arglist . _))
396 . _)
397 (match arglist
398 ((arg)
399 (let ((v (gensym "v"))
400 (x (string->symbol x))
401 (lp (gensym "lp")))
402 `(let ((,v ,(exp vs arg)))
403 (let ,lp ((,x 0))
404 (if (< ,x ,v)
405 (begin
406 ,(exp vs code)
407 (,lp (+ ,x 1))))))))
408 ((arg1 arg2)
409 (let ((v1 (gensym "va"))
410 (v2 (gensym "vb"))
411 (lp (gensym "lp")))
412 `(let ((,v1 ,(exp vs arg1))
413 (,v2 ,(exp vs arg2)))
414 (let ,lp ((,x ,v1))
415 (if (< ,x ,v2)
416 (begin
417 ,(exp vs code)
418 (,lp (+ ,x 1))))))))
419 ((arg1 arg2 arg3)
420 (let ((v1 (gensym "va"))
421 (v2 (gensym "vb"))
422 (st (gensym "vs"))
423 (lp (gensym "lp")))
424 `(let ((,v1 ,(exp vs arg1))
425 (,st ,(exp vs arg2))
426 (,v2 ,(exp vs arg3)))
427 (if (> st 0)
428 (let ,lp ((,x ,v1))
429 (if (< ,x ,v2)
430 (begin
431 ,(exp vs code)
432 (,lp (+ ,x ,st)))))
433 (if (< st 0)
434 (let ,lp ((,x ,v1))
435 (if (> ,x ,v2)
436 (begin
437 ,(exp vs code)
438 (,lp (+ ,x ,st)))))
439 (error "range with step 0 not allowed"))))))
440 (_ (next))))
441 (_ (next))))
442 (_ (next))))
443 (_ (next))))
444
445 ((#:for es in code . else)
446 (let* ((es2 (map (g vs exp) es))
447 (vs2 (union es2 vs))
448 (code2 (exp vs2 code))
449 (p (is-ec #t code2 #t (list (C 'break) (C 'continue))))
450 (else2 (if else (exp vs2 else) #f))
451 (in2 (map (g vs exp) in)))
452 (list (C 'for) es2 in2 code2 else2 p)))
453
454 ((#:while test code else)
455 (let ((lp (gensym "lp")))
456 `(let ,lp ()
457 (if test
458 (begin
459 ,(exp vs code)
460 (,lp))
461 ,(exp vs else)))))
462
463 ((#:try x (or #f ()) #f . fin)
464 `(dynamic-wind
465 (lambda () #f)
466 (lambda () ,(exp vs x))
467 (lambda ()
468 (if (not ,(C 'inhibit-finally))
469 ,(exp vs fin)))))
470
471 ((#:subexpr . l)
472 (exp vs l))
473
474 ((#:try x exc else . fin)
475 (define (guard x)
476 (if fin
477 `(dynamic-wind
478 (lambda () #f)
479 (lambda () ,x)
480 (lambda ()
481 (if (not ,(C 'inhibit-finally))
482 ,(exp vs fin))))
483 x))
484 (define tag (gensym "tag"))
485 (define o (gensym "o"))
486 (define l (gensym "l"))
487 (guard
488 `(catch #t
489 (lambda () ,(exp vs x))
490 (lambda (,tag ,o . ,l)
491 ,(let lp ((it (if else (exp vs else) `(apply throw 'python
492 ,tag ,o ,l)))
493 (exc exc))
494 (match exc
495 ((((test . #f) code) . exc)
496 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
497 ,(exp vs code)
498 ,it)
499 exc))
500 ((((test . as) code) . exc)
501 (let ((a (exp vs as)))
502 (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l)
503 (let ((,a ,o))
504 (,(O 'set) ,a '__excargs__ ,l)
505 ,(exp vs code))
506 ,it)
507 exc)))
508 (()
509 it)))))))
510
511 ((#:raise #f . #f)
512 `(throw 'python (,(O 'Exception))))
513
514 ((#:raise code . #f)
515 (let ((c (gensym "c")))
516 `(throw 'python
517 (let ((,c ,(exp vs code)))
518 (if (,(O 'pyclass?) ,c)
519 (,c)
520 ,c)))))
521
522 ((#:raise code . from)
523 (let ((o (gensym "o"))
524 (c (gensym "c")))
525 `(throw 'python
526 (let ((,c ,(exp vs code)))
527 (let ((,o (if (,(O 'pyclass?) ,c)
528 (,c)
529 ,c)))
530 (,(O 'set) ,o '__cause__ ,(exp vs from))
531 ,o)))))
532
533
534 ((#:yield args)
535 (let ((f (gensym "f")))
536 `(begin
537 (fluid-set! ,(Y 'in-yield) #t)
538 (let ((,f (scm.yield ,@(gen-yargs vs args))))
539 (,f)))))
540
541
542 ((#:yield f args)
543 (let ((f (gen-yield (exp vs f)))
544 (g (gensym "f")))
545 `(begin
546 (set! ,(C 'inhibit-finally) #t)
547 (let ((,g (,f ,@(gen-yargs vs args))))
548 (,g)))))
549
550 ((#:def f
551 (#:types-args-list
552 args
553 #f #f)
554 #f
555 code)
556 (let* ((c? (fluid-ref is-class?))
557 (f (exp vs f))
558 (y? (is-yield f #f code))
559 (r (gensym "return"))
560 (as (map (lambda (x) (match x
561 ((((#:identifier x . _) . #f) #f)
562 (string->symbol x))))
563 args))
564 (ab (gensym "ab"))
565 (vs (union as vs))
566 (ns (scope code vs))
567 (df (defs code '()))
568 (ex (gensym "ex"))
569 (y 'scm.yield)
570 (y.f (gen-yield f))
571 (ls (diff (diff ns vs) df)))
572
573 (define (mk code)
574 `(let-syntax ((,y (syntax-rules ()
575 ((_ . args)
576 (abort-to-prompt ,ab . args))))
577 (,y.f (syntax-rules ()
578 ((_ . args)
579 (abort-to-prompt ,ab . args)))))
580 ,code))
581
582 (with-fluids ((is-class? #f))
583 (if c?
584 (if y?
585 `(define ,f
586 (,(C 'def-wrap) ,y? ,f ,ab
587 (lambda (,@as)
588 (,(C 'with-return) ,r
589 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
590 ,(with-fluids ((return r))
591 (exp ns code))))))))
592
593 `(define ,f
594 (letrec ((,f
595 (case-lambda
596 ((,ex ,@as)
597 (,f ,@as))
598 ((,@as)
599 (,(C 'with-return) ,r
600 ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
601 ,(with-fluids ((return r))
602 (exp ns code)))))))))
603 ,f)))
604
605 (if y?
606 `(define ,f
607 (,(C 'def-wrap) ,y? ,f ,ab
608 (lambda (,@as)
609 (,(C 'with-return) ,r
610 (let ,(map (lambda (x) (list x #f)) ls)
611 ,(with-fluids ((return r))
612 (mk
613 (exp ns code))))))))
614 `(define ,f
615 (lambda (,@as)
616 (,(C 'with-return) ,r
617 (let ,(map (lambda (x) (list x #f)) ls)
618 ,(with-fluids ((return r))
619 (exp ns code)))))))))))
620
621 ((#:global . _)
622 '(values))
623
624 ((#:lambdef v e)
625 (list `lambda v (exp vs e)))
626
627 ((#:stmt l)
628 (if (> (length l) 1)
629 (cons 'values (map (g vs exp) l))
630 (exp vs (car l))))
631
632
633 ((#:expr-stmt (l) (#:assign))
634 (exp vs l))
635
636 ((#:expr-stmt l type)
637 (=> fail)
638 (call-with-values
639 (lambda () (match type
640 ((#:assign u)
641 (values #f u))
642 ((#:augassign op u)
643 (values op u))
644 (_ (fail))))
645
646 (lambda (op u)
647 (cond
648 ((= (length l) (length u))
649 (if (= (length l) 1)
650 (make-set vs op (car l) (exp vs (car u)))
651 (cons 'begin
652 (map (lambda (l u) (make-set vs op l u))
653 l
654 (map (g vs exp) u)))))
655 ((and (= (length u) 1) (not op))
656 (let ((vars (map (lambda (x) (gensym "v")) l)))
657 `(call-with-values (lambda () (exp vs (car u)))
658 (lambda vars
659 ,@(map (lambda (l v) (make-set vs op l v))
660 l vars)))))))))
661
662
663
664 ((#:return . x)
665 `(,(fluid-ref return) ,@(map (g vs exp) x)))
666
667 ((#:expr-stmt
668 ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
669 (#:assign (l)))
670 (let ((s (string->symbol v)))
671 `(set! ,s ,(exp vs l))))
672
673 ((#:comp x #f)
674 (exp vs x))
675
676 ((#:comp x (op . y))
677 (define (tr op x y)
678 (match op
679 ((or "<" ">" "<=" ">=")
680 (list (G (string->symbol op)) x y))
681 ("!=" (list 'not (list 'equal? x y)))
682 ("==" (list 'equal? x y))
683 ("is" (list 'eq? x y))
684 ("isnot" (list 'not (list 'eq? x y)))
685 ("in" (list 'member x y))
686 ("notin" (list 'not (list 'member x y)))
687 ("<>" (list 'not (list 'equal? x y)))))
688 (tr op (exp vs x) (exp vs y)))
689
690 (x x)))
691
692 (define (comp x)
693 (define start
694 (match (pr 'start x)
695 (((#:stmt
696 ((#:expr-stmt
697 ((#:test
698 (#:power #f
699 (#:identifier "module" . _)
700 ((#:arglist arglist #f #f))
701 . #f) #f))
702 (#:assign)))) . _)
703 (let ()
704 (define args
705 (map (lambda (x)
706 (exp '() x))
707 arglist))
708
709 `((,(G 'define-module)
710 (language python module ,@args)
711 #:use-module (language python module python)))))
712 (x '())))
713
714 (if (pair? start)
715 (set! x (cdr x)))
716
717 (let ((globs (get-globals x)))
718 `(begin
719 ,@start
720 ,(C 'clear-warning-data)
721 (set! (@@ (system base message) %dont-warn-list) '())
722 ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
723 ,@(map (g globs exp) x))))
724
725 (define-syntax-parameter break
726 (lambda (x) #'(values)))
727
728 (define-syntax-parameter continue
729 (lambda (x) (error "continue must be bound")))
730
731 (define (is-yield f p x)
732 (match x
733 ((#:def nm args _ code)
734 (is-yield f #t code))
735 ((#:yield x _)
736 (eq? f (exp '() x)))
737 ((#:yield _)
738 (not p))
739 ((a . l)
740 (or
741 (is-yield f p a)
742 (is-yield f p l)))
743 (_
744 #f)))
745
746
747
748 (define-syntax-rule (with-sp ((x v) ...) code ...)
749 (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
750
751 (define (is-ec ret x tail tags)
752 (syntax-case (pr 'is-ec x) (begin let if define @@)
753 ((begin a ... b)
754 #t
755 (or
756 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
757 (is-ec ret #'b tail tags)))
758
759 ((let lp ((y x) ...) a ... b)
760 (symbol? (syntax->datum #'lp))
761 (or
762 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
763 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
764 (is-ec ret #'b tail tags)))
765
766 ((let ((y x) ...) a ... b)
767 #t
768 (or
769 (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
770 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
771 (is-ec ret #'b tail tags)))
772
773 ((if p a b)
774 #t
775 (or
776 (is-ec ret #'p #f tags)
777 (is-ec ret #'a tail tags)
778 (is-ec ret #'b tail tags)))
779
780 ((define . _)
781 #t
782 #f)
783
784 ((if p a)
785 #t
786 (or
787 (is-ec ret #'p #f tags)
788 (is-ec ret #'a tail tags)))
789
790 ((@@ _ _)
791 #t
792 (if (member (pr (syntax->datum x)) tags)
793 #t
794 #f))
795
796 ((a ...)
797 #t
798 (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
799
800 (x
801 #t
802 #f)))
803
804 (define-syntax with-return
805 (lambda (x)
806 (define (analyze ret x)
807 (syntax-case x (begin let if)
808 ((begin a ... b)
809 #`(begin a ... #,(analyze ret #'b)))
810 ((let lp v a ... b)
811 (symbol? (syntax->datum #'lp))
812 #`(let lp v a ... #,(analyze ret #'b)))
813 ((let v a ... b)
814 #`(let v a ... #,(analyze ret #'b)))
815 ((if p a b)
816 #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
817 ((if p a)
818 #`(if p #,(analyze ret #'a)))
819 ((return a b ...)
820 (equal? (syntax->datum #'return) (syntax->datum ret))
821 (if (eq? #'(b ...) '())
822 #'a
823 #`(values a b ...)))
824 (x #'x)))
825
826 (define (is-ec ret x tail)
827 (syntax-case x (begin let if define @@)
828 ((begin a ... b)
829 #t
830 (or
831 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
832 (is-ec ret #'b tail)))
833
834 ((let lp ((y x) ...) a ... b)
835 (symbol? (syntax->datum #'lp))
836 (or
837 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
838 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
839 (is-ec ret #'b tail)))
840
841 ((let ((y x) ...) a ... b)
842 #t
843 (or
844 (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
845 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
846 (is-ec ret #'b tail)))
847
848 ((define . _)
849 #t
850 #f)
851
852 ((if p a b)
853 #t
854 (or
855 (is-ec ret #'p #f)
856 (is-ec ret #'a tail)
857 (is-ec ret #'b tail)))
858
859 ((if p a)
860 #t
861 (or
862 (is-ec ret #'p #f)
863 (is-ec ret #'a tail)))
864
865 ((return a b ...)
866 (equal? (syntax->datum #'return) (syntax->datum ret))
867 (not tail))
868
869 ((a ...)
870 #t
871 (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
872
873 (x
874 #t
875 #f)))
876
877 (syntax-case x ()
878 ((_ ret l)
879 (let ((code (analyze #'ret #'l)))
880 (if (is-ec #'ret #'l #t)
881 #`(let/ec ret #,code)
882 code))))))
883
884 (define-syntax var
885 (lambda (x)
886 (syntax-case x ()
887 ((_ v)
888 (begin
889 (dont-warn (syntax->datum #'v))
890 #'(if (module-defined? (current-module) 'v)
891 (values)
892 (define! 'v #f)))))))
893
894 (define-inlinable (non? x) (eq? x #:nil))
895
896 (define-syntax for
897 (syntax-rules ()
898 ((_ (x) (a) code #f #f)
899 (if (pair? a)
900 (let lp ((l a))
901 (if (pair? l)
902 (let ((x (car l)))
903 (with-sp ((continue (lp (cdr l)))
904 (break (values)))
905 code
906 (lp (cdr l))))))
907 (for/adv1 (x) (a) code #f #f)))
908
909 ((_ (x) (a) code #f #t)
910 (if (pair? a)
911 (let/ec break-ret
912 (let lp ((l a))
913 (if (pair? l)
914 (begin
915 (let/ec continue-ret
916 (let ((x (car l)))
917 (with-sp ((continue (continue-ret))
918 (break (break-ret)))
919 code)))
920 (lp (cdr l))))))
921 (for/adv1 (x) (a) code #f #t)))
922
923 ((_ (x) (a) code next #f)
924 (if (pair? a)
925 (let/ec break-ret
926 (let ((x (let lp ((l a) (old #f))
927 (if (pair? l)
928 (let ((x (car l)))
929 (let/ec continue-ret
930 (with-sp ((continue (continue-ret))
931 (break (break-ret)))
932 code))
933 (lp (cdr l)))
934 old))))
935 next))
936 (for/adv1 (x) (a) code next #f)))
937
938 ((_ x a code next p)
939 (for/adv1 x a code next p))))
940
941 (define-syntax for/adv1
942 (lambda (x)
943 (syntax-case x ()
944 ((_ (x ...) (in ...) code #f #f)
945 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
946 #'(let ((inv (wrap-in in)) ...)
947 (catch StopIteration
948 (lambda ()
949 (let lp ()
950 (call-with-values (lambda () (values (next inv) ...))
951 (lambda (x ...)
952 (with-sp ((break (values))
953 (continue (values)))
954 code
955 (lp))))))
956 (lambda z (values))))))
957
958 ((_ (x ...) (in ...) code #f #t)
959 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
960 #'(let ((inv (wrap-in in)) ...)
961 (let lp ()
962 (let/ec break-ret
963 (catch StopIteration
964 (lambda ()
965 (call-with-values (lambda () (values (next inv) ...))
966 (lambda (x ...)
967 (let/ec continue-ret
968 (with-sp ((break (break-ret))
969 (continue (continue-ret)))
970 code))
971 (lp))))
972 (lambda z (values))))))))
973
974 ((_ (x ...) in code else #f)
975 #'(for-adv (x ...) in code else #f))
976
977 ((_ (x ...) in code else #t)
978 #'(for-adv (x ...) in code else #t)))))
979
980
981 (define-syntax for-adv
982 (lambda (x)
983 (define (gen x y)
984 (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
985 (syntax-case x ()
986 ((x ...) #'(values (next x) ...)))
987 (syntax-case x ()
988 ((x) #'(next x)))))
989
990 (syntax-case x ()
991 ((_ (x ...) (in ...) code else p)
992 (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
993 (with-syntax ((get (gen #'(inv ...) #'(x ...)))
994 ((xx ...) (generate-temporaries #'(x ...))))
995 (if (syntax->datum #'p)
996 #'(let ((inv (wrap-in in)) ...)
997 (let/ec break-ret
998 (let ((x #f) ...)
999 (catch StopIteration
1000 (lambda ()
1001 (let lp ()
1002 (call-with-values (lambda () get)
1003 (lambda (xx ...)
1004 (set! x xx) ...
1005 (let/ec continue-ret
1006 (with-sp ((break (break-ret))
1007 (continue (continue-ret)))
1008 code))
1009 (lp)))))
1010 (lambda q else)))))
1011
1012 #'(let ((inv (wrap-in in)) ...)
1013 (let ((x #f) ...)
1014 (let/ec break-ret
1015 (catch StopIteration
1016 (lambda ()
1017 (let lp ()
1018 (call-with-values (lambda () get)
1019 (lambda (xx ...)
1020 (set! x xx) ...
1021 (with-sp ((break (break-ret))
1022 (continue (values)))
1023 code)
1024 (lp)))))
1025 (lambda e else))))))))))))
1026
1027 (define-syntax def-wrap
1028 (lambda (x)
1029 (syntax-case x ()
1030 ((_ #f f ab x)
1031 (pr 'def-wrap #'f 'false)
1032 #'x)
1033
1034 ((_ #t f ab code)
1035 (pr 'def-wrap #'f 'true)
1036 #'(lambda x
1037 (define obj (make <yield>))
1038 (define ab (make-prompt-tag))
1039 (slot-set! obj 'k #f)
1040 (slot-set! obj 'closed #f)
1041 (slot-set! obj 's
1042 (lambda ()
1043 (call-with-prompt
1044 ab
1045 (lambda ()
1046 (let/ec return
1047 (apply code x))
1048 (slot-set! obj 'closed #t)
1049 (throw StopIteration))
1050 (letrec ((lam
1051 (lambda (k . l)
1052 (fluid-set! in-yield #f)
1053 (slot-set! obj 'k
1054 (lambda (a)
1055 (call-with-prompt
1056 ab
1057 (lambda ()
1058 (k a))
1059 lam)))
1060 (apply values l))))
1061 lam))))
1062 obj)))))
1063
1064 (define-syntax ref-x
1065 (syntax-rules ()
1066 ((_ v)
1067 v)
1068 ((_ v x . l)
1069 (ref-x (ref v 'x) . l))))
1070