diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-10-03 21:44:56 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-10-03 21:44:56 +0200 |
commit | 98f11c126a243596efe83fffa6af09b262ecaeac (patch) | |
tree | b371b8440c6bb523ffcbec2165ce8486b7181c75 /modules/language | |
parent | 3533d6037dd7d83a1f9ee250138d0ebf1bccc062 (diff) |
decorators works
Diffstat (limited to 'modules/language')
-rw-r--r-- | modules/language/python/compile.scm | 120 | ||||
-rw-r--r-- | modules/language/python/list.scm | 22 | ||||
-rw-r--r-- | modules/language/python/number.scm | 37 | ||||
-rw-r--r-- | modules/language/python/set.scm | 4 |
4 files changed, 136 insertions, 47 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 5d9828b..275c635 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -498,14 +498,31 @@ ,(if op `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) u)))))))) - + +(define (filter-defs x) + (match (let lp ((x x)) + (match x + ((('begin . l)) + (lp (cons 'begin l))) + (('begin . l) + (let lp ((l l)) + (match l + ((('values) . l) + (lp l)) + ((x . l) + (cons x (lp l))) + (x x)))))) + (('begin) + '()) + (x x))) + (define is-class? (make-fluid #f)) (define (gen-yargs vs x) (match (pr 'yarg x) ((#:list args) (map (g vs exp) args)))) (define inhibit-finally #f) - +(define decorations (make-fluid '())) (define tagis (make-hash-table)) (define-syntax-rule (gen-table x vs (tag code ...) ...) (begin @@ -548,6 +565,11 @@ ((#:identifier x . _) (string->symbol x))) + (#:decorated + ((_ (l ...)) + (fluid-set! decorations (map (g vs exp) l)) + '(values))) + (#:string ((#:string #f x) x)) @@ -675,9 +697,11 @@ ('fast #t) (_ #f)))) #f l)) - - (let* ((class (string->symbol class)) + (let* ((decor (let ((r (fluid-ref decorations))) + (fluid-set! decorations '()) + r)) + (class (string->symbol class)) (parents (match parents (() '()) @@ -695,18 +719,20 @@ 'mk-p-class 'mk-py-class))) (parents (filt parents))) - `(define ,class (,(O kind) - ,class - ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) - #:const - () - #:dynamic - ,(match (exp vs defs) - (('begin . l) - l) - ((('begin . l)) - l) - (l l))))))))) + `(define ,class + (,(C 'class-decor) ,decor + (,(O kind) + ,class + ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) + #:const + () + #:dynamic + ,(match (filter-defs (exp vs defs)) + (('begin . l) + l) + ((('begin . l)) + l) + (l l)))))))))) (#:scm ((_ (#:string _ s)) (with-input-from-string s read))) @@ -890,7 +916,10 @@ *e **e) #f code) - (let* ((args (get-kwarg-def vs args)) + (let* ((decor (let ((r (fluid-ref decorations))) + (fluid-set! decorations '()) + r)) + (args (get-kwarg-def vs args)) (c? (fluid-ref is-class?)) (f (exp vs f)) (y? (is-yield f #f code)) @@ -933,34 +962,39 @@ (if c? (if y? `(define ,f - (,(C 'def-wrap) ,y? ,f ,ab + (,(C 'def-decor) ,decor + (,(C 'def-wrap) ,y? ,f ,ab + (,(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 + (,(C 'def-decor) ,decor (,(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 (,(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)))))))) + (exp ns code))))))))) (if y? `(define ,f - (,(C 'def-wrap) ,y? ,f ,ab + (,(C 'def-decor) ,decor + (,(C 'def-wrap) ,y? ,f ,ab + (,(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 + (,(C 'def-decor) ,decor (,(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 - (,(D 'lam) (,@args ,@*f ,@**f) - (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code)))))))))))) + (exp ns code))))))))))))) (#:global ((_ . _) @@ -1595,9 +1629,9 @@ ((_ v (#:fast-id f _) . l) (ref-x (f v) . l)) ((_ v (#:identifier x) . l) - (ref-x (refq v 'x) . l)) + (ref-x (refq v x) . l)) ((_ v (#:identifier x) . l) - (ref-x (refq v 'x) . l)) + (ref-x (refq v x) . l)) ((_ v (#:call-obj x) . l) (ref-x (x v) . l)) ((_ v (#:call x ...) . l) @@ -1644,3 +1678,17 @@ ((_ v (#:vecsub x ...) val) (pylist-subset! v x ... val)))) + +(define-syntax class-decor + (syntax-rules () + ((_ () x) x) + ((_ (f ... r) y) + (class-decor (f ...) (r y))))) + +(define-syntax def-decor + (syntax-rules () + ((_ () x) x) + ((_ (f ... r) y) + (def-decor (f ...) (r y))))) + + diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index 1afa56f..7f0d7e4 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -8,13 +8,14 @@ #:use-module (language python for) #:use-module (language python try) #:use-module (language python exceptions) - #:export (to-list to-pylist <py-list> + #:export (to-list to-pylist <py-list> pylist-ref pylist-set! pylist-append! pylist-slice pylist-subset! pylist-reverse! pylist-pop! pylist-count pylist-extend! len in pylist-insert! pylist-remove! pylist-sort! pylist-index pylist-null pylist-delete! - pylist pylist-listing)) + pylist pylist-listing + py-all py-any)) (define scm-list list) @@ -733,3 +734,20 @@ (pylist-sort! l) l)) + +(define (py-all x) + (for ((i : x)) () + (if (not i) + (break #f)) + #:final + #t)) + +(define (py-any x) + (for ((i : x)) () + (if i + (break #t)) + #:final + #f)) + + + diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm index f2c0c6b..56a50cf 100644 --- a/modules/language/python/number.scm +++ b/modules/language/python/number.scm @@ -6,12 +6,12 @@ #:use-module (language python try) #:use-module (language python exceptions) #:export (py-int py-float py-complex - py-/ py-logand py-logior py-logxor py-abs - py-lshift py-rshift py-mod py-floordiv + py-/ py-logand py-logior py-logxor py-abs py-trunc + py-lshift py-rshift py-mod py-floordiv py-round <py-int> <py-float> <py-complex> py-divmod pyfloat-listing pyint-listing pycomplex-listing py-as-integer-ratio py-conjugate py-fromhex py-hex py-imag - py-is-integer py-real hex)) + py-is-integer py-real hex py-bin)) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) @@ -121,11 +121,10 @@ (mk-biop2 i0 py-rmod py-mod __mod__ __rmod__) -(define-method (py-abs (o <number>)) (abs o)) (define-method (py-floor (o1 <integer>)) o1) (define-method (py-floor (o1 <number> )) ) -(define-method (py-float (o1 <integer>)) (exact->inexact o1)) -(define-method (py-float (o1 <number> )) o1) +(define-method (py-trunc (o1 <integer>)) (exact->inexact o1)) +(define-method (py-trunc (o1 <number> )) o1) (define-syntax-rule (u0 f) (begin @@ -145,8 +144,7 @@ (u0 py-hash ) (mk-unop u0 - __neg__ ) -(mk-unop u0 py-abs __abs__ ) -(mk-unop u0 py-floor __floor__ ) +(mk-unop u0 py-trunc __trunc__ ) (mk-unop i0 py-lognot __invert__) (define-method (py-bit-length (i <integer>)) @@ -189,6 +187,12 @@ (define-method (hex (o <integer>)) (+ "0x" (number->string o 16))) +(define-method (py-abs (o <complex>)) + (magnitude o)) +(define-method (py-abs (o <number>)) + (abs o)) + +(mk-unop u0 py-abs __abs__) (mk-unop u0 py-conjugate conjugate) (mk-unop u0 py-imag imag) (mk-unop u0 py-real real) @@ -363,3 +367,20 @@ conjugate imag real))))) (pylist-sort! l) l)) + +(define* (py-round x #:optional (digits 0)) + (let* ((f (expt 1.0 digits)) + (a (if (< x 0) -0.5 0.5)) + (x (py-trunc (+ a (* x f))))) + (/ x f))) + +(define-method (py-bin (o <integer>)) + (number->string o 2)) +(define-method (py-bin (o <py-int>)) + (number->string (slot-ref o 'x) 2)) +(define-method (py-bin (o <p>)) + (let ((r (ref o '__index__))) + (number->string (r) 2) + (raise TypeError "object cannot be interpretted as an index"))) + + diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm index 3164c8f..cd12586 100644 --- a/modules/language/python/set.scm +++ b/modules/language/python/set.scm @@ -7,7 +7,7 @@ #:use-module (language python try) #:use-module (language python list) #:use-module (language python yield) - #:export(set)) + #:export(py-set)) (define-class <set> () dict) @@ -211,3 +211,5 @@ (for ((k v : (slot-ref self 'dict))) () (yield k) (values)))))) + +(define py-set set) |