diff options
Diffstat (limited to 'modules/language/python/compile.scm')
| -rw-r--r-- | modules/language/python/compile.scm | 125 |
1 files changed, 104 insertions, 21 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 4aa67ec..46a9199 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -179,6 +179,60 @@ ((sort) (L 'pylist-sort!)) (else #f))) +(define (get-addings vs x) + (match x + (() '()) + ((x . l) + (let ((is-fkn? (match l + (((#:arglist . _) . _) + #t) + (_ + #f)))) + + (cons + (match x + ((#:identifier . _) + (let* ((tag (exp vs x)) + (xs (gensym "xs")) + (is-fkn? (aif it (and is-fkn? (fastfkn tag)) + `(#:call-obj (lambda (e) + `(lambda ,xs + (apply ,it ,e ,xs)))) + #f))) + (if is-fkn? + is-fkn? + `(#:identifier ',tag)))) + + ((#:arglist args apply #f) + (if apply + `(#:apply ,@(map (g vs exp) args) + ,`(,(L 'to-list) ,(exp vs apply))) + `(#:call ,@(map (g vs exp) args)))) + + ((#:subscripts (n #f #f)) + `(#:vecref ,(exp vs n))) + + ((#:subscripts (n1 n2 n3)) + (let ((w (lambda (x) (if (eq? x 'None) ''None x)))) + `(#:vecsub + ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3))))) + + ((#:subscripts (n #f #f) ...) + `(#:array-ref ,@ (map (lambda (n) + (exp vs n)) + n))) + + ((#:subscripts (n1 n2 n3) ...) + (let ((w (lambda (x) (if (eq? x 'None) ''None x)))) + `(#:arraysub + ,@(map (lambda (x y z) + `(,(exp vs x) ,(exp vs y) ,(exp vs z))) + n1 n2 n3)))) + + (_ (error "unhandled addings"))) + (get-addings vs l)))))) + + (define (make-set vs op x u) (define (tr-op op) (match op @@ -197,7 +251,7 @@ (match x ((#:test (#:power kind (#:identifier v . _) addings . _) . _) - (let ((addings (map (lambda (x) (exp vs x)) addings))) + (let ((addings (get-addings vs addings))) (define q (lambda (x) `',x)) (if kind (let ((v (string->symbol v))) @@ -218,18 +272,12 @@ (if op `(,s/d ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)) `(,s/d ,v ,u)) - (let* ((rev (reverse addings)) - (las (car rev)) - (new (reverse (cdr rev)))) - `(,(O 'set) ,(let lp ((v v) (new new)) - (match new - ((x . new) - (lp `(,(O 'refq) ,v 'x) ',new)) - (() v))) - ',(exp vs las) - ,(if op - `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) - u)))))))))) + `(,(C 'set-x) + ,v + ,addings + ,(if op + `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) + u))))))))) (define is-class? (make-fluid #f)) (define (gen-yargs vs x) @@ -357,6 +405,14 @@ ((_ x) (list 'lognot (exp vs x)))) + (#:u- + ((_ x) + (list '- (exp vs x)))) + + (#:u+ + ((_ x) + (list '+ (exp vs x)))) + (#:band ((_ . l) (cons 'logand (map (g vs exp) l)))) @@ -694,8 +750,8 @@ (#:list ((_ . l) (list (L 'to-pylist) (let lp ((l l)) - (match l - (() ''()) + (match l + ((or () #f) ''()) (((#:starexpr #:power #f (#:list . l) . _) . _) (lp l)) (((#:starexpr #:power #f (#:tuple . l) . _) . _) @@ -1183,10 +1239,37 @@ obj))))) (define-syntax ref-x - (lambda (x) - (syntax-case x () - ((_ v) - #'v) - ((_ v x . l) - #'(ref-x (refq v 'x) . l))))) + (syntax-rules () + ((_ v) + v) + ((_ v (#:identifier x) . l) + (ref-x (refq v 'x) . l)) + ((_ v (#:identifier x) . l) + (ref-x (refq v 'x) . l)) + ((_ v (#:call-obj x) . l) + (ref-x (x v) . l)) + ((_ v (#:call x ...) . l) + (ref-x (v x ...) . l)) + ((_ v (#:apply x ...) . l) + (ref-x (apply v x ...) . l)) + ((_ v (#:apply x ...) . l) + (ref-x (apply v x ...) . l)) + ((_ v (#:vecref x) . l) + (ref-x (pylist-ref v x) . l)) + ((_ v (#:vecsub . x) . l) + (ref-x (pylist-slice v . x) . l)))) + +(define-syntax set-x + (syntax-rules () + ((_ v (a ... b) val) + (set-x-2 (ref-x v a ...) b val)))) + +(define-syntax set-x-2 + (syntax-rules () + ((_ v (#:identifier x) val) + (set v 'x val)) + ((_ v (#:vecref n) val) + (pylist-set! v n val)) + ((_ v (#:vecsub x ...) val) + (pylist-subset! v x ... val)))) |