diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/oop/pf-objects.scm | 110 |
1 files changed, 71 insertions, 39 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index ebaa3b7..abe7169 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -33,8 +33,8 @@ explicitly tell it to not update etc. (define-class <pf> (<p>) size n) ; the pf object consist of a functional ; hashmap it's size and number of live ; object -(define-class <py> (<p>)) -(define-class <pyf> (<pf>)) +(define-class <py> (<p>) ref) +(define-class <pyf> (<pf>) ref) (define-class <property> () get set del) @@ -173,7 +173,18 @@ explicitly tell it to not update etc. (let ((xx x)) (prop-ref xx - (let ((f (mrefx- xx '__getattribute__ '()))) + (let* ((g (mrefx- xx '__fget__ '(#t))) + (f (if g + (if (eq? g #t) + (aif it (mrefx- xx '__getattribute__ '()) + (begin + (set xx '__fget__ it) + it) + (begin + (set xx '__fget__ it) + #f)) + g) + #f))) (if (or (not f) (eq? f not-implemented)) (mrefx- xx key l) (apply f xx key l)))))) @@ -182,7 +193,18 @@ explicitly tell it to not update etc. (let ((xx x)) (prop-ref xx - (let ((f (mrefx xx '__getattribute__ '()))) + (let* ((g (mrefx xx '__fget__ '(#t))) + (f (if g + (if (eq? g #t) + (aif it (mrefx xx '__getattribute__ '()) + (begin + (set xx '__fget__ it) + it) + (begin + (set xx '__fget__ it) + #f)) + g) + #f))) (if (or (not f) (eq? f not-implemented)) (mrefx xx key l) (apply f xx key l)))))) @@ -261,7 +283,21 @@ explicitly tell it to not update etc. (values)))) (define-syntax-rule (mset-py x key val) - (let ((f (mref-py x '__setattr__ '()))) + (let* ((g (mrefx x '__fset__ '(#t))) + (f (if g + (if (eq? g #t) + (let ((class (aif it (mref x '__class__ '()) + it + x))) + (aif it (mrefx x '__setattr__ '()) + (begin + (mset class '__fset__ it) + it) + (begin + (mset class '__fset__ it) + #f))) + g) + #f))) (if (or (eq? f not-implemented) (not f)) (mset x key val) (f key val)))) @@ -269,42 +305,33 @@ explicitly tell it to not update etc. (define (pkh h) (hash-for-each (lambda x (pk x)) h) h) (define-syntax-rule (mset- x key val) - (let () - (define (s h) (begin (hash-set! h key val) #f)) - (define fret #t) - (define (r h k) (hash-ref h k)) - (define-syntax-rule (ifh h fail-code) - (if (r h key) - (s h) - fail-code)) - - (define (hm x) (slot-ref x 'h)) - (let ((h (hm x))) - (if (ifh h - (aif it (r h '__class__) - (let lp ((cl it)) - (let ((h (hm cl))) - (ifh h - (aif it (r h '__parents__) - (let lp2 ((parents it)) - (if (pair? parents) - (let ((h (hm (car parents)))) - (ifh h - (lp2 (cdr parents)))) - fret)) - fret)))) - fret)) - (s h)) - (values)))) + (begin + (hash-set! (slot-ref x 'h) key val) + (values))) (define-syntax-rule (mset-py- x key val) - (let ((v (mref- x key fail))) + (let* ((h (slot-ref x 'h)) + (v (hash-ref h key fail))) (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) - (f key val))) - ((slot-ref v 'set) x val)))) + (let* ((g (mrefx- x '__fset__ '(#t))) + (f (if g + (if (eq? g #t) + (let ((class (aif it (mref- x '__class__ '()) + it + x))) + (aif it (mrefx- x '__setattr__ '()) + (begin + (mset- class '__fset__ it) + it) + (begin + (mset- class '__fset__ it) + #f))) + g) + #f))) + (if (or (eq? f not-implemented) (not f)) + (mset- x key val) + (f key val))) + ((slot-ref v 'set) x val)))) (define-syntax-rule (mklam (mset a ...) val) (if (and (procedure? val) @@ -533,6 +560,9 @@ explicitly tell it to not update etc. null)))) (reshape __const__) + (set class '__class__ #f) + (set class '__fget__ #t) + (set class '__fset__ #t) (set class '__const__ __const__) (set class '__goops__ name) (set class '__name__ 'name) @@ -576,8 +606,10 @@ explicitly tell it to not update etc. (... ...) <p>) '())) (define class (dynamic <p>)) + (set class '__class__ #f) + (set class '__fget__ #t) + (set class '__fset__ #t) (set class '__name__ 'name) - (set class '__class__ #f) (set class '__goops__ name) (set class '__parents__ (filter-parents (list sups (... ...)))) (set class '__mro__ (get-mro class)) |