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 clear-warning-data
12 (set! (@@ (system base message
) %dont-warn-list
) '())
15 (define-syntax dont-warn
21 (set! (@@ (system base message
) %dont-warn-list
)
22 (cons (syntax->datum
#'d
)
23 (@@ (system base message
) %dont-warn-list
)))
28 ((_ (f) . l
) (f . l
))))
30 (define (fold f init l
)
32 (fold f
(f (car l
) init
) (cdr l
))
36 (define port
(open-file "/home/stis/src/python-on-guile/log.txt" "a"))
37 (with-output-to-port port
39 (pretty-print (syntax->datum x
))))
44 (define port
(open-file "/home/stis/src/python-on-guile/compile.log" "a"))
45 (with-output-to-port port
46 (lambda () (pretty-print (syntax->datum x
)) x
))
50 (define (C x
) `(@@ (language python compile
) ,x
))
51 (define (O x
) `(@@ (oop pf-objects
) ,x
))
52 (define (G x
) `(@ (guile) ,x
))
55 (let lp
((as as
) (vs vs
))
65 (let lp
((as as
) (rs '()))
74 (define (get-globals code
)
75 (let lp
((vs (glob code
'())) (rs (scope code
'())))
87 (let lp
((l l
) (vs vs
))
89 (((#:identifier v . _
) . l
)
90 (let ((s (string->symbol v
)))
102 ((#:def
(#:identifier f . _
) . _
)
103 (union (list (string->symbol f
)) vs
))
110 ((#:identifier v . _
)
111 (let ((s (string->symbol v
)))
116 (scope y
(scope x vs
)))
121 ((#:def
(#:identifier f . _
) . _
)
122 (union (list (string->symbol f
)) vs
))
130 (defs y
(defs x vs
)))
134 (lambda (x) (e vs x
)))
136 (define return
(make-fluid 'error-return
))
138 (define (make-set vs x u
)
140 ((#:test
(#:power
(#:identifier v . _
) addings . _
) . _
)
141 (let ((v (string->symbol v
)))
144 (let* ((rev (reverse addings
))
146 (new (reverse (cdr rev
))))
147 `(,(O 'set
) ,(let lp
((v v
) (new new
))
150 (lp `(,(O 'ref
) ,v
,(exp vs x
)) ',new
))
152 ',(exp vs las
) ,u
)))))))
154 (define is-class?
(make-fluid #f
))
159 ((#:power
(x) () .
#f
)
165 ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
166 ((#:power vf trailer .
#f
)
167 (let lp
((e (exp vs vf
)) (trailer trailer
))
176 (lp `(,(O 'ref
) ,e
',(exp vs x
) #f
) trailer
))
177 ((#:arglist args
#f
#f
)
178 (lp `(,e
,@(map (g vs exp
) args
)) trailer
))
179 (_ (error "unhandled trailer")))))))
181 ((#:identifier x . _
)
187 (((and x
(or #:+ #:-
#:* #:/)) . l
)
188 (cons (keyword->symbol x
) (map (g vs exp
) l
)))
191 (list 'lognot
(exp vs x
)))
194 (cons 'logand
(map (g vs exp
) l
)))
197 (cons 'logxor
(map (g vs exp
) l
)))
200 (cons 'logior
(map (g vs exp
) l
)))
203 (list 'not
(exp vs x
)))
206 (cons 'or
(map (g vs exp
) x
)))
209 (cons 'and
(map (g vs exp
) x
)))
215 (list 'if
(exp vs e2
) (exp vs e1
) (exp vs e3
)))
217 ((#:if test a
((tests . as
) ...
) . else
)
219 (,(exp vs test
) ,(exp vs a
))
220 ,@(map (lambda (p a
) (list (exp vs p
) (exp vs a
))) tests as
)
221 ,@(if else
`((else ,(exp vs else
))) '())))
223 ((#:suite . l
) (cons 'begin
(map (g vs exp
) l
)))
228 (lambda () ,(exp vs x
))
229 (lambda () ,(exp vs fin
))))
231 ((#:while test code
#f
)
232 (let ((lp (gensym "lp")))
239 ((#:classdef
(#:identifier class . _
) parents defs
)
240 (with-fluids ((is-class?
#t
))
246 (((or 'fast
'functional
)) s
)
249 (define (is-functional l
)
250 (fold (lambda (x pred
)
257 (fold (lambda (x pred
)
265 (let* ((class (string->symbol class
))
266 (parents (match parents
269 ((#:arglist args . _
)
270 (map (g vs exp
) args
))))
271 (is-func (is-functional parents
))
272 (is-fast (is-fast parents
))
280 (parents (filt parents
)))
281 `(define ,class
(,(O 'wrap
)
284 ,(map (lambda (x) `(,(O 'get-class
) ,x
)) parents
)
286 ,(match (exp vs defs
)
302 ((#:for e in code .
#f
)
305 (((#:power
(#:identifier x . _
) () .
#f
))
307 (((#:test power . _
))
310 (#:identifier
"range" . _
)
311 ((#:arglist arglist . _
))
315 (let ((v (gensym "v"))
316 (x (string->symbol x
))
318 `(let ((,v
,(exp vs arg
)))
325 (let ((v1 (gensym "va"))
328 `(let ((,v1
,(exp vs arg1
))
329 (,v2
,(exp vs arg2
)))
336 (let ((v1 (gensym "va"))
340 `(let ((,v1
,(exp vs arg1
))
342 (,v2
,(exp vs arg3
)))
355 (error "range with step 0 not allowed"))))))
361 ((#:for es in code . else
)
362 (let* ((es2 (map (g vs exp
) es
))
364 (code2 (exp vs2 code
))
365 (p (is-ec #t code2
#t
(list (C 'break
) (C 'continue
))))
366 (else2 (if else
(exp vs2 else
) #f
))
367 (in2 (map (g vs exp
) in
)))
368 (list (C 'for
) es2 in2 code2 else2 p
)))
370 ((#:while test code else
)
371 (let ((lp (gensym "lp")))
379 ((#:try x exc else fin
)
385 (lambda ,(gensym "x") ,(exp vs x
))))))
391 (let lp
((code (exp vs x
)) (l (reverse exc
)))
394 (lp `(catch ,(exp vs e
)
396 (lambda ,(gensym "x")
399 (lp `(let ((,as
,(exp vs e
)))
402 (lambda ,(gensym "x")
406 (lambda () ,(exp vs fin
)))))
408 ((#:def
(#:identifier f . _
)
414 (let* ((c?
(fluid-ref is-class?
))
415 (f (string->symbol f
))
416 (r (gensym "return"))
417 (as (map (lambda (x) (match x
418 ((((#:identifier x . _
) .
#f
) #f
)
419 (string->symbol x
))))
425 (ls (diff (diff ns vs
) df
)))
426 (with-fluids ((is-class?
#f
))
428 `(define ,f
(letrec ((,f
433 (,(C 'with-return
) ,r
434 (let ,(map (lambda (x) (list x
#f
)) ls
)
435 ,(with-fluids ((return r
))
439 `(define ,f
(lambda (,@as
)
440 (,(C 'with-return
) ,r
441 (let ,(map (lambda (x) (list x
#f
)) ls
)
442 ,(with-fluids ((return r
))
443 (exp ns code
))))))))))
449 (list `lambda v
(exp vs e
)))
453 (cons 'values
(map (g vs exp
) l
))
457 ((#:expr-stmt
(l) (#:assign
))
460 ((#:expr-stmt l
(#:assign u
))
462 ((= (length l
) (length u
))
464 (make-set vs
(car l
) (exp vs
(car u
)))
467 (map (lambda x vs
) l
)
469 (map (g vs exp
) u
)))))
471 (let ((vars (map (lambda (x) (gensym "v")) l
)))
472 `(call-with-values (lambda () (exp vs
(car u
)))
474 ,@(map make-set l vars
)))))))
479 `(,(fluid-ref return
) ,@(map (g vs exp
) x
)))
482 ((#:test
(#:power
(#:identifier v . _
) () .
#f
) #f
))
484 (let ((s (string->symbol v
)))
485 `(set! ,s
,(exp vs l
))))
493 ((or "<" ">" "<=" ">=")
494 (list (G (string->symbol op
)) x y
))
495 ("!=" (list 'not
(list 'equal? x y
)))
496 ("==" (list 'equal? x y
))
497 ("is" (list 'eq? x y
))
498 ("isnot" (list 'not
(list 'eq? x y
)))
499 ("in" (list 'member x y
))
500 ("notin" (list 'not
(list 'member x y
)))
501 ("<>" (list 'not
(list 'equal? x y
)))))
502 (tr op
(exp vs x
) (exp vs y
)))
513 (#:identifier
"module" . _
)
514 ((#:arglist arglist
#f
#f
))
523 `((,(G 'define-module
)
524 (language python module
,@args
)))))
530 (let ((globs (get-globals x
)))
533 ,(C 'clear-warning-data
)
534 (set! (@@ (system base message
) %dont-warn-list
) '())
535 ,@(map (lambda (s) `(,(C 'var
) ,s
)) globs
)
536 ,@(map (g globs exp
) x
))))
538 (define-syntax-parameter break
539 (lambda (x) #'(values)))
541 (define-syntax-parameter continue
542 (lambda (x) (error "continue must be bound")))
544 (define-syntax-rule (with-sp ((x v
) ...
) code ...
)
545 (syntax-parameterize ((x (lambda (y) #'v
)) ...
) code ...
))
547 (define (is-ec ret x tail tags
)
548 (syntax-case (pr 'is-ec x
) (begin let if define
@@)
552 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
553 (is-ec ret
#'b tail tags
)))
555 ((let lp
((y x
) ...
) a ... b
)
556 (symbol?
(syntax->datum
#'lp
))
558 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
559 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
560 (is-ec ret
#'b tail tags
)))
562 ((let ((y x
) ...
) a ... b
)
565 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(x ...
))
566 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
))
567 (is-ec ret
#'b tail tags
)))
572 (is-ec ret
#'p
#f tags
)
573 (is-ec ret
#'a tail tags
)
574 (is-ec ret
#'b tail tags
)))
583 (is-ec ret
#'p
#f tags
)
584 (is-ec ret
#'a tail tags
)))
588 (if (member (pr (syntax->datum x
)) tags
)
594 (or-map (lambda (x) (is-ec ret x
#f tags
)) #'(a ...
)))
600 (define-syntax with-return
602 (define (analyze ret x
)
603 (syntax-case x
(begin let if
)
605 #`(begin a ...
#,(analyze ret
#'b
)))
607 (symbol?
(syntax->datum
#'lp
))
608 #`(let lp v a ...
#,(analyze ret
#'b
)))
610 #`(let v a ...
#,(analyze ret
#'b
)))
612 #`(if p
#,(analyze ret
#'a
) #,(analyze ret
#'b
)))
614 #`(if p
#,(analyze ret
#'a
)))
616 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
617 (if (eq?
#'(b ...
) '())
622 (define (is-ec ret x tail
)
623 (syntax-case x
(begin let if define
@@)
627 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
628 (is-ec ret
#'b tail
)))
630 ((let lp
((y x
) ...
) a ... b
)
631 (symbol?
(syntax->datum
#'lp
))
633 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
634 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
635 (is-ec ret
#'b tail
)))
637 ((let ((y x
) ...
) a ... b
)
640 (or-map (lambda (x) (is-ec ret x
#f
)) #'(x ...
))
641 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
))
642 (is-ec ret
#'b tail
)))
653 (is-ec ret
#'b tail
)))
659 (is-ec ret
#'a tail
)))
662 (equal?
(syntax->datum
#'return
) (syntax->datum ret
))
667 (or-map (lambda (x) (is-ec ret x
#f
)) #'(a ...
)))
675 (let ((code (analyze #'ret
#'l
)))
676 (if (is-ec #'ret
#'l
#t
)
677 #`(let/ec ret
#,code
)
680 (define-syntax-rule (var v
)
687 (define-inlinable (non? x
) (eq? x
#:nil
))
691 ((_ (x) (a) code
#f
#f
)
696 (with-sp ((continue (lp (cdr l
)))
700 (for/adv1
(x) (a) code
#f
#f
)))
702 ((_ (x) (a) code
#f
#t
)
710 (with-sp ((continue (continue-ret))
714 (for/adv1
(x) (a) code
#f
#t
)))
716 ((_ (x) (a) code next
#f
)
719 (let ((x (let lp
((l a
) (old #f
))
723 (with-sp ((continue (continue-ret))
729 (for/adv1
(x) (a) code next
#f
)))
732 (for/adv1 x a code next p
))))
734 (define-syntax for
/adv1
737 ((_ (x ...
) (in ...
) code
#f
#f
)
738 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
739 #'(let ((inv (wrap-in in
)) ...
)
741 (call-with-values (lambda () (values (next inv
) ...
))
743 (if (or (non? x
) ...
)
749 ((_ (x ...
) (in ...
) code
#f
#t
)
750 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
751 #'(let ((inv (wrap-in in
)) ...
)
754 (call-with-values (lambda () (values (next inv
) ...
))
756 (if (or (non? x
) ...
)
760 (with-sp ((break (break-ret))
761 (continue (continue-ret)))
765 ((_ (x ...
) in code else
#f
)
766 #'(for-adv (x ...
) in code else
#f
))
768 ((_ (x ...
) in code else
#t
)
769 #'(for-adv (x ...
) in code else
#t
)))))
772 (define-syntax for-adv
775 (if (= (length (syntax->datum x
)) (= (length (syntax->datum y
))))
777 ((x ...
) #'(values (next x
) ...
)))
782 ((_ (x ...
) (in ...
) code else p
)
783 (with-syntax (((inv ...
) (generate-temporaries #'(in ...
))))
784 (with-syntax ((get (gen #'(inv ...
) #'(x ...
)))
785 ((xx ...
) (generate-temporaries #'(x ...
))))
786 #'(let ((inv (wrap-in in
)) ...
)
791 (let lp
((xx #f
) ...
)
792 (call-with-values (lambda () get
)
795 (if (or (non? x
) ...
)
797 (with-sp ((break (break-ret))
798 (continue (continue-ret)))
801 (lambda (x ...
) else
))
806 (let lp
((xx #f
) ...
)
807 (call-with-values (lambda () get
)
809 (if (or (non? x
) ...
)
812 (with-sp ((break (break-ret))
816 (lambda (x ...
) else
)))))))))))
819 (define-class <scm-list
> () (x) l
)
820 (define-class <scm-string
> () (x) s i
)
822 (define-method (next (l <scm-list
>))
823 (let ((ll (slot-ref l
'l
)))
826 (slot-set! l
'l
(cdr ll
))
830 (define-method (next (l <scm-string
>))
831 (let ((s (slot-ref l
's
))
833 (if (= i
(string-length s
))
836 (slot-set! l
'i
(+ i
1))
842 (let ((o (make <scm-list
>)))
847 (let ((o (make <scm-string
>)))