c11bd762bec07ca065f75265e86530bd52ac241f
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
(ice-9 pretty-print
)
9 (define-syntax-rule (aif it p x y
) (let ((it p
)) (if it x y
)))
11 (define-syntax clear-warning-data
14 (set! (@@ (system base message
) %dont-warn-list
) '())
17 (define-syntax dont-warn
23 (set! (@@ (system base message
) %dont-warn-list
)
24 (cons (syntax->datum
#'d
)
25 (@@ (system base message
) %dont-warn-list
)))
30 ((_ (f) . l
) (f . l
))))
32 (define (fold f init l
)
34 (fold f
(f (car l
) init
) (cdr l
))
38 (define port
(open-file "/home/stis/src/python-on-guile/log.txt" "a"))
39 (with-output-to-port port
41 (pretty-print (syntax->datum 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
))
52 (define (C x
) `(@@ (language python compile
) ,x
))
53 (define (O x
) `(@@ (oop pf-objects
) ,x
))
54 (define (G x
) `(@ (guile) ,x
))
57 (let lp
((as as
) (vs vs
))
67 (let lp
((as as
) (rs '()))
76 (define (get-globals code
)
77 (let lp
((vs (glob code
'())) (rs (scope code
'())))
89 (let lp
((l l
) (vs vs
))
91 (((#:identifier v . _
) . l
)
92 (let ((s (string->symbol v
)))
104 ((#:def
(#:identifier f . _
) . _
)
105 (union (list (string->symbol f
)) vs
))
112 ((#:identifier v . _
)
113 (let ((s (string->symbol v
)))
118 (scope y
(scope x vs
)))
123 ((#:def
(#:identifier f . _
) . _
)
124 (union (list (string->symbol f
)) vs
))
132 (defs y
(defs x vs
)))
135 (define (gen-yield f
)
142 (lambda (x) (e vs x
)))
144 (define return
(make-fluid 'error-return
))
146 (define (make-set vs x u
)
148 ((#:test
(#:power kind
(#:identifier v . _
) addings . _
) . _
)
150 (let ((v (string->symbol v
)))
153 (let ((addings (map (lambda (x) `',(exp vs x
)) addings
)))
154 `(set! ,(exp vs kind
)
155 (,(O 'fset-x
) ,v
(list ,@addings
) ,u
)))))
157 (let ((v (string->symbol v
)))
160 (let* ((rev (reverse addings
))
162 (new (reverse (cdr rev
))))
163 `(,(O 'set
) ,(let lp
((v v
) (new new
))
166 (lp `(,(O 'ref
) ,v
,(exp vs x
)) ',new
))
168 ',(exp vs las
) ,u
))))))))
170 (define is-class?
(make-fluid #f
))
171 (define (gen-yargs vs x
)
172 (match (pr 'yarg x
) ((#:list args
)
173 (map (g vs exp
) args
))))
177 ((#:power _
(x) () .
#f
)
179 ((#:power _ x
() .
#f
)
183 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
184 ((#:power
#f vf trailer .
#f
)
185 (let lp
((e (exp vs vf
)) (trailer trailer
))
194 (lp `(,(O 'ref
) ,e
',(exp vs x
) #f
) trailer
))
196 ((#:arglist args
#f
#f
)
197 (lp `(,e
,@(map (g vs exp
) args
)) trailer
))
198 (_ (error "unhandled trailer")))))))
200 ((#:identifier x . _
)
206 (((and x
(or #:+ #:-
#:* #:/)) . l
)
207 (cons (keyword->symbol x
) (map (g vs exp
) l
)))
210 (list 'lognot
(exp vs x
)))
213 (cons 'logand
(map (g vs exp
) l
)))
216 (cons 'logxor
(map (g vs exp
) l
)))
219 (cons 'logior
(map (g vs exp
) l
)))
222 (list 'not
(exp vs x
)))
225 (cons 'or
(map (g vs exp
) x
)))
228 (cons 'and
(map (g vs exp
) x
)))
234 (list 'if
(exp vs e2
) (exp vs e1
) (exp vs e3
)))
236 ((#:if test a
((tests . as
) ...
) . else
)
238 (,(exp vs test
) ,(exp vs a
))
239 ,@(map (lambda (p a
) (list (exp vs p
) (exp vs a
))) tests as
)
240 ,@(if else
`((else ,(exp vs else
))) '())))
242 ((#:suite . l
) (cons 'begin
(map (g vs exp
) l
)))
247 (lambda () ,(exp vs x
))
248 (lambda () ,(exp vs fin
))))
250 ((#:while test code
#f
)
251 (let ((lp (gensym "lp")))
258 ((#:classdef
(#:identifier class . _
) parents defs
)
259 (with-fluids ((is-class?
#t
))
265 ((or 'fast
'functional
) s
)
268 (define (is-functional l
)
269 (fold (lambda (x pred
)
277 (fold (lambda (x pred
)
286 (let* ((class (string->symbol class
))
287 (parents (match parents
290 ((#:arglist args . _
)
291 (map (g vs exp
) args
))))
292 (is-func (is-functional parents
))
293 (is-fast (is-fast parents
))
301 (parents (filt parents
)))
302 `(define ,class
(,(O 'wrap
)
305 ,(map (lambda (x) `(,(O 'get-class
) ,x
)) parents
)
307 ,(match (exp vs defs
)
323 ((#:for e in code .
#f
)
326 (((#:power
#f
(#:identifier x . _
) () .
#f
))
328 (((#:test power . _
))
331 (#:identifier
"range" . _
)
332 ((#:arglist arglist . _
))
336 (let ((v (gensym "v"))
337 (x (string->symbol x
))
339 `(let ((,v
,(exp vs arg
)))
346 (let ((v1 (gensym "va"))
349 `(let ((,v1
,(exp vs arg1
))
350 (,v2
,(exp vs arg2
)))
357 (let ((v1 (gensym "va"))
361 `(let ((,v1
,(exp vs arg1
))
363 (,v2
,(exp vs arg3
)))
376 (error "range with step 0 not allowed"))))))
382 ((#:for es in code . else
)
383 (let* ((es2 (map (g vs exp
) es
))
385 (code2 (exp vs2 code
))
386 (p (is-ec #t code2
#t
(list (C 'break
) (C 'continue
))))
387 (else2 (if else
(exp vs2 else
) #f
))
388 (in2 (map (g vs exp
) in
)))
389 (list (C 'for
) es2 in2 code2 else2 p
)))
391 ((#:while test code else
)
392 (let ((lp (gensym "lp")))
400 ((#:try x exc else fin
)
406 (lambda ,(gensym "x") ,(exp vs x
))))))
412 (let lp
((code (exp vs x
)) (l (reverse exc
)))
415 (lp `(catch ,(exp vs e
)
417 (lambda ,(gensym "x")
420 (lp `(let ((,as
,(exp vs e
)))
423 (lambda ,(gensym "x")
427 (lambda () ,(exp vs fin
)))))
430 `(scm-yield ,@(gen-yargs vs args
)))
434 (let ((f (gen-yield (exp vs f
))))
435 `(,f
,@(gen-yargs vs args
))))
443 (let* ((c?
(fluid-ref is-class?
))
445 (y?
(is-yield f
#f code
))
446 (r (gensym "return"))
447 (as (map (lambda (x) (match x
448 ((((#:identifier x . _
) .
#f
) #f
)
449 (string->symbol x
))))
458 (ls (diff (diff ns vs
) df
)))
461 `(let-syntax ((,y
(syntax-rules ()
463 (abort-to-prompt ,ab . args
))))
464 (,y.f
(syntax-rules ()
466 (abort-to-prompt ,ab . args
)))))
469 (with-fluids ((is-class?
#f
))
472 (,(C 'def-wrap
) ,y?
,f
,ab
478 (,(C 'with-return
) ,r
479 ,(mk `(let ,(map (lambda (x) (list x
#f
)) ls
)
480 ,(with-fluids ((return r
))
481 (exp ns code
)))))))))
485 (,(C 'def-wrap
) ,y?
,f
,ab
487 (,(C 'with-return
) ,r
488 (let ,(map (lambda (x) (list x
#f
)) ls
)
489 ,(with-fluids ((return r
))
491 (exp ns code
))))))))))))
497 (list `lambda v
(exp vs e
)))
501 (cons 'values
(map (g vs exp
) l
))
505 ((#:expr-stmt
(l) (#:assign
))
508 ((#:expr-stmt l
(#:assign u
))
510 ((= (length l
) (length u
))
512 (make-set vs
(car l
) (exp vs
(car u
)))
515 (map (lambda x vs
) l
)
517 (map (g vs exp
) u
)))))
519 (let ((vars (map (lambda (x) (gensym "v")) l
)))
520 `(call-with-values (lambda () (exp vs
(car u
)))
522 ,@(map make-set l vars
)))))))
527 `(,(fluid-ref return
) ,@(map (g vs exp
) x
)))
530 ((#:test
(#:power
#f
(#:identifier v . _
) () .
#f
) #f
))
532 (let ((s (string->symbol v
)))
533 `(set! ,s
,(exp vs l
))))
541 ((or "<" ">" "<=" ">=")
542 (list (G (string->symbol op
)) x y
))
543 ("!=" (list 'not
(list 'equal? x y
)))
544 ("==" (list 'equal? x y
))
545 ("is" (list 'eq? x y
))
546 ("isnot" (list 'not
(list 'eq? x y
)))
547 ("in" (list 'member x y
))
548 ("notin" (list 'not
(list 'member x y
)))
549 ("<>" (list 'not
(list 'equal? x y
)))))
550 (tr op
(exp vs x
) (exp vs y
)))
561 (#:identifier
"module" . _
)
562 ((#:arglist arglist
#f
#f
))
571 `((,(G 'define-module
)
572 (language python module
,@args
)))))
578 (let ((globs (get-globals x
)))
581 ,(C 'clear-warning-data
)
582 (set! (@@ (system base message
) %dont-warn-list
) '())
583 ,@(map (lambda (s) `(,(C 'var
) ,s
)) globs
)
584 ,@(map (g globs exp
) x
))))
586 (define-syntax-parameter break
587 (lambda (x) #'(values)))
589 (define-syntax-parameter continue
590 (lambda (x) (error "continue must be bound")))
592 (define (is-yield f p x
)
594 ((#:def nm args _ code
)
595 (is-yield f
#t code
))
609 (define-syntax-rule (with-sp ((x v
) ...
) code ...
)
610 (syntax-parameterize ((x (lambda (y) #'v
)) ...
) code ...
))
612 (define (is-ec ret x tail tags
)
613 (syntax-case (pr 'is-ec x
) (begin let if define
@@)
617 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
618 (is-ec ret
#'b tail tags
)))
620 ((let lp
((y x
) ...
) a ... b
)
621 (symbol?
(syntax->datum
#'lp
))
623 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
624 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
625 (is-ec ret
#'b tail tags
)))
627 ((let ((y x
) ...
) a ... b
)
630 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
631 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
632 (is-ec ret
#'b tail tags
)))
637 (is-ec ret
#'p
#f tags
)
638 (is-ec ret
#'a tail tags
)
639 (is-ec ret
#'b tail tags
)))
648 (is-ec ret
#'p
#f tags
)
649 (is-ec ret
#'a tail tags
)))
653 (if (member (pr (syntax->datum x
)) tags
)
659 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
)))
665 (define-syntax with-return
667 (define (analyze ret x
)
668 (syntax-case x
(begin let if
)
670 #`(begin a ...
#,(analyze ret
#'b
)))
672 (symbol?
(syntax->datum
#'lp
))
673 #`(let lp v a ...
#,(analyze ret
#'b
)))
675 #`(let v a ...
#,(analyze ret
#'b
)))
677 #`(if p
#,(analyze ret
#'a
) #,(analyze ret
#'b
)))
679 #`(if p
#,(analyze ret
#'a
)))
681 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
682 (if (eq?
#'(b ...
) '())
687 (define (is-ec ret x tail
)
688 (syntax-case x
(begin let if define
@@)
692 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
693 (is-ec ret
#'b tail
)))
695 ((let lp
((y x
) ...
) a ... b
)
696 (symbol?
(syntax->datum
#'lp
))
698 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
699 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
700 (is-ec ret
#'b tail
)))
702 ((let ((y x
) ...
) a ... b
)
705 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
706 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
707 (is-ec ret
#'b tail
)))
718 (is-ec ret
#'b tail
)))
724 (is-ec ret
#'a tail
)))
727 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
732 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
)))
740 (let ((code (analyze #'ret
#'l
)))
741 (if (is-ec #'ret
#'l
#t
)
742 #`(let/ec ret
#,code
)
745 (define-syntax-rule (var v
)
752 (define-inlinable (non? x
) (eq? x
#:nil
))
756 ((_ (x) (a) code
#f
#f
)
761 (with-sp ((continue (lp (cdr l
)))
765 (for/adv1
(x) (a) code
#f
#f
)))
767 ((_ (x) (a) code
#f
#t
)
775 (with-sp ((continue (continue-ret))
779 (for/adv1
(x) (a) code
#f
#t
)))
781 ((_ (x) (a) code next
#f
)
784 (let ((x (let lp
((l a
) (old #f
))
788 (with-sp ((continue (continue-ret))
794 (for/adv1
(x) (a) code next
#f
)))
797 (for/adv1 x a code next p
))))
799 (define-syntax for
/adv1
802 ((_ (x ...
) (in ...
) code
#f
#f
)
803 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
804 #'(let ((inv (wrap-in in
)) ...
)
808 (call-with-values (lambda () (values (next inv
) ...
))
810 (with-sp ((break (values))
814 (lambda z
(values))))))
816 ((_ (x ...
) (in ...
) code
#f
#t
)
817 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
818 #'(let ((inv (wrap-in in
)) ...
)
823 (call-with-values (lambda () (values (next inv
) ...
))
826 (with-sp ((break (break-ret))
827 (continue (continue-ret)))
830 (lambda z
(values))))))))
832 ((_ (x ...
) in code else
#f
)
833 #'(for-adv (x ...
) in code else
#f
))
835 ((_ (x ...
) in code else
#t
)
836 #'(for-adv (x ...
) in code else
#t
)))))
839 (define-syntax for-adv
842 (if (= (length (syntax->datum x
)) (= (length (syntax->datum y
))))
844 ((x ...
) #'(values (next x
) ...
)))
849 ((_ (x ...
) (in ...
) code else p
)
850 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
851 (with-syntax ((get (gen #'(inv ...
) #'(x ...
)))
852 ((xx ...
) (generate-temporaries #'(x ...
))))
853 (if (syntax->datum
#'p
)
854 #'(let ((inv (wrap-in in
)) ...
)
860 (call-with-values (lambda () get
)
864 (with-sp ((break (break-ret))
865 (continue (continue-ret)))
870 #'(let ((inv (wrap-in in
)) ...
)
876 (call-with-values (lambda () get
)
879 (with-sp ((break (break-ret))
883 (lambda e else
))))))))))))
886 (define-class <scm-list
> () l
)
887 (define-class <scm-string
> () s i
)
888 (define-class <yield
> () s k
)
890 (define-method (next (l <scm-list
>))
891 (let ((ll (slot-ref l
'l
)))
894 (slot-set! l
'l
(cdr ll
))
896 (throw StopIteration
))))
898 (define-method (next (l <scm-string
>))
899 (let ((s (slot-ref l
's
))
901 (if (= i
(string-length s
))
902 (throw StopIteration
)
904 (slot-set! l
'i
(+ i
1))
907 (define-method (next (l <yield
>))
908 (let ((k (slot-ref l
'k
))
914 (define-method (wrap-in (x <p
>))
915 (aif it
(ref x
'__iter__
#f
)
919 (define-method (wrap-in x
)
922 (let ((o (make <scm-list
>)))
927 (let ((o (make <scm-string
>)))
935 (define yield-prompt
(list 'yield
))
936 (define-syntax def-wrap
940 (pr 'def-wrap
#'f
'false
)
944 (pr 'def-wrap
#'f
'true
)
946 (define obj
(make <yield
>))
947 (define ab
(make-prompt-tag))
948 (slot-set! obj
'k
#f
)
956 (throw StopIteration
))
965 (throw StopIteration
))