diff options
Diffstat (limited to 'modules/language')
| -rw-r--r-- | modules/language/python/compile.scm | 74 | ||||
| -rw-r--r-- | modules/language/python/list.scm | 26 |
2 files changed, 67 insertions, 33 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 6dd12a5..597c71f 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -7,6 +7,7 @@ #:use-module (language python yield) #:use-module (language python for) #:use-module (language python try) + #:use-module (language python list) #:use-module (ice-9 pretty-print) #:export (comp)) @@ -48,12 +49,13 @@ (close port) x) -(define (C x) `(@@ (language python compile) ,x)) -(define (Y x) `(@@ (language python yield) ,x)) -(define (T x) `(@@ (language python try) ,x)) -(define (F x) `(@@ (language python for) ,x)) -(define (O x) `(@@ (oop pf-objects) ,x)) -(define (G x) `(@ (guile) ,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)) +(define-inlinable (F x) `(@@ (language python for) ,x)) +(define-inlinable (L x) `(@@ (language python list) ,x)) +(define-inlinable (O x) `(@@ (oop pf-objects) ,x)) +(define-inlinable (G x) `(@ (guile) ,x)) (define (union as vs) (let lp ((as as) (vs vs)) @@ -254,8 +256,14 @@ ((#:identifier . _) (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer)) - ((#:arglist args #f #f) - (lp `(,e ,@(map (g vs exp) args)) trailer)) + ((#:arglist args apply #f) + (if apply + (lp `(apply ,e + ,@(map (g vs exp) args) + ,`(,(L 'to-list) ,(exp vs apply))) + trailer) + (lp `(,e ,@(map (g vs exp) args)) trailer))) + (_ (error "unhandled trailer")))))))))) (#:identifier @@ -282,7 +290,7 @@ (#:% ((_ . l) (cons 'modulo (map (g vs exp) l)))) - + (#:// ((_ . l) (cons 'floor-quotient (map (g vs exp) l)))) @@ -290,7 +298,7 @@ (#:<< ((_ . l) (cons (C '<<) (map (g vs exp) l)))) - + (#:>> ((_ . l) (cons (C '>>) (map (g vs exp) l)))) @@ -306,7 +314,7 @@ (#:bxor ((_ . l) (cons 'logxor (map (g vs exp) l)))) - + (#:bor ((_ . l) (cons 'logior (map (g vs exp) l)))) @@ -314,7 +322,7 @@ (#:not ((_ x) (list 'not (exp vs x)))) - + (#:or ((_ . x) (cons 'or (map (g vs exp) x)))) @@ -563,19 +571,23 @@ ((_ f (#:types-args-list args - #f #f) + extra #f) #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)) (ab (gensym "ab")) - (vs (union as vs)) + (vs (union dd (union as vs))) (ns (scope code vs)) (df (defs code '())) (ex (gensym "ex")) @@ -597,59 +609,53 @@ (if y? `(define ,f (,(C 'def-wrap) ,y? ,f ,ab - (lambda (,@as) + (lambda (,@as ,@dd2) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) (exp ns code)))))))) - `(define ,f - (letrec ((,f - (case-lambda - ((,ex ,@as) - (,f ,@as)) - ((,@as) - (,(C 'with-return) ,r - ,(mk `(let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code))))))))) - ,f))) + `(define ,f (lambda (,@as ,@dd2) + (,(C 'with-return) ,r + ,(mk `(let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code)))))))) (if y? `(define ,f (,(C 'def-wrap) ,y? ,f ,ab - (lambda (,@as) + (lambda (,@as ,@dd2) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) (mk (exp ns code)))))))) `(define ,f - (lambda (,@as) + (lambda (,@as ,@dd2) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) ,(with-fluids ((return r)) (exp ns code)))))))))))) - + (#:global ((_ . _) '(values))) - + (#:lambdef ((_ v e) (list `lambda v (exp vs e)))) - + (#:stmt ((_ l) (if (> (length l) 1) (cons 'values (map (g vs exp) l)) (exp vs (car l))))) - + (#:expr-stmt ((_ (l) (#:assign)) (exp vs l)) - + ((_ l type) (=> fail) (call-with-values @@ -708,6 +714,8 @@ (define (exp vs x) (match (pr x) + ((e) + (exp vs e)) ((tag . l) ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs)) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm new file mode 100644 index 0000000..64ff6e4 --- /dev/null +++ b/modules/language/python/list.scm @@ -0,0 +1,26 @@ +(define-module (language python list) + #:use-module (oop pf-objects) + #:use-module (oop goops) + #:use-module (language python yield) + #:use-module (language python for) + #:use-module (language python exceptions) + #:export (to-list)) + + +(define-method (to-list x) + (if (vector? x) + (vector->list x) + x)) + +(define-method (to-list (x <p>)) + ((ref x '__tolist__ (lambda () (error "missing __tolist__ in object"))))) + +(define-method (to-list (x <yield>)) + (define l '()) + (catch StopIteration + (lambda () + (let lp () + (set! l (cons (next x) l)) + (lp))) + (lambda x + (reverse l)))) |