refactoring object system
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Oct 2017 14:24:10 +0000 (16:24 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 18 Oct 2017 14:24:10 +0000 (16:24 +0200)
modules/oop/pf-objects.scm

index 13edec89cbdc6b7b8fb9d18c4833adc79bff5ce0..f7680271b5f7504e85cadd48d3123952a5753c0f 100644 (file)
@@ -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))