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