small steps of meta and meta meta

1 files changed, 68 insertions, 56 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index a72d360..d5e9e5f 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -9,8 +9,9 @@
                 def-p-class   mk-p-class   make-p-class
                 define-python-class get-type py-class
                 object-method class-method static-method
-                py-super-mac py-super py-equal?
-                *class* *self*
+                py-super-mac py-super py-equal? 
+                *class* *self* type pyobject? pytype?
+                type object
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -51,28 +52,14 @@ explicitly tell it to not update etc.
       (hash-set! h '__class__ x)
       (slot-set! o 'h    h)))
    (else #f))
-   (values))
+  (values))
 
-(define-method (get-dict (self <pyf>) name parents)
+(define (get-dict self name parents)
   (aif it (ref self '__prepare__)
        (it self name parents)
-       (make (kwclass->class kw <pyf>))))
-
-(define-method (get-dict (self <py>) name parents)
-  (aif it (ref self '__prepare__)
-       (it self name parents)
-       (make (kwclass->class kw <py>))))
-
-(define-method (get-dict (self <pf>) name parents)
-  (aif it (ref self '__prepare__)
-       (it self name parents)
-       (make (kwclass->class kw <pf>))))
-
-(define-method (get-dict (self <p>) name parents)
-  (aif it (ref self '__prepare__)
-       (it self name parents)
-       (make (kwclass->class kw <p>))))
+       (make-hash-table)))
 
+(define (hashforeach a b) (values))
 
 (define (new-class meta name parents dict keys)
   (aif it (ref self '__new__)
@@ -82,44 +69,35 @@ explicitly tell it to not update etc.
               (class (make p)))
 	 (slot-set! class 'procedure
                     (lambda x
-                      (create-object class meta goops x)))         
-         (cond
-          ((eq? p <pf>)
-           (cond
-            ((is-a? dict <pf>)
-             (slot-set! class 'h    (slot-ref dict 'h))
-             (slot-set! class 'n    (slot-ref dict 'n))
-             (slot-set! class 'size (slot-ref dict 'size)))
-            (else
-             (error "funtional class creation needs functional dicts"))))
-          
-          ((eq? p <p>)
-           (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)))))
-
-         (let lp ((ps parents))
-           (if (pair? ps)
-               (let ((p (car ps)))
+                      (create-object class meta goops x)))
+         (set class '__class__ meta)
+         (if (hashtable? dict)
+             (hash-for-each
+              (lambda (k v) (set class k v))
+              dict)
+             (hashforeach
+              (lambda (k v) (set class k v))
+              dict))
+         (let((mro (ref class '__mro__)))
+           (if (pair? mro)
+               (let ((p (car mro)))
                  (aif it (ref p '__init_subclass__)
                       (apply it class #f keys)
-                      #f)
-                 (lp (cdr ps)))))         
+                      #f))))
          class)))
 
+(define (type- meta name parents dict keys)
+  (let ((class (new-class meta name parents dict keys)))
+    (aif it (ref meta '__init__)
+         (it name parents dict keys)
+         #f)
+    class))
+
 (define (create-class meta name parents gen-methods . keys)
   (let ((dict (gen-methods (get-dict meta name keys))))
-    (aif it (ref (ref meta '__class__) '__call__)
-         (apply it name parents dict keys)
-         (let ((class (new-class meta name parents dict keys)))
-           (aif it (ref meta '__init__)
-                (it name parents dict keys)
-                #f)
-           class))))
+    (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+         (apply (it meta 'object) name parents dict keys)
+         (type- meta name parents dict keys))))
 
 (define (create-object class meta goops x)
   (aif it (ref meta '__call__)
@@ -616,9 +594,8 @@ explicitly tell it to not update etc.
           (make-p-class name
                         parents
                         (lambda (dict)
-                          (let ((d (make-pf class)))
-                            (set d 'dname dname) (... ...)
-                            d))))
+                          (hash-set! d 'dname dname) (... ...)))))
+                          
         
       name)))
 
@@ -681,8 +658,25 @@ explicitly tell it to not update etc.
                    #f)))
        #f))
 
+(define (pyobject? x)
+  (and (is-a? x <p>)
+       (if (is-a? x type)
+           #f
+           (if it (ref x '__class__)
+               (if (is-a? it type)
+                   #f
+                   #t)))
+       #f))
+
+(define (pytype? x)
+  (and (is-a? x <p>)
+       (if (is-a? x type)
+           #t
+           #f)
+       #f))
+
 (define-method (py-class (o <p>))
-  (ref o '__class__ 'type))
+  (ref o '__class__ type))
 
 (define (mark-fkn tag f)
   (set-procedure-property! f 'py-special tag)
@@ -872,3 +866,21 @@ explicitly tell it to not update etc.
 (define-method (py-equal? x y) ((@ (guile) equal?) x y))
 
 (define (equal? x y) (or (eq? x y) (py-equal? x y)))
+
+(define type 'type)
+(define-python-class type ()
+  (define __call__
+    (case-lambda
+      ((self obj)
+       (if (is-a? obj type)
+           obj
+           (let ((r (ref obj '__class__)))
+             (if (is-a? r type)
+                 r
+                 (ref r '__class__)))))
+      ((self name bases dict . keys)
+       (type- meta name parents dict keys)))))
+
+(set type '__class__ type)
+
+(define-python-class object ())