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
) '())
18 (set! (@@ (system base message
) %dont-warn-list
)
20 (@@ (system base message
) %dont-warn-list
))))
24 ((_ (f) . l
) (f . l
))))
26 (define (fold f init l
)
28 (fold f
(f (car l
) init
) (cdr l
))
32 (define port
(open-file "/home/stis/src/python-on-guile/log.txt" "a"))
33 (with-output-to-port port
35 (pretty-print (syntax->datum x
))))
40 (define port
(open-file "/home/stis/src/python-on-guile/compile.log" "a"))
41 (with-output-to-port port
42 (lambda () (pretty-print (syntax->datum x
)) x
))
46 (define (C x
) `(@@ (language python compile
) ,x
))
47 (define (O x
) `(@@ (oop pf-objects
) ,x
))
48 (define (G x
) `(@ (guile) ,x
))
51 (let lp
((as as
) (vs vs
))
61 (let lp
((as as
) (rs '()))
70 (define (get-globals code
)
71 (let lp
((vs (glob code
'())) (rs (scope code
'())))
83 (let lp
((l l
) (vs vs
))
85 (((#:identifier v . _
) . l
)
86 (let ((s (string->symbol v
)))
99 (union (list (exp '() f
)) vs
))
105 (union (list (exp '() f
)) vs
))
110 ((#:expr-stmt l
(#:assign u
))
111 (union (fold (lambda (x s
)
113 ((#:test
(#:power v2 v1
() . _
) . _
)
116 (union (list (exp '() v1
))
119 (union (list (exp '() v1
)) s
)))
126 (scope y
(scope x vs
)))
131 ((#:def
(#:identifier f . _
) . _
)
132 (union (list (string->symbol f
)) vs
))
140 (defs y
(defs x vs
)))
143 (define (gen-yield f
)
150 (lambda (x) (e vs x
)))
152 (define return
(make-fluid 'error-return
))
154 (define (make-set vs x u
)
156 ((#:test
(#:power kind
(#:identifier v . _
) addings . _
) . _
)
158 (let ((v (string->symbol v
)))
161 (let ((addings (map (lambda (x) `',(exp vs x
)) addings
)))
162 `(set! ,(exp vs kind
)
163 (,(O 'fset-x
) ,v
(list ,@addings
) ,u
)))))
165 (let ((v (string->symbol v
)))
168 (let* ((rev (reverse addings
))
170 (new (reverse (cdr rev
))))
171 `(,(O 'set
) ,(let lp
((v v
) (new new
))
174 (lp `(,(O 'ref
) ,v
,(exp vs x
)) ',new
))
176 ',(exp vs las
) ,u
))))))))
178 (define is-class?
(make-fluid #f
))
179 (define (gen-yargs vs x
)
180 (match (pr 'yarg x
) ((#:list args
)
181 (map (g vs exp
) args
))))
185 ((#:power _
(x) () .
#f
)
187 ((#:power _ x
() .
#f
)
191 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
192 ((#:power
#f vf trailer .
#f
)
193 (let lp
((e (exp vs vf
)) (trailer trailer
))
202 (lp `(,(O 'ref
) ,e
',(exp vs x
) #f
) trailer
))
204 ((#:arglist args
#f
#f
)
205 (lp `(,e
,@(map (g vs exp
) args
)) trailer
))
206 (_ (error "unhandled trailer")))))))
208 ((#:identifier x . _
)
214 (((and x
(or #:+ #:-
#:* #:/)) . l
)
215 (cons (keyword->symbol x
) (map (g vs exp
) l
)))
218 (list 'lognot
(exp vs x
)))
221 (cons 'logand
(map (g vs exp
) l
)))
224 (cons 'logxor
(map (g vs exp
) l
)))
227 (cons 'logior
(map (g vs exp
) l
)))
230 (list 'not
(exp vs x
)))
233 (cons 'or
(map (g vs exp
) x
)))
236 (cons 'and
(map (g vs exp
) x
)))
242 (list 'if
(exp vs e2
) (exp vs e1
) (exp vs e3
)))
244 ((#:if test a
((tests . as
) ...
) . else
)
246 (,(exp vs test
) ,(exp vs a
))
247 ,@(map (lambda (p a
) (list (exp vs p
) (exp vs a
))) tests as
)
248 ,@(if else
`((else ,(exp vs else
))) '())))
250 ((#:suite . l
) (cons 'begin
(map (g vs exp
) l
)))
252 ((#:while test code
#f
)
253 (let ((lp (gensym "lp")))
260 ((#:classdef
(#:identifier class . _
) parents defs
)
261 (with-fluids ((is-class?
#t
))
267 ((or 'fast
'functional
) s
)
270 (define (is-functional l
)
271 (fold (lambda (x pred
)
279 (fold (lambda (x pred
)
288 (let* ((class (string->symbol class
))
289 (parents (match parents
292 ((#:arglist args . _
)
293 (map (g vs exp
) args
))))
294 (is-func (is-functional parents
))
295 (is-fast (is-fast parents
))
303 (parents (filt parents
)))
304 `(define ,class
(,(O 'wrap
)
307 ,(map (lambda (x) `(,(O 'get-class
) ,x
)) parents
)
309 ,(match (exp vs defs
)
318 ((#:import
((() nm
) .
#f
))
319 `(use-modules (language python module
,(exp vs nm
))))
327 ((#:for e in code .
#f
)
330 (((#:power
#f
(#:identifier x . _
) () .
#f
))
332 (((#:test power . _
))
335 (#:identifier
"range" . _
)
336 ((#:arglist arglist . _
))
340 (let ((v (gensym "v"))
341 (x (string->symbol x
))
343 `(let ((,v
,(exp vs arg
)))
350 (let ((v1 (gensym "va"))
353 `(let ((,v1
,(exp vs arg1
))
354 (,v2
,(exp vs arg2
)))
361 (let ((v1 (gensym "va"))
365 `(let ((,v1
,(exp vs arg1
))
367 (,v2
,(exp vs arg3
)))
380 (error "range with step 0 not allowed"))))))
386 ((#:for es in code . else
)
387 (let* ((es2 (map (g vs exp
) es
))
389 (code2 (exp vs2 code
))
390 (p (is-ec #t code2
#t
(list (C 'break
) (C 'continue
))))
391 (else2 (if else
(exp vs2 else
) #f
))
392 (in2 (map (g vs exp
) in
)))
393 (list (C 'for
) es2 in2 code2 else2 p
)))
395 ((#:while test code else
)
396 (let ((lp (gensym "lp")))
404 ((#:try x
(or #f
()) #f . fin
)
407 (lambda () ,(exp vs x
))
408 (lambda () ,(exp vs fin
))))
410 ((#:try x exc else . fin
)
416 (lambda () ,(exp vs fin
)))
418 (define tag
(gensym "tag"))
419 (define o
(gensym "o"))
420 (define l
(gensym "l"))
423 (lambda () ,(exp vs x
))
424 (lambda (,tag
,o .
,l
)
425 ,(let lp
((it (if else
(exp vs else
) `(apply throw
,tag
,l
)))
428 ((((test .
#f
) code
) . exc
)
429 (lp `(if (,(O 'testex
) ,tag
,o
,(exp vs test
) ,l
)
433 ((((test . as
) code
) . exc
)
434 (let ((a (exp vs as
)))
435 (lp `(if (,(O 'testex
) ,o
,tag
,(exp vs test
) ,l
)
437 (,(O 'set
) ,a
'__excargs__
,l
)
445 `(throw 'python
(,(O 'Exception
))))
448 (let ((c (gensym "c")))
450 (let ((,c
,(exp vs code
)))
451 (if (,(O 'pyclass?
) ,c
)
455 ((#:raise code . from
)
456 (let ((o (gensym "o"))
459 (let ((,c
,(exp vs code
)))
460 (let ((,o
(if (,(O 'pyclass?
) ,c
)
463 (,(O 'set
) ,o
'__cause__
,(exp vs from
))
468 `(scm-yield ,@(gen-yargs vs args
)))
472 (let ((f (gen-yield (exp vs f
))))
473 `(,f
,@(gen-yargs vs args
))))
481 (let* ((c?
(fluid-ref is-class?
))
483 (y?
(is-yield f
#f code
))
484 (r (gensym "return"))
485 (as (map (lambda (x) (match x
486 ((((#:identifier x . _
) .
#f
) #f
)
487 (string->symbol x
))))
496 (ls (diff (diff ns vs
) df
)))
499 `(let-syntax ((,y
(syntax-rules ()
501 (abort-to-prompt ,ab . args
))))
502 (,y.f
(syntax-rules ()
504 (abort-to-prompt ,ab . args
)))))
507 (with-fluids ((is-class?
#f
))
511 (,(C 'def-wrap
) ,y?
,f
,ab
513 (,(C 'with-return
) ,r
514 ,(mk `(let ,(map (lambda (x) (list x
#f
)) ls
)
515 ,(with-fluids ((return r
))
524 (,(C 'with-return
) ,r
525 ,(mk `(let ,(map (lambda (x) (list x
#f
)) ls
)
526 ,(with-fluids ((return r
))
527 (exp ns code
)))))))))
532 (,(C 'def-wrap
) ,y?
,f
,ab
534 (,(C 'with-return
) ,r
535 (let ,(map (lambda (x) (list x
#f
)) ls
)
536 ,(with-fluids ((return r
))
541 (,(C 'with-return
) ,r
542 (let ,(map (lambda (x) (list x
#f
)) ls
)
543 ,(with-fluids ((return r
))
544 (exp ns code
)))))))))))
550 (list `lambda v
(exp vs e
)))
554 (cons 'values
(map (g vs exp
) l
))
558 ((#:expr-stmt
(l) (#:assign
))
561 ((#:expr-stmt l
(#:assign u
))
563 ((= (length l
) (length u
))
565 (make-set vs
(car l
) (exp vs
(car u
)))
568 (map (lambda x vs
) l
)
570 (map (g vs exp
) u
)))))
572 (let ((vars (map (lambda (x) (gensym "v")) l
)))
573 `(call-with-values (lambda () (exp vs
(car u
)))
575 ,@(map make-set l vars
)))))))
580 `(,(fluid-ref return
) ,@(map (g vs exp
) x
)))
583 ((#:test
(#:power
#f
(#:identifier v . _
) () .
#f
) #f
))
585 (let ((s (string->symbol v
)))
586 `(set! ,s
,(exp vs l
))))
594 ((or "<" ">" "<=" ">=")
595 (list (G (string->symbol op
)) x y
))
596 ("!=" (list 'not
(list 'equal? x y
)))
597 ("==" (list 'equal? x y
))
598 ("is" (list 'eq? x y
))
599 ("isnot" (list 'not
(list 'eq? x y
)))
600 ("in" (list 'member x y
))
601 ("notin" (list 'not
(list 'member x y
)))
602 ("<>" (list 'not
(list 'equal? x y
)))))
603 (tr op
(exp vs x
) (exp vs y
)))
614 (#:identifier
"module" . _
)
615 ((#:arglist arglist
#f
#f
))
624 `((,(G 'define-module
)
625 (language python module
,@args
)
626 #:use-module
(language python module python
)))))
632 (let ((globs (get-globals x
)))
635 ,(C 'clear-warning-data
)
636 (set! (@@ (system base message
) %dont-warn-list
) '())
637 ,@(map (lambda (s) `(,(C 'var
) ',s
)) globs
)
638 ,@(map (g globs exp
) x
))))
640 (define-syntax-parameter break
641 (lambda (x) #'(values)))
643 (define-syntax-parameter continue
644 (lambda (x) (error "continue must be bound")))
646 (define (is-yield f p x
)
648 ((#:def nm args _ code
)
649 (is-yield f
#t code
))
663 (define-syntax-rule (with-sp ((x v
) ...
) code ...
)
664 (syntax-parameterize ((x (lambda (y) #'v
)) ...
) code ...
))
666 (define (is-ec ret x tail tags
)
667 (syntax-case (pr 'is-ec x
) (begin let if define
@@)
671 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
672 (is-ec ret
#'b tail tags
)))
674 ((let lp
((y x
) ...
) a ... b
)
675 (symbol?
(syntax->datum
#'lp
))
677 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
678 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
679 (is-ec ret
#'b tail tags
)))
681 ((let ((y x
) ...
) a ... b
)
684 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
685 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
686 (is-ec ret
#'b tail tags
)))
691 (is-ec ret
#'p
#f tags
)
692 (is-ec ret
#'a tail tags
)
693 (is-ec ret
#'b tail tags
)))
702 (is-ec ret
#'p
#f tags
)
703 (is-ec ret
#'a tail tags
)))
707 (if (member (pr (syntax->datum x
)) tags
)
713 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
)))
719 (define-syntax with-return
721 (define (analyze ret x
)
722 (syntax-case x
(begin let if
)
724 #`(begin a ...
#,(analyze ret
#'b
)))
726 (symbol?
(syntax->datum
#'lp
))
727 #`(let lp v a ...
#,(analyze ret
#'b
)))
729 #`(let v a ...
#,(analyze ret
#'b
)))
731 #`(if p
#,(analyze ret
#'a
) #,(analyze ret
#'b
)))
733 #`(if p
#,(analyze ret
#'a
)))
735 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
736 (if (eq?
#'(b ...
) '())
741 (define (is-ec ret x tail
)
742 (syntax-case x
(begin let if define
@@)
746 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
747 (is-ec ret
#'b tail
)))
749 ((let lp
((y x
) ...
) a ... b
)
750 (symbol?
(syntax->datum
#'lp
))
752 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
753 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
754 (is-ec ret
#'b tail
)))
756 ((let ((y x
) ...
) a ... b
)
759 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
760 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
761 (is-ec ret
#'b tail
)))
772 (is-ec ret
#'b tail
)))
778 (is-ec ret
#'a tail
)))
781 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
786 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
)))
794 (let ((code (analyze #'ret
#'l
)))
795 (if (is-ec #'ret
#'l
#t
)
796 #`(let/ec ret
#,code
)
802 (if (module-defined?
(current-module) v
)
806 (define-inlinable (non? x
) (eq? x
#:nil
))
810 ((_ (x) (a) code
#f
#f
)
815 (with-sp ((continue (lp (cdr l
)))
819 (for/adv1
(x) (a) code
#f
#f
)))
821 ((_ (x) (a) code
#f
#t
)
829 (with-sp ((continue (continue-ret))
833 (for/adv1
(x) (a) code
#f
#t
)))
835 ((_ (x) (a) code next
#f
)
838 (let ((x (let lp
((l a
) (old #f
))
842 (with-sp ((continue (continue-ret))
848 (for/adv1
(x) (a) code next
#f
)))
851 (for/adv1 x a code next p
))))
853 (define-syntax for
/adv1
856 ((_ (x ...
) (in ...
) code
#f
#f
)
857 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
858 #'(let ((inv (wrap-in in
)) ...
)
862 (call-with-values (lambda () (values (next inv
) ...
))
864 (with-sp ((break (values))
868 (lambda z
(values))))))
870 ((_ (x ...
) (in ...
) code
#f
#t
)
871 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
872 #'(let ((inv (wrap-in in
)) ...
)
877 (call-with-values (lambda () (values (next inv
) ...
))
880 (with-sp ((break (break-ret))
881 (continue (continue-ret)))
884 (lambda z
(values))))))))
886 ((_ (x ...
) in code else
#f
)
887 #'(for-adv (x ...
) in code else
#f
))
889 ((_ (x ...
) in code else
#t
)
890 #'(for-adv (x ...
) in code else
#t
)))))
893 (define-syntax for-adv
896 (if (= (length (syntax->datum x
)) (= (length (syntax->datum y
))))
898 ((x ...
) #'(values (next x
) ...
)))
903 ((_ (x ...
) (in ...
) code else p
)
904 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
905 (with-syntax ((get (gen #'(inv ...
) #'(x ...
)))
906 ((xx ...
) (generate-temporaries #'(x ...
))))
907 (if (syntax->datum
#'p
)
908 #'(let ((inv (wrap-in in
)) ...
)
914 (call-with-values (lambda () get
)
918 (with-sp ((break (break-ret))
919 (continue (continue-ret)))
924 #'(let ((inv (wrap-in in
)) ...
)
930 (call-with-values (lambda () get
)
933 (with-sp ((break (break-ret))
937 (lambda e else
))))))))))))
940 (define-class <scm-list
> () l
)
941 (define-class <scm-string
> () s i
)
942 (define-class <yield
> () s k
)
944 (define-method (next (l <scm-list
>))
945 (let ((ll (slot-ref l
'l
)))
948 (slot-set! l
'l
(cdr ll
))
950 (throw StopIteration
))))
952 (define-method (next (l <scm-string
>))
953 (let ((s (slot-ref l
's
))
955 (if (= i
(string-length s
))
956 (throw StopIteration
)
958 (slot-set! l
'i
(+ i
1))
961 (define-method (next (l <yield
>))
962 (let ((k (slot-ref l
'k
))
968 (define-method (wrap-in (x <p
>))
969 (aif it
(ref x
'__iter__
#f
)
973 (define-method (wrap-in x
)
976 (let ((o (make <scm-list
>)))
981 (let ((o (make <scm-string
>)))
989 (define yield-prompt
(list 'yield
))
990 (define-syntax def-wrap
994 (pr 'def-wrap
#'f
'false
)
998 (pr 'def-wrap
#'f
'true
)
1000 (define obj
(make <yield
>))
1001 (define ab
(make-prompt-tag))
1002 (slot-set! obj
'k
#f
)
1010 (throw StopIteration
))
1019 (throw StopIteration
))