diff options
Diffstat (limited to 'modules/language/python/compile.scm')
| -rw-r--r-- | modules/language/python/compile.scm | 126 |
1 files changed, 86 insertions, 40 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index f936aa0..8f5139d 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -17,6 +17,7 @@ #:use-module (language python module) #:use-module (language python dir) #:use-module (language python procedure) + #:use-module (language python bool) #:use-module ((language python with) #:select ()) #:use-module (ice-9 pretty-print) #:export (comp)) @@ -415,15 +416,54 @@ (() (values (reverse l) (reverse kw)))))) -(define (get-kwarg-def vs arg) +(define (get-args_ vs arg) (let lp ((arg arg)) (match arg - ((((x . _) #f) . arg) - (cons (exp vs x) + (((#:arg x) . arg) + (cons (exp vs (car x)) (lp arg))) - ((((a . _) b) . arg) - (cons (list '= (exp vs a) (exp vs b)) + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args= vs arg) + (let lp ((arg arg)) + (match arg + (((#:= x v) . arg) + (cons (list '= (exp vs (car x)) (exp vs v)) + (lp arg))) + + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args* vs arg) + (let lp ((arg arg)) + (match arg + (((#:* x) . arg) + (cons (exp vs (car x)) + (lp arg))) + + ((x . args) + (lp args)) + + (() + '())))) + +(define (get-args** vs arg) + (let lp ((arg arg)) + (match arg + (((#:** x) . arg) + (cons (exp vs (car x)) (lp arg))) + + ((x . args) + (lp args)) + (() '())))) @@ -757,22 +797,25 @@ (#:not ((_ x) - (list 'not (exp vs x)))) + (list 'not (list (C 'boolit) (exp vs x))))) (#:or ((_ . x) - (cons 'or (map (g vs exp) x)))) + (cons 'or (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) (#:and ((_ . x) - (cons 'and (map (g vs exp) x)))) + (cons 'and (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) (#:test ((_ e1 #f) (exp vs e1)) - - ((_ e1 e2 e3) - (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))) + + ((_ e1 (e2 #f)) + (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None))) + + ((_ e1 (e2 e3)) + (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3)))) (#:del ;;We don't delete variables @@ -797,9 +840,10 @@ (#:if ((_ test a ((tests . as) ...) . else) `(,(G 'cond) - (,(exp vs test) ,(exp vs a)) - ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as) - ,@(if else `((else ,(exp vs else))) '())))) + (,(list (C 'boolit) (exp vs test)) ,(exp vs a)) + ,@(map (lambda (p a) (list (list (C 'boolit) (exp vs p)) + (exp vs a))) tests as) + ,@(if else `((else ,(exp vs else))) '())))) (#:suite ((_ . l) (cons 'begin (map (g vs exp) l)))) @@ -984,6 +1028,9 @@ (match exc ((((test . #f) code) . exc) (lp exc (cons `(#:except ,(exp vs code)) r))) + + (((#f code) . exc) + (lp exc (cons `(#:except ,(exp vs code)) r))) ((((test . as) code) . exc) (let ((l (gensym "l"))) @@ -1038,37 +1085,25 @@ (#:def ((_ f - (#:types-args-list - args - *e **e) + (#:types-args-list . args) #f code) (let* ((decor (let ((r (fluid-ref decorations))) (fluid-set! decorations '()) r)) - (args (get-kwarg-def vs args)) + (args (get-args_ vs args)) + (arg= (get-args= vs args)) + (dd= (map cadr arg=)) (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)) + (*f (get-args* vs args)) + (dd* (map cadr *f)) + (**f (get-args** vs args)) + (dd** (map cadr **f)) (ab (gensym "ab")) - (vs (union dd3 (union dd2 (union as vs)))) + (vs (union dd** (union dd* (union dd= (union args vs))))) (ns (scope code vs)) (df (defs code '())) (ex (gensym "ex")) @@ -1091,7 +1126,7 @@ `(define ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1100,7 +1135,7 @@ `(define ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1111,7 +1146,7 @@ `(define ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1120,7 +1155,7 @@ (exp ns code)))))))))) `(define ,f (,(C 'def-decor) ,decor - (,(D 'lam) (,@args ,@*f ,@**f) + (,(D 'lam) (,@args ,@*f ,@arg= ,@**f) (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,args @@ -1300,7 +1335,9 @@ ((e) (exp vs e)) ((tag . l) - ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs)) + ((hash-ref tagis tag + (lambda y (warn (format #f "not tag in tagis ~a" tag)) x)) + x vs)) (#:True #t) (#:None (E 'None)) @@ -1878,3 +1915,12 @@ ((_ s c) (syntax-parameterize ((*class* (lambda (x) #'s))) c)))) + +(define-syntax boolit + (syntax-rules (and or not) + ((_ (and x y)) (and (boolit x) (boolit y))) + ((_ (or x y)) (or (boolit x) (boolit y))) + ((_ (not x )) (not (boolit x))) + ((_ #t) #t) + ((_ #f) #f) + ((_ x ) (bool x)))) |