python repo install

1 files changed, 1072 insertions, 0 deletions

diff --git a/modules/oop/pf-objects.scm.bak b/modules/oop/pf-objects.scm.bak
new file mode 100644
index 0000000..8946c59
--- /dev/null
+++ b/modules/oop/pf-objects.scm.bak
@@ -0,0 +1,1072 @@
+(define-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+<<<<<<< HEAD
+  #:use-module (system base message)
+  #:use-module (language python guilemod)
+=======
+  #:use-module (ice-9 pretty-print)
+>>>>>>> d71244f5cb87a4a61a6b341e4838a38e50142815
+  #:use-module (logic guile-log persistance)
+  #:replace (equal?)  
+  #: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* pyobject? pytype?
+                type object pylist-set! pylist-ref tr
+		resolve-method rawref rawset
+                ))
+
+#|
+Python object system is basically syntactic suger otop of a hashmap and one
+this project is inspired by the python object system and what it measn when
+one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
+with assocs or tree like functional hashmaps in stead.
+
+The hashmap works like an assoc e.g. we will define new values by 'consing' a
+new binding on the list and when the assoc take up too much space it will be
+reshaped and all extra bindings will be removed.
+
+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> <object>) h)
+(define-class <pf> (<p>) size n)         ; the pf object consist of a functional
+                                         ; hashmap it's size and number of live
+                                         ; object
+(define-class <py>  (<p>))
+(define-class <pyf> (<pf>))
+
+(define-class <property> () get set del)
+
+(name-object <p>)
+(name-object <pf>)
+(name-object <py>)
+(name-object <pyf>)
+(name-object <property>)
+
+(define (resolve-method-g g pattern)
+  (define (mmatch p pp)
+    (if (eq? pp '_)
+	'()
+	(match (cons p pp)
+	  (((p . ps) . (pp . pps))
+	   (if (eq? pp '_)
+	       (mmatch ps pps)
+	       (if (is-a? p pp)
+		   (cons p (mmatch ps pps))
+		   #f)))
+	  ((() . ())
+	   '())
+	  (_
+	   #f))))
+
+  (define (q< x y)
+    (let lp ((x x) (y y))
+      (match (cons x y)
+	(((x . xs) . (y . ys))
+	 (and (is-a? x y)
+	      (lp xs ys)))
+	(_ #t))))
+  
+  (let ((l
+	 (let lp ((ms (generic-function-methods g)))
+	   (if (pair? ms)
+	       (let* ((m (car ms))
+		      (p (method-specializers m))
+		      (f (method-generic-function m)))
+		 (aif it (mmatch p pattern)
+		     (cons (cons it f) (lp (cdr ms)))
+		     (lp (cdr ms))))
+	       '()))))
+    
+    
+    (cdr (car (sort l q<)))))
+
+(define (resolve-method-o o pattern)
+  (resolve-method-g (class-of o) pattern))
+  
+(define (get-dict self name parents)
+  (aif it (ref self '__prepare__)
+       (it self name parents)
+       (make-hash-table)))
+
+(define (hashforeach a b) (values))
+
+(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)))
+         (if (hash-table? dict)
+             (hash-for-each
+              (lambda (k v) k (set class k v))
+              dict)
+             (hashforeach
+              (lambda (k v) k (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 kw)
+                      #f))))
+         (set class '__mro__ (cons class (ref class '__mro__)))
+         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 meta '__class__)
+         (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+              (apply (it meta 'class) name parents dict keys)
+              (type- meta name parents dict keys))
+         (type- meta name parents dict keys))))
+
+(define (create-object class meta goops x)
+  (with-fluids ((*make-class* #t))
+    (aif it #f ;(ref meta '__call__)
+       (apply it x)       
+       (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! obj 'procedure
+                    (lambda x
+                      (aif it (ref obj '__call__)
+                           (apply it x)
+                           (error "not a callable object"))))
+         obj))))
+
+(define (make-object class meta goops)
+  (let ((obj (make-p goops)))
+    (set obj '__class__ class)
+    obj))
+
+;; Make an empty pf object
+(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)))
+    (if (pair? a)
+        (let ((it (cdr a)))
+          x)
+        y)))
+
+(define-syntax-rule (cif (it h) (k cl) x y)
+  (let* ((h (slot-ref cl 'h))
+         (a (vhash-assq k h)))
+    (if (pair? a)
+        (let ((it (cdr a)))
+          x)
+        y)))
+
+(define-syntax-rule (mrefx x key l)
+  (let ()
+    (define (end)
+      (if (null? l)
+          #f
+          (car l)))
+
+    (define (parents li)
+      (let lp ((li li))
+        (if (pair? li)
+            (let ((p (car li)))
+              (cif (it h) (key p)
+                   it
+		   (lp (cdr li))))
+            fail)))
+  
+    (cif (it h) (key x)
+         it
+         (hif cl ('__class__ h)
+              (cif (it h) (key cl)
+                   it
+                   (hif p ('__mro__ h)
+                        (let ((r (parents p)))
+                          (if (eq? r fail)
+                              (end)
+                              r))
+                        (end)))
+              (end)))))
+
+(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 (find-in-class-and-parents klass key fail)
+  (kif r (find-in-class klass key fail)
+       r
+       (aif parents (find-in-class klass '__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))
+    (fluid-set! *refkind* 'object)
+    (kif it (find-in-class klass key fail)
+	 it
+	 (begin
+	   (fluid-set! *refkind* 'class)
+	   (aif klass (find-in-class klass '__class__ #f)
+		(kif it (find-in-class-and-parents klass key fail)
+		     it
+		     (end))
+		(end))))))
+
+(define not-implemented (cons 'not 'implemeneted))
+
+(define-syntax-rule (prop-ref xx x)
+  (let ((y xx)
+        (r x))
+      (if (and (is-a? r <property>) (not (pyclass? y)))
+          ((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
+			      (mset xx '__fget__ it it)
+			      it)
+			    (begin
+			      (if (mc?)
+				  (mset xx '__fget__ it it))
+			      #f))
+		       g)
+		   #f)))
+       (if (or (not f) (eq? f not-implemented))
+	   (mrefx xx key l)
+	   (catch #t
+		  (lambda () ((f xx (fluid-ref *refkind*)) key))
+		  (lambda x
+		    (mrefx 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 (fluid-ref *refkind*))
+	  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 (fluid-ref *refkind*))
+	  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 <pyf>)  key . l) (mref-py  x key l))
+(define-method (ref (x <py> )  key . l) (mref-py  x key l))
+
+(define-method (rawref (x <pf> )  key . l) (mref     x key l))
+(define-method (rawref (x <p>  )  key . l) (mref     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
+(define (reshape x)
+  (let ((h (slot-ref x 'h))
+        (m (make-hash-table))
+        (n 0))
+    (define h2 (vhash-fold (lambda (k v s)
+                             (if (hash-ref m k #f)
+                                 s
+                                 (begin
+                                   (hash-set! m k #t)
+                                   (set! n (+ n 1))
+                                   (vhash-consq k v s))))
+                           vlist-null
+                           h))
+    (slot-set! x 'h h2)
+    (slot-set! x 'size n)
+    (slot-set! x 'n    n)
+    (values)))
+
+;; on object x add a binding that key -> val
+(define-method (mset (x <pf>) key rval 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-assoc key h)))
+      (when (not r)
+        (slot-set! x 'n (+ n 1)))
+      (slot-set! x 'h (vhash-cons key val h))
+      (when (> s (* 2 n))
+        (reshape x))
+      (values))))
+
+(define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
+
+(define-method (mset (x <p>) key rval val)
+  (begin
+    (hash-set! (slot-ref x 'h) key val)
+    (values)))
+
+(define *make-class* (make-fluid #f))
+(define (mc?) (not (fluid-ref *make-class*)))
+
+(define-syntax-rule (mset-py x key rval val)
+  (let* ((xx x)
+	 (v  (mref xx key (list fail))))
+    (if (or (eq? v fail)
+	    (not (and (is-a? v <property>)
+		      (not (pyclass? xx)))))
+	(let* ((g (mrefx xx '__fset__ '(#t)))
+	       (f (if g
+		      (if (eq? g #t)
+			  (aif it (mrefx xx '__setattr__ '())
+			       (begin
+				 (mset xx '__fset__ it it)
+				 it)
+			       (begin
+				 (if (mc?)
+				     (mset xx '__fset__ it it))
+				 #f))
+			  g)
+		      #f)))
+	  (if (or (eq? f not-implemented) (not f))
+	      (mset xx key val val)              
+	      (catch #t
+	        (lambda () ((f xx (fluid-ref *refkind*)) key rval))
+		(lambda x (mset xx key val val)))))
+	((slot-ref v 'set) xx val))))
+
+(define-syntax-rule (mklam (mset a ...) val)
+  (if (and (procedure? val)
+           (not (pyclass? val))
+           (not (pytype?  val))
+           (if (is-a? val <p>)
+               (ref val '__call__)
+               #t))
+      (if (procedure-property val 'py-special)
+          (mset a ... val val)
+          (mset a ... val (object-method val)))
+      (mset a ... val 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 <pyf>) key val) (mklam (mset-py  x key) val))
+(define-method (set (x <py>)  key val) (mklam (mset-py  x key) val))
+
+(define-method (rawset (x <pf>)  key val) (mklam (mset     x key) val))
+(define-method (rawset (x <p>)   key val) (mklam (mset     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)
+  (define-syntax-rule (mcall x key l)
+    (apply (mref x key '()) l)))
+
+(mk-call mcall     mref)
+(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 <pyf>) 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
+(define-syntax-rule (mcopy x)
+  (let ((r (make-p (ref 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 (ref x '__goops__)))
+         (h (slot-ref r 'h)))
+    (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
+    r))
+
+(define-method (copy (x <pf>)) (mcopy  x))
+(define-method (copy (x <p> )) (mcopy- x))
+
+;; make a copy of a pf object
+(define-syntax-rule (mtr r x)
+  (begin
+    (slot-set! r 'h    (slot-ref x 'h   ))
+    (slot-set! r 'size (slot-ref x 'size))
+    (slot-set! r 'n    (slot-ref x 'n   ))
+    (values)))
+
+(define-syntax-rule (mtr- r x)
+  (begin
+    (slot-set! r 'h (slot-ref x 'h))
+    (values)))
+  
+
+(define-method (tr (r <pf>) (x <pf>)) (mtr  r x))
+(define-method (tr (r <p> ) (x <p> )) (mtr- r x))
+  
+
+;; with will execute thunk and restor x to it's initial state after it has
+;; finished note that this is a cheap operatoin because we use a functional
+;; datastructure
+(define-syntax-rule (mwith x thunk)
+  (let ((old (mcopy x)))
+    (let ((r (thunk)))
+      (slot-set! x 'h    (slot-ref old 'h))
+      (slot-set! x 'size (slot-ref old 'size))    
+      (slot-set! x 'n    (slot-ref old 'n))
+      r)))
+
+(define-syntax-rule (mwith- x thunk)
+  (let ((old (mcopy- x)))
+    (let ((r (thunk)))
+      (slot-set! x 'h    (slot-ref old 'h))
+      r)))
+
+
+
+;; a functional set will return a new object with the added binding and keep
+;; x untouched
+(define-method (fset (x <pf>) key val)
+  (let ((x (mcopy x)))
+    (mset x key val val)
+    x))
+
+(define-method (fset (x <p>) key val)
+  (let ((x (mcopy- x)))
+    (mset x key val val)
+    x))
+
+(define (fset-x obj l val)
+  (let lp ((obj obj) (l l) (r '()))
+    (match l
+      (()
+       (let lp ((v val) (r r))
+         (if (pair? r)
+             (lp (fset (caar r) (cdar r) v) (cdr r))
+             v)))
+      ((k . l)
+       (lp (ref obj k #f) l (cons (cons obj k) r))))))
+
+
+
+           
+
+;; a functional call will keep x untouched and return (values fknval newx)
+;; e.g. we get both the value of the call and the new version of x with
+;; perhaps new bindings added
+(define-method (fcall (x <pf>) key . l)
+  (let* ((y (mcopy x))
+         (r (mcall y key l)))
+    (if (eq? (slot-ref x 'h) (slot-ref y 'h))
+        (values r x)
+        (values r y))))
+
+(define-method (fcall (x <p>) key . l)
+  (let ((x (mcopy x)))
+    (values (mcall x key l)
+            x)))
+
+;; this shows how we can override addition in a pythonic way
+
+;; lets define get put pcall etc so that we can refer to an object like
+;; e.g. (put x.y.z 1) (pcall x.y 1)
+
+(define-syntax-rule (cross x k f set)
+  (call-with-values (lambda () f)
+    (lambda (r y)
+      (if (eq? x y)
+          (values r x)
+          (values r (set x k y))))))
+
+(define-syntax-rule (cross! x k f _) f)
+
+(define-syntax mku
+  (syntax-rules ()
+    ((_ cross set setx f (key) (val ...))
+     (setx f key val ...))
+    ((_ cross set setx f (k . l) val)
+     (cross f k (mku cross set setx (ref f k) l val) set))))
+
+(define-syntax-rule (mkk pset setx set cross)
+  (define-syntax pset
+    (lambda (x)   
+      (syntax-case x ()
+        ((_ f val (... ...))
+         (let* ((to (lambda (x)
+                      (datum->syntax #'f  (string->symbol x))))
+                (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
+           (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
+                                             (cdr l)))
+                         (h       (to (car l))))
+             #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
+
+(mkk put    fset  fset cross)
+(mkk put!   set   set  cross!)
+(mkk pcall! call  fset cross!)
+(mkk pcall  fcall fset cross)
+(mkk get    ref   fset cross!)
+
+;; 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-p <pf>))
+
+(define (filter-parents l)
+  (let lp ((l l))
+    (if (pair? l)
+        (if (is-a? (car l) <p>)
+            (cons (car l) (lp (cdr l)))
+            (lp (cdr l)))
+        '())))
+
+(define (kw->class kw meta)
+  (if (memq #:functional kw)
+      (if (memq #:fast kw)
+          <pf>
+          (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
+              <pyf>
+              <pf>))              
+      (if (memq #:fast kw)
+          (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)
+      (if (memq #:fastClass kw)
+          <pf>
+          (if (memq #:pyClass kw)
+              <pyf>
+              (if (or (is-a? default <py>) (is-a? default <pyf>))
+                  <pyf>
+                  <pf>)))
+      (if (memq #:mutatingClass kw)
+          (if (memq #:fastClass kw)
+              <p>
+              (if (memq #:pyClass kw)
+                  <py>
+                  (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>))
+                  <pf>
+                  <p>)
+              (if (memq #:pyClass kw)
+                  (if (or (is-a? default <pf>) (is-a? default <pyf>))
+                      <pyf>
+                      <py>)
+                  (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))
+                       supers))
+  (define parents (let ((p (filter-parents supers)))
+                    (if (null? p)
+                        (if object
+                            (list object)
+                            '())
+                        p)))
+  
+  (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 (gen-methods dict)
+    (methods 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)
+
+  (with-fluids ((*make-class* #t))
+    (create-class meta name parents gen-methods kw)))
+
+
+;; Let's make an object essentially just move a reference
+
+;; the make class and defclass syntactic sugar
+(define-syntax mk-p-class
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name parents (ddef dname dval) ...)
+       (with-syntax (((ddname ...)
+		      (map (lambda (dn)
+			     (datum->syntax
+			      #'name
+			      (string->symbol
+			       (string-append
+				(symbol->string
+				 (syntax->datum #'name))
+				"-"
+				(symbol->string
+				 (syntax->datum dn))))))
+			   #'(dname ...)))
+		     (nname (datum->syntax
+			     #'name
+			     (string->symbol
+			      (string-append
+			       (symbol->string
+				(syntax->datum #'name))
+			       "-goops-class")))))
+         (%add-to-warn-list (syntax->datum #'nname))
+         (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
+              #'(ddname ...))
+	#'(let ()
+	    (define name 
+	      (letruc ((dname dval) ...)
+		      (make-p-class 'name
+				    parents
+				    (lambda (dict)
+				      (pylist-set! dict 'dname dname)
+				      ...
+				      (values)))))
+
+	    (begin
+	      (module-define! (current-module) 'ddname (ref name 'dname))
+	      (name-object ddname))
+	    ...
+
+	    (module-define! (current-module) 'nname (ref name '__goops__))
+	    (name-object nname)
+	    (name-object name)
+	    name))))))
+
+(define-syntax-rule (def-p-class name . l)
+  (define name (mk-p-class name . l)))
+
+(define (get-class o)
+  (cond
+   ((is-a? o <p>)
+    o)
+   (else
+    (error "not a pyclass"))))
+
+(define (get-type o)
+  (cond
+   ((is-a? o <pyf>)
+    'pyf)
+   ((is-a? o <py>)
+    'py)
+   ((is-a? o <pf>)
+    'pf)
+   ((is-a? o <p>)
+    'p)
+   (else
+    'none)))
+
+(define (print o l)
+  (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
+                      (if (pyobject? o)
+                          (ref o '__repr__)
+                          #f))
+               (format
+                #f "~a(~a)<~a>"
+                p (get-type o) (it))
+               (format
+                #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))
+
+(define (arglist->pkw l)
+  (let lp ((l l) (r '()))
+    (if (pair? l)
+        (let ((x (car l)))
+          (if (keyword? x)
+              (cons (reverse r) l)
+              (lp (cdr l) (cons x r))))
+        (cons (reverse r) '()))))
+
+(define-syntax-rule (define-python-class name (parents ...) code ...)
+  (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
+
+
+(define-syntax make-python-class
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name (parents ...) code ...)
+       #'(let* ((cl  (mk-p-class name
+				 (arglist->pkw (list parents ...))
+				 code ...)))
+	   cl)))))
+    
+
+(define (kind x)
+  (and (is-a? x <p>)
+       (aif it (find-in-class x '__goops__ #f)
+            (if (is-a? (make it) (ref type '__goops__))
+                'type
+                'class)
+            'object)))
+
+(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)
+  f)
+
+(define (object-method f)
+  (letrec ((self
+            (mark-fkn 'object
+                      (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 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 kind) f))))
+    self))
+
+        
+(define-syntax-parameter
+  *class* (lambda (x) (error "*class* not parameterized")))
+(define-syntax-parameter
+  *self* (lambda (x) (error "*class* not parameterized")))
+
+(define *super* (list 'super))
+
+(define (not-a-super) 'not-a-super)
+(define (py-super class obj)
+  (define (make cl parents)
+    (let ((c (make-p <p>))
+          (o (make-p <p>)))
+      (set c '__super__        #t)
+      (set c '__mro__       parents)
+      (set c '__getattribute__  (lambda (self key . l)
+                                  (aif it (ref c key)
+                                       (if (procedure? it)
+                                           (if (eq? (procedure-property
+                                                     it
+                                                     'py-special)
+                                                    'class)
+                                               (it cl)
+                                               (it obj))
+                                           it)
+                                       (error "no attribute"))))
+      (set o '__class__ c)
+      o))
+  
+  (call-with-values
+      (lambda ()
+        (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
+          (if (pair? l)
+              (if (eq? class (car l))
+                  (let ((r (cdr l)))
+                    (if (pair? r)
+                        (values (car r) r)
+                        (values #f      #f)))
+                  (lp (cdr l)))
+              (values #f #f))))
+    make))
+        
+        
+   
+(define-syntax py-super-mac
+  (syntax-rules ()
+    ((_)
+     (py-super *class* *self*))
+    ((_ class self)
+     (py-super class self))))
+
+(define (pp x)
+  (pretty-print (syntax->datum x))
+  x)
+
+(define-syntax letruc
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((x v) ...) code ...)
+       (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
+         (if (pair? a)
+             (let* ((x (car a))
+                    (s (syntax->datum x)))
+               (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
+                         (r (list (car b))))
+                 (if (pair? a2)
+                     (if (eq? (syntax->datum a2) s)
+                         (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
+                         (lp2 (cdr a2) (cdr b2)
+                              (cons (car a2) a3)
+                              (cons (car b2) b3)
+                              r))
+                     (lp (reverse a3) (reverse b3)
+                         (cons
+                          (list x #`(let* #,(map (lambda (v) (list x v))
+                                                 (reverse r)) #,x))
+                          u)))))
+             #`(letrec #,(reverse u) code ...)))))))
+                        
+
+             
+       
+(define-method (py-init (o <p>) . l)
+  (apply (ref o '__init__) l))
+
+(define mk-tree
+  (case-lambda
+   ((root)
+    (vector root '()))
+   ((root hist) (vector root hist))))
+
+(define (geth t) (vector-ref t 1))
+(define (getr t) (vector-ref t 0))
+(define (tree-ref t) (car (getr t)))
+
+(define (nxt tree)  
+  (define (dive r h)
+    (let ((x (car r)))
+      (if (pair? x)
+	  (dive (car r) (cons (cdr r) h))
+	  (mk-tree r h))))
+  
+  (define (up r h)
+    (if (null? r)
+	(if (pair? h)
+	    (up (car h) (cdr h))
+	    #f)
+	(let ((x (car r)))
+	  (if (pair? x)
+	      (dive r h)
+	      (mk-tree r h)))))
+	 
+  (let ((r (getr tree)) (h (geth tree)))
+    (cond
+     ((pair? r)
+      (let ((r (cdr r)))
+	(if (pair? r)
+	    (let ((x (car r)))
+	      (if (pair? x)
+		  (dive x (cons (cdr r) h))
+		  (mk-tree r h)))
+	    (if (pair? h)
+		(up (car h) (cdr h))
+		#f))))
+     (else
+      (if (pair? h)
+	  (up (car h) (cdr h))
+	  #f)))))
+
+(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
+
+(define (find-tree o tree)
+  (if tree
+      (let ((x (tree-ref tree)))
+	(if (eq? o x)
+	    #t
+	    (find-tree o (nxt tree))))
+      #f))
+
+(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))))
+
+(define-method (py-equal? (x <p>)  y)
+  (aif it (ref x '__eq__)
+       (it y)
+       (next-method)))
+
+(define-method (py-equal? y (x <p>))
+  (aif it (ref x '__eq__)
+       (it y)
+       (next-method)))
+
+(define-method (py-equal? x y) ((@ (guile) equal?) x y))
+
+(define (equal? x y) (or (eq? x y) (py-equal? x y)))
+
+(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)
+
+(set! object (make-python-class object ()))
+
+(name-object type)
+(name-object object)