cashing of attribute reference and setting

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))