diff options
Diffstat (limited to 'modules/language/python/compile.scm')
-rw-r--r-- | modules/language/python/compile.scm | 79 |
1 files changed, 53 insertions, 26 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 230279a..eace6ec 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -51,6 +51,11 @@ (close port) x) +(define (pp x) + (pretty-print (syntax->datum x)) + x) + + (define-inlinable (C x) `(@@ (language python compile) ,x)) (define-inlinable (Y x) `(@@ (language python yield) ,x)) (define-inlinable (T x) `(@@ (language python try) ,x)) @@ -58,6 +63,7 @@ (define-inlinable (L x) `(@@ (language python list) ,x)) (define-inlinable (A x) `(@@ (language python array) ,x)) (define-inlinable (S x) `(@@ (language python string) ,x)) +(define-inlinable (D x) `(@@ (language python def) ,x)) (define-inlinable (O x) `(@@ (oop pf-objects) ,x)) (define-inlinable (G x) `(@ (guile) ,x)) @@ -142,7 +148,7 @@ (define (defs x vs) (match x - ((#:def (#:identifier f . _) . _) + ((#:def ((#:identifier f) . _) . _) (union (list (string->symbol f)) vs)) ((#:lambdef . _) vs) @@ -200,7 +206,19 @@ (lp arg (cons (exp vs x) l) kw)) (() (values (reverse l) (reverse kw)))))) - + +(define (get-kwarg-def vs arg) + (let lp ((arg arg)) + (match arg + ((((x . _) #f) . arg) + (cons (exp vs x) + (lp arg))) + ((((a . _) b) . arg) + (cons (list '= (exp vs a) (exp vs b)) + (lp arg))) + (() + '())))) + (define (get-addings vs x) (match x (() '()) @@ -214,7 +232,7 @@ (cons (match x - ((#:identifier . _) + (((#:identifier . _) . _) (let* ((tag (exp vs x)) (xs (gensym "xs")) (is-fkn? (aif it (and is-fkn? (fastfkn tag)) @@ -224,7 +242,7 @@ #f))) (if is-fkn? is-fkn? - `(#:identifier ',tag)))) + `((#:identifier ',tag) . _)))) ((#:arglist args apply #f) (call-with-values (lambda () (get-kwarg vs args)) @@ -275,7 +293,7 @@ ("//=" 'floor-quotient))) (match x - ((#:test (#:power kind (#:identifier v . _) addings . _) . _) + ((#:test (#:power kind ((#:identifier v . _) . _) addings . _) . _) (let ((addings (get-addings vs addings))) (define q (lambda (x) `',x)) (if kind @@ -349,7 +367,7 @@ (_ #f)))) (match (pr x) - ((#:identifier . _) + (((#:identifier . _) . _) (let* ((tag (exp vs x)) (xs (gensym "xs")) (is-fkn? (aif it (and is-fkn? (fastfkn tag)) @@ -701,28 +719,37 @@ (set! ,(C 'inhibit-finally) #t) (let ((,g (,f ,@(gen-yargs vs args)))) (,g)))))) - + (#:def ((_ f (#:types-args-list args - extra #f) + *e **e) #f code) - (let* ((c? (fluid-ref is-class?)) - (f (exp vs f)) - (y? (is-yield f #f code)) - (r (gensym "return")) - (dd (match extra - (((e . #f) ()) (list (exp vs e))) - (#f '()))) - (dd2 (if (null? dd) dd (car dd))) - (as (map (lambda (x) (match x - ((((#:identifier x . _) . #f) #f) - (string->symbol x)))) - args)) + (let* ((args (get-kwarg-def vs args)) + (c? (fluid-ref is-class?)) + (f (exp vs f)) + (y? (is-yield f #f code)) + (r (gensym "return")) + (*f (match *e + (((e . #f) ()) (list (list '* (exp vs e)))) + (#f '()))) + (dd2 (match *e + (((e . #f) ()) (list (exp vs e))) + (#f '()))) + (**f (match **e + ((e . #f) (list (list '** (exp vs e)))) + (#f '()))) + (dd3 (match **e + ((e . #f) (list (exp vs e))) + (#f '()))) + (as (map (lambda (x) (match x + (('= a _) a) + (a a))) + args)) (ab (gensym "ab")) - (vs (union dd (union as vs))) + (vs (union dd3 (union dd2 (union as vs)))) (ns (scope code vs)) (df (defs code '())) (ex (gensym "ex")) @@ -738,19 +765,19 @@ ((_ . args) (abort-to-prompt ,ab . args))))) ,code)) - + (with-fluids ((is-class? #f)) (if c? (if y? `(define ,f (,(C 'def-wrap) ,y? ,f ,ab - (lambda (,@as ,@dd2) + (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) (exp ns code)))))))) - `(define ,f (lambda (,@as ,@dd2) + `(define ,f (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) @@ -759,14 +786,14 @@ (if y? `(define ,f (,(C 'def-wrap) ,y? ,f ,ab - (lambda (,@as ,@dd2) + (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) (mk (exp ns code)))))))) `(define ,f - (lambda (,@as ,@dd2) + (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) |