refactoring functional objects

7 files changed, 293 insertions, 256 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index a040c7d..10320f5 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -407,7 +407,7 @@
        '()))))
 
 (define (kw->li dict)
-  (for ((k v : dict) (l '()))
+  (for ((k v : dict)) ((l '()))
     (cons* v (symbol->keyword (string->symbol k)) l)
     #:final
     (reverse l)))
@@ -528,12 +528,12 @@
                    `(,s/d ,v (,(C 'setwrap) ,u)))
                (if op
                    `(,s/d ,(exp vs kind)
-                           (,(O 'fset-x) ,v (list ,@(map q addings))
+                           (,(C 'fset-x) ,v ,addings
                             (,(C 'setwrap)
                              (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
                      
                    `(,s/d ,(exp vs kind)
-                          (,(O 'fset-x) ,v (list ,@(map q addings))
+                          (,(C 'fset-x) ,v ,addings
                            (,(C 'setwrap) ,u)))))
            
            (if (null? addings)
@@ -757,26 +757,24 @@
                           r))
                (class   (exp vs class))
                (parents (match parents
-                          (()
-                           (cons '() '()))
-                          (#f
-                           (cons '() '()))
+                          (() #f)
+                          (#f #f)
                           ((#:arglist . _)
-                           (get-addings vs (list parents)))))
-               (is-func (is-functional parents))
-               (parents (filt parents)))
+                           (get-addings vs (list parents))))))
           `(define ,class
              (,(C 'class-decor) ,decor
               (,(C 'with-class) ,class
-               (,(mk-p-class
-                ,class
-                (,(C 'ref-x) ,(C 'arglist->pkw) ,@parents)
+               (,(C 'mk-p-class)
+                ,class                
+                ,(if parents
+                     `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents)
+                     `(,(G 'cons) '() '()))
                 ,@(match (filter-defs (exp vs defs))
                     (('begin . l)
                      l)
                     ((('begin . l))
                      l)
-                    (l l))))))))))))
+                    (l l)))))))))))
 
  (#:scm
   ((_ (#:string _ s)) (with-input-from-string s read)))
@@ -1702,9 +1700,9 @@
     ((_ v (#:fast-id f _) . l)
      (ref-x (f v) . l))
     ((_ v (#:identifier x) . l)
-     (ref-x (refq v x) . l))
+     (ref-x (ref v x) . l))
     ((_ v (#:identifier x) . l)
-     (ref-x (refq v x) . l))
+     (ref-x (ref v x) . l))
     ((_ v (#:call-obj x) . l)
      (ref-x (x v) . l))
     ((_ v (#:call x ...) . l)
@@ -1721,7 +1719,7 @@
 (define-syntax del-x
   (syntax-rules ()
     ((_ v (#:identifier x))
-     (ref-x (refq v 'x)))
+     (ref-x (ref v 'x)))
     ((_ v (#:call-obj x))
      (values))
     ((_ v (#:call x ...))
@@ -1738,6 +1736,11 @@
     ((_ v (a ... b) val)
      (set-x-2 (ref-x v a ...) b val))))
 
+(define-syntax fset-x
+  (syntax-rules ()
+    ((_ v ((#:identifier x) ...) val)
+     ((@ (oop pf-objects) fset-x) v (list x ...) val))))
+
 (define-syntax set-x-2
   (syntax-rules ()
     ((_ v (#:fastfkn-ref f id) val)
@@ -1775,3 +1778,4 @@
   (syntax-rules ()
     ((_ s c)
      (syntax-parameterize ((*class* (lambda (x) #'s))) c))))
+
diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm
index 30e47ac..da07642 100644
--- a/modules/language/python/dir.scm
+++ b/modules/language/python/dir.scm
@@ -15,23 +15,24 @@
 
 (define-method (dir) (pylist))
 
-(define (get-from-class c f)
-  (let lp ((c c))    
-    (hash-for-each f (slot-ref c 'h))
-    (let lpp ((pl (ref c '__parents__)))
-      (if (pair? pl)
-          (begin
-            (lp (car pl))
-            (lpp (cdr pl)))))))
+(define (chash-for-each f c)
+  (let ((h (slot-ref c 'h)))
+  (if (is-a? c <pf>)
+      (let ((hh (make-hash-table)))
+        (vhash-fold
+         (lambda (k v s)
+           (when (not (hash-ref hh k))
+             (hash-set! hh k #t)
+             (f k v))
+           s) #f h))
+      (hash-for-each f h))))
 
-(define (get-from-class-f c f)
-  (let lp ((c c))
-    (vhash-fold f 0 (slot-ref c 'h))
-    (let lpp ((pl (ref c '__parents__)))
-      (if (pair? pl)
-          (begin
-            (lp (car pl))
-            (lpp (cdr pl)))))))
+(define (get-from-class c f)
+  (let lp ((pl (ref c '__mro__)))
+    (if (pair? pl)
+        (begin
+          (chash-for-each f (car pl))
+          (lp (cdr pl))))))
 
 (define-method (dir (o <p>))
   (if (not (pyclass? o))
@@ -47,7 +48,7 @@
                        (c (ref o '__class__))
                        (l '())
                        (f (lambda (k v) (set! l (cons k l)))))
-                  (hash-for-each f (slot-ref o 'h))
+                  (chash-for-each f o)
                   (get-from-class c f)
                   (hash-for-each (lambda (k v) (pylist-append! l k)) h)
                   (to-pylist (map symbol->string (sort l <))))))
@@ -59,32 +60,6 @@
         (hash-for-each (lambda (k v) (set! l (cons k l))) h)
         (to-pylist (map symbol->string (sort l <))))))
 
-(define-method (dir (o <pf>))
-  (if (not (pyclass? o))
-      (aif it (ref o '__dir__)
-           (it)
-           (aif it (ref o '__dict__)
-                (let ((l (pylist)))
-                  (for ((k v : it)) ()
-                       (pylist-append! l k))
-                  (pylist-sort! l)
-                  l)
-                (let* ((h (make-hash-table))
-                       (c (ref o '__class__))
-                       (l '())
-                       (f (lambda (k v s) (set! l (cons k l)))))
-                  (vhash-fold f 0 (slot-ref o 'h))
-                  (get-from-class-f c f)
-                  (hash-for-each (lambda (k v) (pylist-append! l k)) h)
-                  (to-pylist (map symbol->string (sort l <))))))      
-      (let* ((h (make-hash-table))
-             (c o)
-             (l '())
-             (f (lambda (k v s) (pylist-append! h k #t))))
-        (get-from-class-f c f)
-        (hash-for-each (lambda (k v) (set! l (cons k l))) h)
-        (to-pylist (map symbol->string (sort l <))))))
-
 (define-method (dir (o <py-list>))
   (let ((l1 (pk (pylist-listing))))
     (if (is-a? o <p>)
@@ -172,6 +147,16 @@
     (let ((ret (to-pylist l)))
       (pylist-sort! ret)
       ret)))
-  
+
+(define-method (dir (o <procedure>))
+  (let ((ret (to-pylist (map (lambda (x)
+                               (let ((x (car x)))
+                                 (if (symbol? x)
+                                     (symbol->string x)
+                                     x)))
+                             (procedure-properties o)))))
+    (pylist-sort! ret)
+    ret))
+
                   
                           
diff --git a/modules/language/python/eval.scm b/modules/language/python/eval.scm
index 999acc0..53b4bce 100644
--- a/modules/language/python/eval.scm
+++ b/modules/language/python/eval.scm
@@ -1,5 +1,4 @@
 (define-module (language python eval)
-  #:use-module 
   #:use-module (parser stis-parser lang python3-parser)
   #:use-module (language python exceptions)
   #:use-module ((ice-9 local-eval) #:select ((the-environment . locals)))
diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm
index ded6b15..34c9ba0 100644
--- a/modules/language/python/list.scm
+++ b/modules/language/python/list.scm
@@ -11,7 +11,7 @@
   #:use-module (language python try)
   #:use-module (language python exceptions)
   #:export (to-list to-pylist <py-list> 
-            pylist-ref pylist-set! pylist-append!
+            pylist-append!
             pylist-slice pylist-subset! pylist-reverse!
             pylist-pop! pylist-count pylist-extend! len in
             pylist-insert! pylist-remove! pylist-sort!
@@ -822,11 +822,11 @@
   (let ((n1 (len o1))
         (n2 (len o2)))
     (for ((x1 : o1) (x2 : o2)) ()
-      (if (> x1 x2)
-          (break #t))
-      #:final
-      (>= n1 n2))))
-          
+         (if (> x1 x2)
+             (break #t))
+         #:final
+         (>= n1 n2))))
+
 (define-python-class list (<py-list>)
   (define  __init__
     (letrec ((__init__
diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm
index bd68841..02f4e5e 100644
--- a/modules/language/python/module/python.scm
+++ b/modules/language/python/module/python.scm
@@ -3,8 +3,8 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 readline)
   #:use-module ((oop pf-objects) #:select
-                (<p> <property> class-method static-method refq
-                     py-super-mac))
+                (<p> <property> class-method static-method ref
+                     py-super-mac type object pylist-ref))
   #:use-module (language python exceptions       )
   #:use-module (language python def              )
   #:use-module (language python for              )
@@ -35,7 +35,7 @@
                              SyntaxError
                              len dir next dict None property range
                              tuple bytes bytearray eval locals globals
-                             compile exec type
+                             compile exec type object
                              )
   
   #:export (print repr complex float int
@@ -76,7 +76,7 @@
 (define-method (callable (x <applicable>       )) #t)
 (define-method (callable (x <primitive-generic>)) #t)
 (define-method (callable (x <p>))
-  (refq x '__call__))
+  (ref x '__call__))
                             
 (define chr integer->char)
   
@@ -100,17 +100,17 @@
 (define miss ((@ (guile) list) 'miss))
 
 (define* (getattr a b #:optional (k miss))
-  (let ((r (refq a (symbol->string b) k)))
+  (let ((r (ref a (symbol->string b) k)))
     (if (eq? r miss)
         (raise AttributeError "object/class ~a is missing attribute ~a" a b)
         r)))
 
 (define (hasattr a b)
-  (let ((r (refq a (symbol->string b) miss)))
+  (let ((r (ref a (symbol->string b) miss)))
     (not (eq? r miss))))
 
 (define-method (issubclass (sub <p>) (cls <p>))
-  (aif it (ref cl '__subclasscheck__)
+  (aif it (ref cls '__subclasscheck__)
        (it sub)
        (is-a? (ref sub '__goops__) (ref cls '__goops__))))
 
@@ -121,13 +121,13 @@
            (or
             (isinstance o (car cl))
             (isinstance o (cdr cl)))
-           (is-a? (ref (ref o '__class__) '__goops__) cl)))
+           (is-a? (ref (ref o '__class__) '__goops__) cl))))
 
 (define iter
   (case-lambda
     ((o) (aif it (wrap-in o)
               it
-              (aif get (refq o '__getitem__)
+              (aif get (ref o '__getitem__)
                    (make-generator iter
                                    (lambda (yield)
                                      (for () ((i 0))
diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm
index ef4abe7..e9d7c63 100644
--- a/modules/language/python/set.scm
+++ b/modules/language/python/set.scm
@@ -23,7 +23,7 @@
          (slot-set! self 'dict d)
 	 (for ((y : x)) ()
 	      (pylist-set! d y #t))))))
-  
+
   (define pop
     (lambda (self)
       (call-with-values (lambda () (pylist-pop! (slot-ref self 'dict)))
@@ -32,7 +32,7 @@
   (define  add
     (lambda (self k)
       (pylist-set! (slot-ref self 'dict) k #t)))
-  
+
   (define copy
     (lambda (self)
       (let ((dict (py-copy (slot-ref self 'dict))))
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index d5e9e5f..86ffd20 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -3,15 +3,15 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:replace (equal?)
-  #:export (set ref make-pf <p> <py> <pf> <pyf> <property>
-                call with copy fset fcall make-p put put!
-                pcall pcall! get fset-x pyclass? refq                
+  #:export (set ref make-p <p> <py> <pf> <pyf> <property>
+                call with copy fset fcall put put!
+                pcall pcall! get fset-x pyclass?                
                 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* type pyobject? pytype?
-                type object
+                *class* *self* pyobject? pytype?
+                type object pylist-set! pylist-ref
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -27,8 +27,26 @@ The datastructure is functional but the objects mutate. So one need to
 explicitly tell it to not update etc.
 |#
 
+(define fail (cons 'fail '()))
+
+(define-syntax-rule (kif it p x y)
+  (let ((it p))
+    (if (eq? it fail)
+	y
+	x)))
+
+(define-method (pylist-set! (o <hashtable>) key val)
+  (hash-set! o key val))
+
+(define-method (pylist-ref (o <hashtable>) key)
+  (kif it (hash-ref o key fail)
+       it
+       (error "IndexError")))
+
+(define (is-acl? a b) (member a (cons b (class-subclasses b))))
+
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
-(define-class <p>  (<applicable-struct>) h)
+(define-class <p>  (<applicable-struct> <object>) h)
 (define-class <pf> (<p>) size n)         ; the pf object consist of a functional
                                          ; hashmap it's size and number of live
                                          ; object
@@ -37,23 +55,6 @@ explicitly tell it to not update etc.
 
 (define-class <property> () get set del)
 
-(define (mk-p/pf o)
-  (cond
-   ((is-a? x <pf>)
-    (let ((r (ref x '__const__)))
-      (slot-set! o 'h    (slot-ref r 'h))
-      (slot-set! o 'size (slot-ref r 'size))
-      (slot-set! o 'n    (slot-ref r 'n))
-      o))
-     
-   ((is-a? x <p>)
-    (let ((r (ref x '__const__))
-          (h (make-hash-table)))        
-      (hash-set! h '__class__ x)
-      (slot-set! o 'h    h)))
-   (else #f))
-  (values))
-
 (define (get-dict self name parents)
   (aif it (ref self '__prepare__)
        (it self name parents)
@@ -61,17 +62,16 @@ explicitly tell it to not update etc.
 
 (define (hashforeach a b) (values))
 
-(define (new-class meta name parents dict keys)
-  (aif it (ref self '__new__)
-       (apply it name parents dict keys)
-       (let* ((goops (ref dict '__goops__))
-              (p     (kwclass->class kw meta))  
-              (class (make p)))
+(define (new-class meta name parents dict kw)
+  (aif it (ref meta '__new__)
+       (apply it name parents dict kw)
+       (let* ((goops (pylist-ref dict '__goops__))
+              (p     (kwclass->class kw meta))
+              (class (make-p p)))
 	 (slot-set! class 'procedure
                     (lambda x
                       (create-object class meta goops x)))
-         (set class '__class__ meta)
-         (if (hashtable? dict)
+         (if (hash-table? dict)
              (hash-for-each
               (lambda (k v) (set class k v))
               dict)
@@ -82,8 +82,9 @@ explicitly tell it to not update etc.
            (if (pair? mro)
                (let ((p (car mro)))
                  (aif it (ref p '__init_subclass__)
-                      (apply it class #f keys)
+                      (apply it class #f kw)
                       #f))))
+         (set class '__mro__ (cons class (ref class '__mro__)))
          class)))
 
 (define (type- meta name parents dict keys)
@@ -95,20 +96,22 @@ explicitly tell it to not update etc.
 
 (define (create-class meta name parents gen-methods . keys)
   (let ((dict (gen-methods (get-dict meta name keys))))
-    (aif it (find-in-class (ref meta '__class__) '__call__ #f)
-         (apply (it meta 'object) name parents dict keys)
+    (aif it (ref meta '__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))
          (type- meta name parents dict keys))))
 
 (define (create-object class meta goops x)
-  (aif it (ref meta '__call__)
+  (aif it #f ;(ref meta '__call__)
        (apply it x)       
-       (let ((obj (aif it (ref class __new__)
-                       (it)
+       (let ((obj (aif it (find-in-class class '__new__ #f)
+                       ((it class 'object))
                        (make-object class meta goops))))
          (aif it (ref obj '__init__)
               (apply it x)
               #f)
-         (slot-set! 'procedure
+         (slot-set! obj 'procedure
                     (lambda x
                       (aif it (ref obj '__call__)
                            (apply it x)
@@ -116,26 +119,25 @@ explicitly tell it to not update etc.
          obj)))
 
 (define (make-object class meta goops)
-  (let ((obj (make goops)))
-    (mk-p/pf obj)
+  (let ((obj (make-p goops)))
     (set obj '__class__ class)
     obj))
 
-
-    
-  
 ;; Make an empty pf object
-(define* (make-pf #:optional (class <pf>))
-  (define r (make-pyclass class))
-  (slot-set! r 'h vlist-null)
-  (slot-set! r 'size 0)
-  (slot-set! r 'n 0)
-  r)
-
-(define* (make-p #:optional (class <p>))
-  (define r (make-pyclass class))
-  (slot-set! r 'h (make-hash-table))
-  r)
+(define (make-p <x>)
+  (let ((r (make <x>)))
+    (cond
+     ((is-a? r <pf>)
+      (slot-set! r 'h vlist-null)
+      (slot-set! r 'size 0)
+      (slot-set! r 'n 0))
+     ((is-a? r <p>)
+      (slot-set! r 'h (make-hash-table)))
+     (else
+      (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
+             r)))
+    r))
+
 
 (define-syntax-rule (hif it (k h) x y)
   (let ((a (vhash-assq k h)))
@@ -152,7 +154,6 @@ explicitly tell it to not update etc.
           x)
         y)))
 
-(define fail (cons 'fail '()))
 (define-syntax-rule (mrefx x key l)
   (let ()
     (define (end)
@@ -184,25 +185,19 @@ explicitly tell it to not update etc.
 
 (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)
+       (aif parents (find-in-class klass '__mro__ #f)
 	    (let lp ((parents parents))
 	      (if (pair? parents)
 		  (kif r (find-in-class (car parents) key fail)
@@ -219,7 +214,7 @@ explicitly tell it to not update etc.
 	 it
 	 (begin
 	   (fluid-set! *refkind* 'class)
-	   (aif klass (hash-ref h '__class__)
+	   (aif klass (find-in-class klass '__class__ #f)
 		(kif it (find-in-class-and-parents klass key fail)
 		     it
 		     (end))
@@ -241,7 +236,7 @@ explicitly tell it to not update etc.
      (let* ((g (mrefx xx '__fget__ '(#t)))
 	    (f (if g
 		   (if (eq? g #t)
-		       (aif it (mrefx- xx '__getattribute__ '())
+		       (aif it (mrefx xx '__getattribute__ '())
 			    (begin
 			      (set xx '__fget__ it)
 			      it)
@@ -260,14 +255,14 @@ explicitly tell it to not update etc.
     (let ((res (mrefx xx key l)))
       (if (and (not (struct? res)) (procedure? res))
 	  (res xx)
-	  res)))))
+	  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)))))
+	  res))))
 
 (define-method (ref x key . l) (if (pair? l) (car l) #f))
 (define-method (ref (x <pf> )  key . l) (mref     x key l))
@@ -275,11 +270,15 @@ explicitly tell it to not update etc.
 (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 (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))
-      
+(define-method (set (f <procedure>) key val)
+  (set-procedure-property! f key val))
+
+(define-method (ref (f <procedure>) key . l)
+  (aif it (assoc key (procedure-properties f))
+       (cdr it)
+       (if (pair? l) (car l) #f)))
+
+
 ;; 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
 ;; a lot to gain essentially tho complexity is as in the number of set
@@ -302,15 +301,15 @@ explicitly tell it to not update etc.
     (values)))
 
 ;; on object x add a binding that key -> val
-(define--method (mset (x <pf) 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)))
     (slot-set! x 'size (+ 1 s))
-    (let ((r (vhash-assq key h)))
+    (let ((r (vhash-assoc key h)))
       (when (not r)
         (slot-set! x 'n (+ n 1)))
-      (slot-set! x 'h (vhash-consq key val h))
+      (slot-set! x 'h (vhash-cons key val h))
       (when (> s (* 2 n))
         (reshape x))
       (values))))
@@ -322,19 +321,13 @@ explicitly tell it to not update etc.
     (hash-set! (slot-ref x 'h) key val)
     (values)))
 
-(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)))
+  (let* ((v (mref x key (list 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__ '())
+			  (let ((class (aif it (mref x '__class__ '())
 					    it
 					    x)))
 			    (aif it (mrefx x '__setattr__ '())
@@ -389,14 +382,14 @@ explicitly tell it to not update etc.
 
 ;; make a copy of a pf object
 (define-syntax-rule (mcopy x)
-  (let ((r (make-pyclass <pf>)))
+  (let ((r (make-p (pk (ref (pk x) '__goops__)))))
     (slot-set! r 'h (slot-ref x 'h))
     (slot-set! r 'size (slot-ref x 'size))
     (slot-set! r 'n (slot-ref x 'n))
     r))
 
 (define-syntax-rule (mcopy- x)
-  (let* ((r (make-p))
+  (let* ((r (make-p (ref x '__goops__)))
          (h (slot-ref r 'h)))
     (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
     r))
@@ -508,7 +501,7 @@ explicitly tell it to not update etc.
 
 ;; it's good to have a null object so we don't need to construct it all the
 ;; time because it is functional we can get away with this.
-(define null (make-pf))
+(define null (make-p <pf>))
 
 (define (filter-parents l)
   (let lp ((l l))
@@ -518,14 +511,44 @@ explicitly tell it to not update etc.
             (lp (cdr l)))
         '())))
 
-(define (kw->class kw)
+(define (kw->class kw meta)
   (if (memq #:functional kw)
       (if (memq #:fast kw)
           <pf>
-          <pyf>)
+          (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
+              <pyf>
+              <pf>))              
       (if (memq #:fast kw)
-          <p>
-          <py>)))
+          (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
+              <pf>
+              <p>)
+          (cond
+           ((is-a? meta <pyf>)
+            <pyf>)
+           ((is-a? meta <py>)
+            <py>)
+           ((is-a? meta <pf>)
+            <pf>)
+           ((is-a? meta <p>)
+            <p>)
+           (else
+            <py>)))))
+           
+
+(define (defaulter d)
+  (if d
+      (cond
+       ((is-a? d <pyf>)
+        <pyf>)
+       ((is-a? d <py>)
+        <py>)
+       ((is-a? d <pf>)
+        <pf>)
+       ((is-a? d <p>)
+        <p>)
+       (else
+        d))
+      <py>))
 
 (define (kwclass->class kw default)
   (if (memq #:functionalClass kw)
@@ -533,7 +556,7 @@ explicitly tell it to not update etc.
           <pf>
           (if (memq #:pyClass kw)
               <pyf>
-              (if (or (is-a default <py>) (is-a default <pyf>))
+              (if (or (is-a? default <py>) (is-a? default <pyf>))
                   <pyf>
                   <pf>)))
       (if (memq #:mutatingClass kw)
@@ -541,42 +564,77 @@ explicitly tell it to not update etc.
               <p>
               (if (memq #:pyClass kw)
                   <py>
-                  (if (or (is-a default <py>) (is-a default <pyf>))
+                  (if (or (is-a? default <py>) (is-a? default <pyf>))
                       <py>
                       <p>)))
           (if (memq #:fastClass kw)
-              (if (or (is-a default <pf>) (is-a default <pyf>))
+              (if (or (is-a? default <pf>) (is-a? default <pyf>))
                   <pf>
                   <p>)
               (if (memq #:pyClass kw)
-                  (if (or (is-a default <pf>) (is-a default <pyf>))
+                  (if (or (is-a? default <pf>) (is-a? default <pyf>))
                       <pyf>
                       <py>)
-                  default)))))
-  
-(define (make-p-class name supers methods kw)
+                  (defaulter default))))))
+
+(define object #f)
+(define (make-p-class name supers.kw methods)
+  (define kw      (cdr supers.kw))
+  (define supers  (car supers.kw))
   (define goopses (map (lambda (sups)
                          (aif it (ref sups '__goops__ #f)
                               it
                               sups)
                          sups)
                        supers))
+  (define parents (let ((p (filter-parents supers)))
+                    (if (null? p)
+                        (if object
+                            (list object)
+                            '())
+                        p)))
   
-  (define goops (make-class
-                 (append goopses
-                         (list (kw->class kw)))))
+  (define meta (aif it (memq #:metaclass kw)
+                    (car it)
+                    (if (null? parents)
+                        type
+                        (let* ((p   (car parents))
+                               (m   (ref p '__class__))
+                               (mro (reverse (ref m '__mro__))))
+                          (let lp ((l   (cdr parents))
+                                   (max mro)
+                                   (min mro))
+                            (if (pair? l)
+                                (let* ((p    (car l))
+                                       (meta (ref p '__class__))
+                                       (mro  (ref meta '__mro__)))
+                                  (let lp2 ((max max) (mr (reverse mro)))
+                                    (if (and (pair? max) (pair? mr))
+                                        (if (eq? (car max) (car mr))
+                                            (lp2 (cdr max) (cdr mr))
+                                            (error
+                                             "need a common lead for meta"))
+                                        (if (pair? max)
+                                            (if (< (length mro) (length min))
+                                                (lp (cdr l) max mro)
+                                                (lp (cdr l) max min))
+                                            (lp (cdr l) mro min)))))
+                                (car (reverse min))))))))
+  
+  (define goops   (make-class (append goopses (list (kw->class kw meta)))
+                              '() #:name name))
     
-  (define parents (filter-parents supers))
-  (define meta (aif it (memqq #:metaclass kw) (car it) type))
-  (define (gen-methods dict)   
-    (dynamic dict)
-    (set dict '__goops__   goops)
-    (set dict '__class__   meta)
-    (set dict '__fget__    #t)
-    (set dict '__fset__    #t)
-    (set dict '__name__    name)
-    (set dict '__parents__ parents)
-    (set dict '__mro__     (get-mro class)))
+  (define (gen-methods dict)
+    (method dict)
+    (pylist-set! dict '__goops__   goops)
+    (pylist-set! dict '__class__   meta)
+    (pylist-set! dict '__fget__    #t)
+    (pylist-set! dict '__fset__    #t)
+    (pylist-set! dict '__name__    name)
+    (pylist-set! dict '__parents__ parents)
+    (pylist-set! dict '__class__   meta)
+    (pylist-set! dict '__mro__     (get-mro parents))
+    dict)
   (create-class meta name parents gen-methods kw))
 
 
@@ -585,19 +643,20 @@ explicitly tell it to not update etc.
 ;; the make class and defclass syntactic sugar
 (define-syntax-rule (mk-p-class name
                                  parents
-                                (kw      ...)
-                                (ddef dname dval)
+                                 (ddef dname dval)
                                 ...)
     (let ()
       (define name 
-        (letruc ((dname dval) (... ...))
-          (make-p-class name
-                        parents
-                        (lambda (dict)
-                          (hash-set! d 'dname dname) (... ...)))))
+        (letruc ((dname dval) ...)
+           (make-p-class 'name
+                         parents
+                         (lambda (dict)
+                           (pylist-set! dict 'dname dname)
+                           ...
+                           (values)))))
                           
         
-      name)))
+      name))
 
 (define-syntax-rule (def-p-class name . l)
   (define name (mk-p-class name . l)))
@@ -623,15 +682,20 @@ explicitly tell it to not update etc.
     'none)))
 
 (define (print o l)
-  (define p1 (if (pyclass? o) "C" "O"))
-  (define p2 (if (pyclass? o) "C" "O"))
+  (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
   (define port (if (pair? l) (car l) #t))
   (format port "~a"
-          (aif it (if (pyclass? o) #f (ref o '__repr__ #f))
+          (aif it (if (pyclass? o)
+                      #f
+                      (if (pyobject? o)
+                          (ref o '__repr__)
+                          #f))
                (format
-                #f "~a(~a)<~a>" p1 (get-type o) (it))
+                #f "~a(~a)<~a>"
+                p (get-type o) (it))
                (format
-                #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
+                #f "~a(~a)<~a>"
+                p (get-type o) (ref o '__name__ 'Annonymous)))))
 
 (define-method (write   (o <p>) . l) (print o l))
 (define-method (display (o <p>) . l) (print o l))
@@ -646,37 +710,22 @@ explicitly tell it to not update etc.
         (cons (reverse l) '()))))
 
 (define-syntax-rule (define-python-class name (parents ...) code ...)
-  (define name (mk-py-class name (arglist->pkw (list parents ...)) code ...)))
+  (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
 
-(define (pyclass? x)
-  (and (is-a? x <p>)
-       (if (is-a? x type)
-           #f
-           (if it (ref x '__class__)
-               (if (is-a? it type)
-                   #t
-                   #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)
+(define-syntax-rule (make-python-class name (parents ...) code ...)
+  (mk-p-class name (arglist->pkw (list parents ...)) code ...))
+
+(define (kind x)
   (and (is-a? x <p>)
-       (if (is-a? x type)
-           #t
-           #f)
-       #f))
+       (aif it (find-in-class x '__goops__ #f)
+            (if (is-a? (make it) (ref type '__goops__))
+                'type
+                'class)
+            'object)))
 
-(define-method (py-class (o <p>))
-  (ref o '__class__ type))
+(define (pyobject? x) (eq? (kind x) 'object))
+(define (pyclass?  x) (eq? (kind x) 'class))
+(define (pytype?   x) (eq? (kind x) 'type))
 
 (define (mark-fkn tag f)
   (set-procedure-property! f 'py-special tag)
@@ -718,8 +767,8 @@ explicitly tell it to not update etc.
 (define (not-a-super) 'not-a-super)
 (define (py-super class obj)
   (define (make cl parents)
-    (let ((c (make-p))
-          (o (make-p)))
+    (let ((c (make-p <p>))
+          (o (make-p <p>)))
       (set c '__super__        #t)
       (set c '__mro__       parents)
       (set c '__getattribute__  (lambda (self key . l)
@@ -842,16 +891,21 @@ explicitly tell it to not update etc.
 	    (find-tree o (nxt tree))))
       #f))
 
-(define (get-mro class)
-  (define tree (mk-tree (class-to-tree class)))
+(define (get-mro parents)
+  (if (null? parents)
+      parents
+      (get-mro0 parents)))
+
+(define (get-mro0 parents)  
+  (define tree (mk-tree parents))
   (let lp ((tree tree) (r '()))
     (if tree
-	(let ((x (tree-ref tree))
-	      (n (nxt tree)))
-	  (if (find-tree x n)
-	      (lp n r)
-	      (lp n (cons x r))))
-	(reverse r))))
+        (let ((x (tree-ref tree))
+              (n (nxt tree)))
+          (if (find-tree x n)
+              (lp n r)
+              (lp n (cons x r))))
+        (reverse r))))
 
 (define-method (py-equal? (x <p>)  y)
   (aif it (ref x '__eq__)
@@ -867,20 +921,15 @@ explicitly tell it to not update etc.
 
 (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)))))
-
+(define type #f)
+(set! type
+      (make-python-class type ()
+        (define __call__
+          (case-lambda
+            ((meta obj)
+             (ref obj '__class__ 'None))
+            ((meta name bases dict . keys)
+             (type- meta name bases dict keys))))))
 (set type '__class__ type)
 
-(define-python-class object ())
+(set! object (make-python-class object ()))