diff options
Diffstat (limited to 'modules/language/python')
-rw-r--r-- | modules/language/python/compile.scm | 111 |
1 files changed, 69 insertions, 42 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index b94e867..e515ded 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -6,6 +6,8 @@ #:use-module (ice-9 pretty-print) #:export (comp)) +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + (define-syntax clear-warning-data (lambda (x) (pr 'clear) @@ -132,7 +134,7 @@ (define (gen-yield f) (string->symbol - (string-concat + (string-append (symbol->string f) ".yield"))) @@ -158,10 +160,12 @@ ',(exp vs las) ,u))))))) (define is-class? (make-fluid #f)) +(define (gen-yargs vs x) + (match (pr 'yarg x) ((#:list args) + (map (g vs exp) args)))) (define (exp vs x) (match (pr x) - ((#:power (x) () . #f) (exp vs x)) ((#:power x () . #f) @@ -180,6 +184,7 @@ (match (pr x) ((#:identifier . _) (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer)) + ((#:arglist args #f #f) (lp `(,e ,@(map (g vs exp) args)) trailer)) (_ (error "unhandled trailer"))))))) @@ -412,12 +417,12 @@ (lambda () ,(exp vs fin))))) ((#:yield args) - '(scm-yield ,@gen-args(args))) + `(scm-yield ,@(gen-yargs vs args))) - ((#:yield (f args)) - (let ((f (gen-yield (exp vs f)))) - '(,f ,@gen-args(args))) + ((#:yield f args) + (let ((f (gen-yield (exp vs f)))) + `(,f ,@(gen-yargs vs args)))) ((#:def f (#:types-args-list @@ -425,41 +430,55 @@ #f #f) #f code) - (let* ((c? (fluid-ref is-class?)) - (f (exp vs f)) - (y? (is-yield f #f code)) - (r (gensym "return")) - (as (map (lambda (x) (match x - ((((#:identifier x . _) . #f) #f) - (string->symbol x)))) - args)) - (vs (union as vs)) - (ns (scope code vs)) - (df (defs code '())) - (ex (gensym "ex")) - (ls (diff (diff ns vs) df))) + (let* ((c? (fluid-ref is-class?)) + (f (exp vs f)) + (y? (is-yield f #f code)) + (r (gensym "return")) + (as (map (lambda (x) (match x + ((((#:identifier x . _) . #f) #f) + (string->symbol x)))) + args)) + (ab (gensym "ab")) + (vs (union as vs)) + (ns (scope code vs)) + (df (defs code '())) + (ex (gensym "ex")) + (y 'scm.yield) + (y.f (gen-yield f)) + (ls (diff (diff ns vs) df))) + + (define (mk code) + `(let-syntax ((,y (syntax-rules () + ((_ . args) + (abort-to-prompt ,ab . args)))) + (,y.f (syntax-rules () + ((_ . args) + (abort-to-prompt ,ab . args))))) + ,code)) + (with-fluids ((is-class? #f)) (if c? `(define ,f - (def-wrap ,y? + (,(C 'def-wrap) ,y? ,f ,ab (letrec ((,f (case-lambda ((,ex ,@as) (,f ,@as)) ((,@as) (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code)))))))) + ,(mk `(let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code))))))))) ,f))) `(define ,f - (def-wrap ,y? + (,(C 'def-wrap) ,y? ,f ,ab (lambda (,@as) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) - (exp ns code))))))))))) + (mk + (exp ns code)))))))))))) ((#:global . _) '(values)) @@ -564,7 +583,7 @@ (match x ((#:def nm args _ code) (is-yield f #t code)) - ((#:yield (x _)) + ((#:yield x _) (eq? f (exp '() x))) ((#:yield _) (not p)) @@ -782,7 +801,7 @@ (continue (values))) code (lp)))))) - (lambda x (values)))))) + (lambda z (values)))))) ((_ (x ...) (in ...) code #f #t) (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) @@ -798,7 +817,7 @@ (continue (continue-ret))) code)) (lp)))) - (lambda x (values)))))))) + (lambda z (values)))))))) ((_ (x ...) in code else #f) #'(for-adv (x ...) in code else #f)) @@ -821,7 +840,7 @@ (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) (with-syntax ((get (gen #'(inv ...) #'(x ...))) ((xx ...) (generate-temporaries #'(x ...)))) - (if (syntax->datume #'p) + (if (syntax->datum #'p) #'(let ((inv (wrap-in in)) ...) (let/ec break-ret (let ((x #f) ...) @@ -856,7 +875,7 @@ (define-class <scm-list> () l) (define-class <scm-string> () s i) -(define-class <yield> () k) +(define-class <yield> () s k) (define-method (next (l <scm-list>)) (let ((ll (slot-ref l 'l))) @@ -907,29 +926,37 @@ (define-syntax def-wrap (lambda (x) (syntax-case x () - ((_ #f f x) + ((_ #f f ab x) + (pr 'def-wrap #'f 'false) #'x) - ((_ #t f code) + ((_ #t f ab code) + (pr 'def-wrap #'f 'true) #'(lambda x (define obj (make <yield>)) + (define ab (make-prompt-tag)) (slot-set! obj 'k #f) - (slot-set! obj 'start + (slot-set! obj 's (lambda () (let/ec return - (with-prompt - yield-prompt - (lambda () (apply code x)) + (call-with-prompt + ab + (lambda () + (apply code x) + (throw StopIteration)) (letrec ((lam (lambda (k . l) (slot-set! obj 'k (lambda () - (with-prompt - yield-prompt - k - lam)))))) - lam)) - (throw StopIteration))) + (call-with-prompt + ab + (lambda () + (k) + (throw StopIteration)) + lam))) + (apply values l)))) + lam))))) + obj))))) |