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