class definition improvements

1 files changed, 68 insertions, 48 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 4ff3d23..0c54bd4 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -76,26 +76,46 @@ explicitly tell it to not update etc.
               (parents))))))
 
 (define-syntax-rule (mrefx- x key l)
-  (let* ((h (slot-ref x 'h))
-         (r (hash-ref x key fail)))
-    (if (eq? r fail)
-        (if (pair? l)
-            (car l)
-            #f)
-        r)))
+  (let ()
+    (define (end)   (if (pair? l) (car l) #f))
+    (define (ret q) (if (eq? q fail) (end) q))
+    
+    (define (find-in-class h)
+      (let lp ((class-h h))
+        (let ((r (hash-ref class-h key fail)))
+          (if (eq? r fail)
+              (aif parents (hash-ref class-h '__parents__ #f)
+                   (let lpp ((parents parents))
+                     (if (pair? parents)
+                         (let ((parent (car parents)))
+                           (let ((r (lp (slot-ref parent 'h))))
+                             (if (eq? r fail)
+                                 (lp (cdr parents))
+                                 r)))
+                         fail))
+                   fail)
+              r))))
+
+    (let* ((h (slot-ref x 'h))
+           (r (hash-ref h key fail)))
+      (if (eq? r fail)
+          (aif class (hash-ref h '__class__)
+               (ret (find-in-class (slot-ref class 'h)))
+               fail)
+          r))))
 
 (define not-implemented (cons 'not 'implemeneted))
 
 (define-syntax-rule (mrefx-py- x key l)
-  (let ((f (mref- x '__ref__ '())))
+  (let ((f (mrefx- x '__ref__ '())))
     (if (or (not f) (eq? f not-implemented))
-        (mref- x key l)
+        (mrefx- x key l)
         (apply f x key l))))
 
 (define-syntax-rule (mrefx-py x key l)
-  (let ((f (mref x '__ref__ '())))
+  (let ((f (mrefx x '__ref__ '())))
     (if (or (not f) (eq? f not-implemented))
-        (mref    x key l)
+        (mrefx    x key l)
         (apply f x key l))))
 
 (define-syntax-rule (unx mrefx- mref-)
@@ -159,7 +179,6 @@ explicitly tell it to not update etc.
     (if (or (eq? f not-implemented) (not f))
         (mset x key val)
         (f key val))))
-        
 
 (define-syntax-rule (mset- x key val)
   (let ((h (slot-ref x 'h)))
@@ -176,13 +195,11 @@ explicitly tell it to not update etc.
 (define-method (set (x <pyf>) key val) (mset-py  x key val))
 (define-method (set (x <py>)  key val) (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
 ;; if there is no found binding in the object search the class and
 ;; the super classes for a binding
 
-
 ;; call a function as a value of key in x with the object otself as a first
 ;; parameter, this is pythonic object semantics
 (define-syntax-rule (mk-call mcall mref)
@@ -387,9 +404,10 @@ explicitly tell it to not update etc.
 (define (union- x y)
   (define hx (slot-ref x 'h))
   (define hy (slot-ref y 'h))  
-  (define out (make <p>))
-  (hash-for-each (lambda (k v) (hash-set! hy k v)) hx)
-  (slot-set! out 'h hy)
+  (define out (make-p))
+  (define h  (slot-ref out 'h))
+  (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
+  (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
   out)
 
 
@@ -407,7 +425,8 @@ explicitly tell it to not update etc.
                                           #'(supers (... ...)))))
            #'(let ((sups supers) (... ...))
                (define class dynamic)
-               (define-class name (sups (... ...) <pf>))
+               (define name (make-class (list sups (... ...) <p>) '()))
+
                (put! class.__const__
                      (union const
                             (let lp ((sup (list sups (... ...))))
@@ -425,6 +444,7 @@ explicitly tell it to not update etc.
                (put! class.__const__.__name__    (cons 'name 'obj))
                (put! class.__const__.__class__   class)
                (put! class.__const__.__parents__ (list sups (... ...)))
+               (put! class.__const__.__goops__   name)
                class)))))))
 
 (mk-pf make-pf-class <pf>)
@@ -439,44 +459,44 @@ explicitly tell it to not update etc.
                                           #'(supers (... ...)))))
            #'(let ((sups supers) (... ...))
                (define class dynamic)
-               (define-class name (sups (... ...) <p>))
-               (put! class.__const__
-                     (union- const
-                             (let lp ((sup (list sups (... ...))))
-                               (if (pair? sup)
-                                   (union- (ref (car sup) '__const__  null)
-                                           (lp (cdr sup)))
-                                   (make-p)))))
-    
+               (define name (make-class (list sups (... ...) <p>) '()))
+               
+               (set! class
+                 (union- const
+                         (let lp ((sup (list sups (... ...))))
+                           (if (pair? sup)
+                               (union- (car sup)
+                                       (lp (cdr sup)))
+                               (make-p)))))
+               
 
-               (put! class.__goops__    name)
-               (put! class.__name__     'name)
-               (put! class.__parents__  (list sups (... ...)))
+               (set class '__goops__    name)
+               (set class '__name__     'name)
+               (set class '__parents__  (list sups (... ...)))
+               
+               class)))))))
 
-               (put! class.__const__.__name__    (cons 'name 'obj))
-               (put! class.__const__.__class__   class)
-               (put! class.__const__.__parents__ (list sups (... ...)))
-             
-               (union- class (get class.__const__)))))))))
-         
 (mk-p  make-p-class  <p>)
 (mk-p  make-py-class <py>)
 
 ;; Let's make an object essentially just move a reference
 (define-method (mk (x <pf>) . l)
-  (let ((r (get x.__const__))
-        (k (make (get x.__goops__))))
-    (slot-set! k 'h (slot-ref r 'h))
-    (slot-set! k 'size (slot-ref r 'size))
-    (slot-set! k 'n (slot-ref r 'n))
-    (apply (ref k '__init__ (lambda x (values))) k l)
-    k))
+  (let ((r (ref x '__const__))
+        (o (make (ref x '__goops__))))
+    (slot-set! o 'h    (slot-ref r 'h))
+    (slot-set! o 'size (slot-ref r 'size))
+    (slot-set! o 'n    (slot-ref r 'n))
+    (apply (ref o '__init__ (lambda x (error "no init fkn"))) o l)
+    o))
+
 
 (define-method (mk (x <p>) . l)
-  (let ((k (make (get x.__goops__))))
-    (put! k.__class__ x)
-    (apply (ref k '__init__ (lambda x (values))) k l)
-    k))
+  (let ((o (make (ref x '__goops__)))
+        (h (make-hash-table)))
+    (slot-set! o 'h h)
+    (hash-set! h '__class__ x)
+    (apply (ref o '__init__ (lambda x (error "no init fkn"))) l)
+    o))
 
 ;; the make class and defclass syntactic sugar
 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
@@ -517,7 +537,7 @@ explicitly tell it to not update etc.
 (define-syntax-rule (wrap class)
   (let* ((c   class)
          (ret (lambda x (apply mk c x))))
-    (set-procedure-property! ret 'pyclass class)
+    (set-procedure-property! ret 'pyclass c)
     ret))
 
 (define (get-class x)