functional objects

1 files changed, 61 insertions, 25 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 9101415..761d44c 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -1,9 +1,10 @@
 (define-module (oop pf-objects)
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
   #:export (set ref make-pf <p> <py> <pf> <pyf>
                 call with copy fset fcall make-p put put!
-                pcall pcall! get next
+                pcall pcall! get next fset-x
                 mk
                 def-pf-class  mk-pf-class  make-pf-class
                 def-p-class   mk-p-class   make-p-class
@@ -47,35 +48,55 @@ explicitly tell it to not update etc.
   (slot-set! r 'h (make-hash-table))
   r)
 
+(define-syntax-rule (hif it (k h) x y)
+  (let ((a (vhash-assq k h)))
+    (if (pair? a)
+        (let ((it (cdr a)))
+          x)
+        y)))
+
+(define-syntax-rule (cif (it h) (k cl) x y)
+  (let* ((h (slot-ref cl 'h))
+         (a (vhash-assq k h)))
+    (if (pair? a)
+        (let ((it (cdr a)))
+          x)
+        y)))
+
 (define fail (cons 'fail '()))
 (define-syntax-rule (mrefx x key l)
-  (let ((h (slot-ref x 'h)))
-    (define pair (vhash-assq key h))
+  (let ()
     (define (end)
       (if (null? l)
           #f
           (car l)))
-    (define (parents)
-      (let ((pair (vhash-assq '__parents__ h)))
-        (if (pair? pair)
-            (let lp ((li (cdr pair)))
-              (if (pair? li)
-                  (let ((r (ref (car li) key fail)))
-                    (if (eq? r fail)
-                        (lp (cdr li))
-                        r))
-                  (end)))
-            (end))))
-
-    (if pair
-        (cdr pair)
-        (let ((cl (ref x '__class__)))
-          (if cl
-              (let ((r (ref cl key fail)))
-                (if (eq? r fail)
-                    (parents)
-                    r))
-              (parents))))))
+
+    (define (parents li)
+      (let lp ((li li))
+        (if (pair? li)
+            (let ((p (car li)))
+              (cif (it h) (key p)
+                   it
+                   (hif it ('__parents__ h)
+                        (let ((r (parents it)))
+                          (if (eq? r fail)
+                              (lp (cdr li))
+                              r))
+                        (lp (cdr li)))))
+            fail)))
+  
+    (cif (it h) (key x)
+         it
+         (hif cl ('__class__ h)
+              (cif (it h) (key cl)
+                   it
+                   (hif p ('__parents__ h)
+                        (let ((r (parents p)))
+                          (if (eq? r fail)
+                              (end)
+                              r))
+                        (end)))
+              (end)))))
 
 (define-syntax-rule (mrefx- x key l)
   (let ()
@@ -275,6 +296,21 @@ explicitly tell it to not update etc.
     (mset x key val)
     x))
 
+(define (fset-x obj l val)
+  (let lp ((obj obj) (l l) (r '()))
+    (match l
+      (()
+       (let lp ((v val) (r r))
+         (if (pair? r)
+             (lp (fset (caar r) (cdar r) v) (cdr r))
+             v)))
+      ((k . l)
+       (lp (ref obj k #f) l (cons (cons obj k) r))))))
+
+
+
+           
+
 ;; a functional call will keep x untouched and return (values fknval newx)
 ;; e.g. we get both the value of the call and the new version of x with
 ;; perhaps new bindings added
@@ -434,7 +470,7 @@ explicitly tell it to not update etc.
                                           #'(supers (... ...)))))
            #'(let ((sups supers) (... ...))
                (define class dynamic)
-               (define name (make-class (list sups (... ...) <p>) '()))
+               (define name (make-class (list sups (... ...) <pf>) '()))
 
                (put! class.__const__
                      (union const