diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-10-04 21:19:09 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-10-04 21:19:09 +0200 |
commit | 5f8089beb5d77a186f4f00053edf45f1985bdb63 (patch) | |
tree | faca727fb2313f7686f87cf2809a221191289d4c /modules/oop/pf-objects.scm | |
parent | 596eebc8eea930e964114defa57ac39e42c2a605 (diff) |
further refinements of properties
Diffstat (limited to 'modules/oop/pf-objects.scm')
-rw-r--r-- | modules/oop/pf-objects.scm | 17 |
1 files changed, 11 insertions, 6 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 05f65be..56247ab 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -165,9 +165,10 @@ explicitly tell it to not update etc. (define not-implemented (cons 'not 'implemeneted)) (define-syntax-rule (prop-ref xx x) - (let ((r x)) - (if (is-a? r <property>) - ((slot-ref r 'get) xx) + (let ((y xx) + (r x)) + (if (and (is-a? r <property>) (not (pyclass? y))) + ((slot-ref r 'get) y) r))) (define-syntax-rule (mrefx-py- x key l) @@ -300,7 +301,7 @@ explicitly tell it to not update etc. (define-syntax-rule (mset-py- x key val) (let ((v (mref- x key fail))) - (if (or (eq? v fail) (not (is-a? v <property>))) + (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x))))) (let ((f (mref-py- x '__setattr__ '()))) (if (or (eq? f not-implemented) (not f)) (mset- x key val) @@ -308,7 +309,11 @@ explicitly tell it to not update etc. ((slot-ref v 'set) x val)))) (define-syntax-rule (mklam (mset a ...) val) - (if (procedure? val) + (if (and (procedure? val) + (not (pyclass? val)) + (if (is-a? val <p>) + (ref val '__call__) + #t)) (if (procedure-property val 'py-special) (mset a ... val) (mset a ... (object-method val))) @@ -592,7 +597,7 @@ explicitly tell it to not update etc. ((ddef dname dval) (... ...))) (let () (define name - (letrec ((mname sval) (... ...) (dname dval) (... ...)) + (let* ((mname sval) (... ...) (dname dval) (... ...)) (make-pf-class name (let ((s (make-pf))) (set s 'mname mname) (... ...) |