From eccf2ec337f63fd266050c23d1ecb56d3b04eebe Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Tue, 12 Sep 2017 23:52:40 +0200 Subject: better operator compilings --- modules/language/python/compile.scm | 216 +++++++++++++++++++++++++----------- 1 file changed, 150 insertions(+), 66 deletions(-) (limited to 'modules/language') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 81de0c3..962c877 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -4,13 +4,13 @@ #:use-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 pretty-print) - #:export (comp send sendException sendClose)) + #:replace (send) + #:export (comp sendException sendClose)) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define-syntax clear-warning-data (lambda (x) - (pr 'clear) (set! (@@ (system base message) %dont-warn-list) '()) #f)) @@ -117,7 +117,7 @@ (list (exp '() v2))) s) (union (list (exp '() v1)) s))) - (() s))) + (_ s))) '() l) vs)) @@ -151,29 +151,60 @@ (define return (make-fluid 'error-return)) -(define (make-set vs x u) +(define-syntax-rule (<< x y) (ash x y)) +(define-syntax-rule (>> x y) (ash x (- y))) + +(define (make-set vs op x u) + (define (tr-op op) + (match op + ("+=" '+) + ("-=" '-) + ("*=" '*) + ("/=" '/) + ("%=" 'modulo) + ("&=" 'logand) + ("|=" 'logior) + ("^=" 'logxor) + ("**=" 'expt) + ("<<=" (C '<<)) + (">>=" (C '>>)) + ("//=" 'floor-quotient))) + (match x ((#:test (#:power kind (#:identifier v . _) addings . _) . _) - (if kind - (let ((v (string->symbol v))) - (if (null? addings) - `(set! ,v ,u) - (let ((addings (map (lambda (x) `',(exp vs x)) addings))) - `(set! ,(exp vs kind) - (,(O 'fset-x) ,v (list ,@addings) ,u))))) - - (let ((v (string->symbol v))) - (if (null? addings) - `(set! ,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 'ref) ,v ,(exp vs x)) ',new)) - (() v))) - ',(exp vs las) ,u)))))))) + (let ((addings (map (lambda (x) (exp vs x)) addings))) + (define q (lambda (x) `',x)) + (if kind + (let ((v (string->symbol v))) + (if (null? addings) + (if op + `(set! ,v (,(tr-op op) ,v ,u)) + `(set! ,v ,u)) + (if op + `(set! ,(exp vs kind) + (,(O 'fset-x) ,v (list ,@(map q addings)) + (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))) + + `(set! ,(exp vs kind) + (,(O 'fset-x) ,v (list ,@(map q addings)) ,u))))) + + (let ((v (string->symbol v))) + (if (null? addings) + (if op + `(set! ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)) + `(set! ,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 'ref) ,v 'x) ',new)) + (() v))) + ',(exp vs las) + ,(if op + `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) + u)))))))))) (define is-class? (make-fluid #f)) (define (gen-yargs vs x) @@ -191,21 +222,27 @@ ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls - ((#:power #f vf trailer . #f) - (let lp ((e (exp vs vf)) (trailer trailer)) - (match trailer - (() - e) - ((#f) - (list e)) - ((x . trailer) - (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"))))))) + ((#:power #f vf trailer . **) + (let () + (define (pw x) + (if ** + `(expt ,x ,(exp vs **)) + x)) + (pw + (let lp ((e (exp vs vf)) (trailer trailer)) + (match trailer + (() + e) + ((#f) + (list e)) + ((x . trailer) + (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"))))))))) ((#:identifier x . _) (string->symbol x)) @@ -216,24 +253,36 @@ (((and x (or #:+ #:- #:* #:/)) . l) (cons (keyword->symbol x) (map (g vs exp) l))) + ((#:% . l) + (cons 'modulo (map (g vs exp) l))) + + ((#:// . l) + (cons 'floor-quotient (map (g vs exp) l))) + + ((#:<< . l) + (cons (C '<<) (map (g vs exp) l))) + + ((#:>> . l) + (cons (C '>>) (map (g vs exp) l))) + ((#:u~ x) (list 'lognot (exp vs x))) ((#:band . l) (cons 'logand (map (g vs exp) l))) - + ((#:bxor . l) (cons 'logxor (map (g vs exp) l))) ((#:bor . l) (cons 'logior (map (g vs exp) l))) - + ((#:not x) (list 'not (exp vs x))) ((#:or . x) (cons 'or (map (g vs exp) x))) - + ((#:and . x) (cons 'and (map (g vs exp) x))) @@ -292,6 +341,8 @@ (let* ((class (string->symbol class)) (parents (match parents + (() + '()) (#f '()) ((#:arglist args . _) @@ -579,22 +630,32 @@ ((#:expr-stmt (l) (#:assign)) (exp vs l)) - ((#:expr-stmt l (#:assign u)) - (cond - ((= (length l) (length u)) - (if (= (length l) 1) - (make-set vs (car l) (exp vs (car u))) - (cons 'begin - (map make-set - (map (lambda x vs) l) - l - (map (g vs exp) u))))) - ((= (length u) 1) - (let ((vars (map (lambda (x) (gensym "v")) l))) - `(call-with-values (lambda () (exp vs (car u))) - (lambda vars - ,@(map make-set l vars))))))) - + ((#:expr-stmt l type) + (=> fail) + (call-with-values + (lambda () (match type + ((#:assign u) + (values #f u)) + ((#:augassign op u) + (values op u)) + (_ (fail)))) + + (lambda (op u) + (cond + ((= (length l) (length u)) + (if (= (length l) 1) + (make-set vs op (car l) (exp vs (car u))) + (cons 'begin + (map (lambda (l u) (make-set vs op l u)) + l + (map (g vs exp) u))))) + ((and (= (length u) 1) (not op)) + (let ((vars (map (lambda (x) (gensym "v")) l))) + `(call-with-values (lambda () (exp vs (car u))) + (lambda vars + ,@(map (lambda (l v) (make-set vs op l v)) + l vars))))))))) + ((#:return . x) @@ -655,7 +716,7 @@ ,@start ,(C 'clear-warning-data) (set! (@@ (system base message) %dont-warn-list) '()) - ,@(map (lambda (s) `(,(C 'var) ',s)) globs) + ,@(map (lambda (s) `(,(C 'var) ,s)) globs) ,@(map (g globs exp) x)))) (define-syntax-parameter break @@ -817,12 +878,15 @@ #`(let/ec ret #,code) code)))))) -(define (var v) - (begin - (dont-warn v) - (if (module-defined? (current-module) v) - (values) - (define! v #f)))) +(define-syntax var + (lambda (x) + (syntax-case x () + ((_ v) + (begin + (dont-warn (syntax->datum #'v)) + #'(if (module-defined? (current-module) 'v) + (values) + (define! 'v #f))))))) (define-inlinable (non? x) (eq? x #:nil)) @@ -1030,7 +1094,20 @@ (apply throw 'python tag l)))) (apply throw tag v)))) (slot-set! l 'closed #t))))) - + +(define-method (send (l

) . u) + (apply (ref l '__send__) u)) + +(define-method (sendException (l

) . u) + (apply (ref l '__exception__) u)) + +(define-method (sendClose (l

)) + ((ref l '__close__))) + +(define-method (next (l

)) + ((ref l '__next__))) + + (define-method (wrap-in (x

)) (aif it (ref x '__iter__ #f) @@ -1093,3 +1170,10 @@ +(define-syntax ref-x + (syntax-rules () + ((_ v) + v) + ((_ v x . l) + (ref-x (ref v 'x) . l)))) + -- cgit v1.2.3