refactoring object system

1 files changed, 163 insertions, 172 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 13edec8..f768027 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -60,17 +60,52 @@ explicitly tell it to not update etc.
         (hash-set! h '__class__ x)
         (slot-set! o 'h    h))
       o))))
-          
-(define (make-pyclass x)
-  (letrec ((class (make x)))
-    (slot-set! class 'procedure
-               (lambda x
-                 (let ((obj (mk class)))
-                   (aif it (ref obj '__init__)
-                        (apply it x)
-                        (values))
-                   obj)))
-    class))
+
+(define-method (get-dict (self <pf>) name parents)
+  (aif it (find-in-class self '__prepare__ #f)
+       (it self name parents)
+       (make <pf>)))
+
+(define-method (get-dict (self <p>) name parents)
+  (aif it (find-in-class self '__prepare__ #f)
+       (it self name parents)
+       (make <p>)))
+
+(define-method (new-class (self <p>) name parents dict)
+  (aif it (ref self '__new__)
+       (it self name parents dict)
+       (let ((class (make (ref dict '__goops__))))
+	 (slot-set! class 'procedure
+		    (aif it (ref self '__call__)
+			 (lambda x (apply __call__ x))		    
+			 (lambda x
+			   (let ((obj (py-make-obj class)))
+			     (aif it (ref obj '__init__)
+				  (apply it x)
+				  (values))
+			     obj)))
+		    class)
+	 (cond
+	  ((is-a? dict <pf>)
+	   (slot-set! class 'h dict))
+	  ((is-a? dict <p>)
+	   (slot-set! class 'h (slot-ref dict 'h)))
+	  (else
+	   (slot-set! class 'h dict))))))
+
+(define (create-class meta name parents gen-methods keys)
+  (let ((dict (gen-methds (get-dict meta name keys))))
+    (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+	 ((it meta 'object) meta name parents keywords)
+	 (let ((class (aif it (find-in-class meta '__new__ #f)
+			   ((it meta 'object) meta name parents dict keys)
+			   (new-class meta name parents dict keys))))
+	   (aif it (find-in-class meta '__init__)
+		((it meta 'object) name parents 
+			     
+	      
+    
+  
 
 ;; Make an empty pf object
 (define* (make-pf #:optional (class <pf>))
@@ -130,36 +165,48 @@ explicitly tell it to not update etc.
                         (end)))
               (end)))))
 
-(define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
-(define-syntax-rule (mrefx-- hi key l)
+(define *refkind* (make-fluid 'object))
+
+
+(define-method (find-in-class (klass <p>) key fail)
+  (hash-ref (slot-ref klass 'h) key fail))
+(define-method (find-in-class (klass <pf>) key fail)
+  (let ((r (vhash-assoc key (slot-ref klass 'h))))
+    (if r
+	(cdr r)
+	fail)))
+
+(define-syntax-rule (kif it p x y)
+  (let ((it p))
+    (if (eq? it fail)
+	y
+	x)))
+
+(define-syntax-rule (find-in-class-and-parents klass key fail)
+  (kif r (find-in-class klass key fail)
+       r
+       (aif parents (hash-ref class-h '__mro__ #f)
+	    (let lp ((parents parents))
+	      (if (pair? parents)
+		  (kif r (find-in-class (car parents) key fail)
+		       r
+		       (lp (cdr parents)))
+		  fail))
+	    fail)))
+
+(define-syntax-rule (mrefx klass key l)
   (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 '__mro__ #f)
-                   (let lpp ((parents parents))
-                     (if (pair? parents)
-                         (let ((parent (car parents)))
-                           (let* ((h (slot-ref parent 'h))
-				  (r (hash-ref h key fail)))
-                             (if (eq? r fail)
-                                 (lpp (cdr parents))
-                                 r)))
-                         fail))
-                   fail)
-              r))))
-
-    (let* ((h hi)
-           (r (hash-ref h key fail)))
-      (if (eq? r fail)
-          (aif class (hash-ref h '__class__)
-               (ret (find-in-class (slot-ref class 'h)))
-               (end))
-          r))))
+    (define (end) (if (pair? l) (car l) #f))
+    (fluid-set! *refkind* 'object)
+    (kif it (find-in-class klass key fail)
+	 it
+	 (begin
+	   (fluid-set! *refkind* 'class)
+	   (aif klass (hash-ref h '__class__)
+		(kif it (find-in-class-and-parents klass key fail)
+		     it
+		     (end))
+		(end))))))
 
 (define not-implemented (cons 'not 'implemeneted))
 
@@ -170,84 +217,51 @@ explicitly tell it to not update etc.
           ((slot-ref r 'get) y)
           r)))
 
-(define-syntax-rule (mrefx-py- x key l)
-  (let ((xx x))
-    (prop-ref
-     xx
-     (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))))))
-
 (define-syntax-rule (mrefx-py x key l)
   (let ((xx x))
     (prop-ref
      xx
      (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)))
+	    (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))))))
-
-(define-syntax-rule (unx mrefx- mref-)
-  (define-syntax-rule (mref- x key l)
-    (let ((xx x))
-      (let ((res (mrefx- xx key l)))
-        (if (and (not (struct? res)) (procedure? res))
-            (res xx)
-            res)))))
-
-(unx mrefx-    mref-)
-(unx mrefx     mref)
-(unx mrefx-py  mref-py)
-(unx mrefx-py- mref-py-)
-
-(define-syntax-rule (unx mrefx- mref-)
-  (define-syntax-rule (mref- x key l)
-    (let ((xx x))
-      (let ((res (mrefx- xx key l)))
-        (if (and (not (struct? res))
-                 (not (pyclass? res))
-                 (procedure? res))
-            (res xx)
-            res)))))
-
-(unx mrefx-    mref-q)
-(unx mrefx     mrefq)
-(unx mrefx-py  mref-pyq)
-(unx mrefx-py- mref-py-q)
+	   (mrefx xx key l)
+	   (apply f xx key l))))))
+
+
+(define-syntax-rule (mref x key l)
+  (let ((xx x))
+    (let ((res (mrefx xx key l)))
+      (if (and (not (struct? res)) (procedure? res))
+	  (res xx)
+	  res)))))
+
+(define-syntax-rule (mref-py x key l)
+  (let ((xx x))
+    (let ((res (mrefx-py xx key l)))
+      (if (and (not (struct? res)) (procedure? res))
+	  (res xx)
+	  res)))))
 
 (define-method (ref x key . l) (if (pair? l) (car l) #f))
 (define-method (ref (x <pf> )  key . l) (mref     x key l))
-(define-method (ref (x <p>  )  key . l) (mref-    x key l))
+(define-method (ref (x <p>  )  key . l) (mref     x key l))
 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
-(define-method (ref (x <py> )  key . l) (mref-py- x key l))
+(define-method (ref (x <py> )  key . l) (mref-py  x key l))
 
-(define-method (refq (x <pf> )  key . l) (mrefq     x key l))
-(define-method (refq (x <p>  )  key . l) (mref-q    x key l))
-(define-method (refq (x <pyf>)  key . l) (mref-pyq  x key l))
-(define-method (refq (x <py> )  key . l) (mref-py-q x key l))
+(define-method (refq (x <pf> )  key . l) (mref     x key l))
+(define-method (refq (x <p>  )  key . l) (mref     x key l))
+(define-method (refq (x <pyf>)  key . l) (mref-py  x key l))
+(define-method (refq (x <py> )  key . l) (mref-py  x key l))
       
 ;; the reshape function that will create a fresh new pf object with less size
 ;; this is an expensive operation and will only be done when we now there is
@@ -271,7 +285,7 @@ explicitly tell it to not update etc.
     (values)))
 
 ;; on object x add a binding that key -> val
-(define-syntax-rule (mset x key val)
+(define--method (mset (x <pf) key val)
   (let ((h (slot-ref x 'h))
         (s (slot-ref x 'size))
         (n (slot-ref x 'n)))
@@ -284,56 +298,41 @@ explicitly tell it to not update etc.
         (reshape x))
       (values))))
 
-(define-syntax-rule (mset-py x key 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))))
-
 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 
-(define-syntax-rule (mset- x key val)
+(define-method (mset (x <p>) key val)
   (begin
     (hash-set! (slot-ref x 'h) key val)
     (values)))
 
-(define-syntax-rule (mset-py- x key val)
+(define-method (mset (x <pf>) key val)
+  (begin
+    (hash-set! (slot-ref x 'h) key val)
+    (values)))
+
+(define-syntax-rule (mset-py x key val)
   (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* ((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))))
+	(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)
@@ -347,9 +346,9 @@ explicitly tell it to not update etc.
       (mset a ... 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 <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))
+(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
@@ -363,14 +362,12 @@ explicitly tell it to not update etc.
     (apply (mref x key '()) l)))
 
 (mk-call mcall     mref)
-(mk-call mcall-    mref-)
 (mk-call mcall-py  mref-py)
-(mk-call mcall-py- mref-py-)
   
 (define-method (call (x <pf>)  key . l) (mcall     x key l))
-(define-method (call (x <p>)   key . l) (mcall-    x key l))
+(define-method (call (x <p>)   key . l) (mcall     x key l))
 (define-method (call (x <pyf>) key . l) (mcall-py  x key l))
-(define-method (call (x <py>)  key . l) (mcall-py- x key l))
+(define-method (call (x <py>)  key . l) (mcall-py  x key l))
 
 
 ;; make a copy of a pf object
@@ -449,7 +446,7 @@ explicitly tell it to not update etc.
 
 (define-method (fcall (x <p>) key . l)
   (let ((x (mcopy x)))
-    (values (mcall- x key l)
+    (values (mcall x key l)
             x)))
 
 ;; this shows how we can override addition in a pythonic way
@@ -720,32 +717,26 @@ explicitly tell it to not update etc.
 (define (object-method f)
   (letrec ((self
             (mark-fkn 'object
-                      (lambda (x)
-                        (aif it (pyclass? x)
-                             (if (eq? it 'super)
-                                 self
-                                 f)
-                             (lambda z (apply f x z)))))))
+                      (lambda (x kind)
+			(if (eq? kind 'object)
+			    f
+			    (lambda z (apply f x z)))))))
     self))
 
 (define (class-method f)
   (letrec ((self
             (mark-fkn 'class
-              (lambda (x)
-                (aif it (pyclass? x)
-                     (if (eq? it 'super)
-                         self
-                         (lambda z (apply f x z)))
-                     (lambda z (apply f (ref x '__class__) z)))))))
+              (lambda (x kind)
+		(if (eq? kind 'object)
+		    (let ((klass (ref x '__class__)))
+		      (lambda z (apply f klass z)))
+		    (lambda z (apply f x z)))))))
     self))
 
 (define (static-method f)
   (letrec ((self
             (mark-fkn 'static
-                      (lambda (x)
-                        (if (eq? (pyclass? x) 'super)
-                            self
-                            f)))))
+                      (lambda (x kind) f))))
     self))