property values

1 files changed, 34 insertions, 17 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index d916fe8..05f65be 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -2,7 +2,7 @@
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
-  #:export (set ref make-pf <p> <py> <pf> <pyf>
+  #:export (set ref make-pf <p> <py> <pf> <pyf> <property>
                 call with copy fset fcall make-p put put!
                 pcall pcall! get fset-x pyclass? refq
                 def-pf-class  mk-pf-class  make-pf-class
@@ -34,6 +34,8 @@ explicitly tell it to not update etc.
 (define-class <py>  (<p>))
 (define-class <pyf> (<pf>))
 
+(define-class <property> () get set del)
+
 (define (mk x)
   (letrec ((o (make (ref x '__goops__))))
     (slot-set! o 'procedure
@@ -162,17 +164,29 @@ 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)
+          r)))
+
 (define-syntax-rule (mrefx-py- x key l)
-  (let ((f (mrefx- x '__getattribute__ '())))
-    (if (or (not f) (eq? f not-implemented))
-        (mrefx- x key l)
-        (apply f x key l))))
+  (let ((xx x))
+    (prop-ref
+     xx
+     (let ((f (mrefx- xx '__getattribute__ '())))
+       (if (or (not f) (eq? f not-implemented))
+           (mrefx- xx key l)
+           (apply f xx key l))))))
 
 (define-syntax-rule (mrefx-py x key l)
-  (let ((f (mrefx x '__getattribute__ '())))
-    (if (or (not f) (eq? f not-implemented))
-        (mrefx    x key l)
-        (apply f x key l))))
+  (let ((xx x))
+    (prop-ref
+     xx
+     (let ((f (mrefx xx '__getattribute__ '())))
+       (if (or (not f) (eq? f not-implemented))
+           (mrefx    xx key l)
+           (apply f xx key l))))))
 
 (define-syntax-rule (unx mrefx- mref-)
   (define-syntax-rule (mref- x key l)
@@ -285,10 +299,13 @@ explicitly tell it to not update etc.
       (values))))
 
 (define-syntax-rule (mset-py- x key val)
-  (let ((f (mref-py- x '__setattr__ '())))
-    (if (or (eq? f not-implemented) (not f))
-        (mset- x key val)
-        (f key val))))
+  (let ((v (mref- x key fail)))
+    (if (or (eq? v fail) (not (is-a? v <property>)))
+        (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))))
 
 (define-syntax-rule (mklam (mset a ...) val)
   (if (procedure? val)
@@ -297,10 +314,10 @@ explicitly tell it to not update etc.
           (mset a ... (object-method val)))
       (mset a ... val)))
 
-(define-method (set (x <pf>)  key val) (mset     x key val))
-(define-method (set (x <p>)   key val) (mset-    x key val))
-(define-method (set (x <pyf>) key val) (mset-py  x key val))
-(define-method (set (x <py>)  key val) (mset-py- x key val))
+(define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
+(define-method (set (x <p>)   key val) (mklam (mset-    x key) val))
+(define-method (set (x <pyf>) key val) (mklam (mset-py  x key) val))
+(define-method (set (x <py>)  key val) (mklam (mset-py- x key) val))
 
 ;; mref will reference the value of the key in the object x, an extra default
 ;; parameter will tell what the fail object is else #f if fail