path: root/modules/oop/pf-objects.scm

(define-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (system base message)
  #:use-module (language python guilemod)
  #:use-module (ice-9 pretty-print)
  #: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 define-python-class-noname
		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-g 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-method (ref (o <procedure>) key . l)
  (aif it (procedure-property o key)
       it
       (if (pair? l)
	   (car l)
	   #f)))

(define-method (rawref (o <procedure>) key . l)
  (aif it (procedure-property o key)
       it
       (if (pair? l)
	   (car l)
	   #f)))

(define-method (set (o <procedure>) key val)
  (set-procedure-property! o key val))

(define-method (rawset (o <procedure>) key val)
  (set-procedure-property! o key val))

(define (mk-getter-object f)
  (lambda (obj cls)
    (if (or (pyclass? obj) (pytype? obj))
	(lambda x (apply f x))
	(lambda x (apply f obj x)))))

(define (mk-getter-class f)				       
  (lambda (obj cls)
    (lambda x (apply f cls x))))

(define (class-method f)
  (set f '__get__ (mk-getter-class f))
  f)

(define (object-method f)
  (set f '__get__ (mk-getter-object f))
  f)

(define (static-method f)
  (set f '__get__ #f)
  f)


(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 (or (eq? p pp) (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-class0 meta 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 '__zub_classes__)
		 (hash-set! it class #t)
		 #f)
	    
	    (aif it (ref p '__init_subclass__)
		 (apply it class p #f kw)
		 #f))))
    (set class '__mro__ (cons class (ref class '__mro__)))
    class))

(define (new-class meta name parents dict kw)
  (aif it (ref meta '__new__)
       (apply it meta name parents dict kw)
       (apply new-class0 meta name parents dict kw)))

(define (type- meta name parents dict keys)
  (let ((class (new-class meta name parents dict keys)))
    (aif it (and meta (find-in-class meta '__init__ #f))
         (it class 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 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
       (apply it x)       
       (let ((obj (aif it (find-in-class class '__new__ #f)
                       (it)
                       (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-inlinable (gox obj it)
  (let ((class (fluid-ref *location*)))
    (aif f (rawref it '__get__)
	 (f obj class)
	 it)))

(define *location* (make-fluid #f))
(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)
                   (begin (fluid-set! *location* p) it)
		   (lp (cdr li))))
            fail)))
  
    (cif (it h) (key x)
         (begin (fluid-set! *location* x) it)
         (hif cl ('__class__ h)
              (cif (it h) (key cl)
                   (begin (fluid-set! *location* cl) it)
                   (hif p ('__mro__ h)
                        (let ((r (parents p)))
                          (if (eq? r fail)
                              (end)
                              r))
                        (end)))
              (end)))))

(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! *location* klass)
    (kif it (find-in-class-and-parents klass key fail)
	 it
	 (aif klass (find-in-class klass '__class__ #f)
	      (begin
		(fluid-set! *location* klass)
		(kif it (find-in-class-and-parents klass key fail)
		     it
		     (end)))
	      (end)))))

(define not-implemented (cons 'not 'implemeneted))

(define-syntax-rule (mrefx-py x key l)
  (let ((xx x))
     (let* ((g (mrefx xx '__fget__ '(#t)))
	    (f (if g
		   (if (eq? g #t)
		       (aif it (mrefx xx '__getattribute__ '())
			    (let ((f (gox xx it)))
			      (rawset xx '__fget__ it)
			      f)			    
			    (begin
			      (if (mc?)
				  (rawset xx '__fget__ #f))
			      #f))
		       g)
		   #f)))
       (if (or (not f) (eq? f not-implemented))
	   (gox xx (mrefx xx key l))
	   (catch #t
		  (lambda ()
		    (f xx key))
		  (lambda x
		    (gox xx (mrefx xx key l))))))))


(define-syntax-rule (mref x key l)
  (let ((xx x))
    (mrefx xx key l)))

(define-syntax-rule (mref-py x key l)
  (let ((xx x))
    (let ((res (mrefx-py xx key l)))
      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 key . l) (if (pair? l) (car l) #f))
(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 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 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 val)
  (let* ((xx x)
	 (v  (mref xx key (list fail))))
    (if (eq? v fail)
	(let* ((g (mrefx xx '__fset__ '(#t)))
	       (f (if g
		      (if (eq? g #t)
			  (aif it (rawref xx '__setattr__)
			       (begin
				 (rawset xx '__fset__ it)
				 it)
			       (begin
				 (if (mc?)
				     (rawset xx '__fset__ it))
				 #f))
			  g)
		      #f)))
	  (if (or (eq? f not-implemented) (not f))
	      (mset xx key val)              
	      (catch #t
	        (lambda () (f key val))
		(lambda q  (mset xx key val)))))
	
	(aif it (ref v '__class__)
	     (aif it (ref it '__set__)
		  (it val)
		  (mset xx key val))
	     (mset xx key val)))))

(define-syntax-rule (mklam (mset a ...) val)
  (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 <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
      (aif it (ref d '__goops__)
	   it
	   (if (is-a? d <py>)
	       <py>
	       <p>))
      <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 type   #f)
(define object #f)
(define make-p-class
  (case-lambda
   ((name supers.kw methods)
    (make-p-class name "" supers.kw methods))
   ((name doc 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)
		      (cadr 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 (make-module)
      (let ((l (module-name (current-module))))
	(if (and (>= (length l) 3)
		 (equal? (list-ref l 0) 'language)
		 (equal? (list-ref l 1) 'python)
		 (equal? (list-ref l 2) 'module))
	    (string-join
	     (map symbol->string (cdddr l))
	     ".")
	    l)))
  
    (define (gen-methods dict)
      (methods dict)
      (pylist-set! dict '__goops__    goops)
      (pylist-set! dict '__class__    meta)
      (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
      (pylist-set! dict '__module__   (make-module))
      (pylist-set! dict '__bases__    parents)
      (pylist-set! dict '__fget__     #t)
      (pylist-set! dict '__fset__     #t)
      (pylist-set! dict '__name__     name)
      (pylist-set! dict '__qualname__ name)
      (pylist-set! dict '__class__    meta)
      (pylist-set! dict '__mro__      (get-mro parents))
      (pylist-set! dict '__doc__      doc)
      dict)

    (let ((cl (with-fluids ((*make-class* #t))
			   (create-class meta name parents gen-methods kw))))
      (aif it (ref meta '__init_subclass__)
	   (let lp ((ps parents))
	     (if (pair? ps)
		 (let ((super (car ps)))
		   (it cl super)
		   (lp (cdr ps)))))
	   #f)
    
      cl))))
		    


;; Let's make an object essentially just move a reference

;; the make class and defclass syntactic sugar

(define-syntax make-up
  (syntax-rules (lambda case-lambda lambda* letrec letrec*)
    ((_ (lambda . l))
     (object-method (lambda . l)))
    ((_ (case-lambda . l))
     (object-method (case-lambda . l)))
    ((_ (lambda* . l))
     (object-method (lambda* . l)))
    ((_ (letrec . l))
     (object-method (letrec . l)))
    ((_ (letrec* . l))
     (object-method (letrec* . l)))
    ((_ x) x)))

(define-syntax mk-p-class
  (lambda (x)
    (syntax-case x ()
      ((_ name parents (ddef dname dval) ...)
       #'(mk-p-class name parents "" (ddef dname dval) ...))
      ((_ name parents doc (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 (make-up dval)) ...)
		     (make-p-class 'name doc
				    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 mk-p-class-noname
  (lambda (x)
    (syntax-case x ()
      ((_ name parents (ddef dname dval) ...)
       #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
      ((_ name parents doc (ddef dname dval) ...)
       #'(let ()
	   (define name 
	     (letruc ((dname dval) ...)
		     (make-p-class 'name doc
				   parents
				   (lambda (dict)
				     (pylist-set! dict 'dname dname)
				     ...
				     (values)))))
	   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
    (syntax-parameterize ((*class* (lambda (x) #'name)))
       (mk-p-class name (arglist->pkw (list parents ...)) code ...))))

(define-syntax-rule (define-python-class-noname name (parents ...) code ...)
  (define name
    (syntax-parameterize ((*class* (lambda (x) #'name)))
      (mk-p-class-noname 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-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)
    (if (or (pyclass? obj) (pytype? obj))
	cl
	(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 (if (or (pytype? obj) (pyclass? obj))
			     obj
			     (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 '__bases__))))

(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 (subclasses self)
  (aif it (ref self '__zubclasses__)
       (let ((h (make-hash-table)))
	 (let lp0 ((it it))
	   (let lp ((l (hash-fold
			(lambda (k v s)
			  (hash-set! h k #t)
			  (cons k s))
			'() it)))
	     (if (pair? l)
		 (begin
		   (lp0 (car l))
		   (lp (cdr l))))))

	 (hash-fold (lambda (k v s) (cons k s)) '() h))
       '()))

(set! type
      (make-python-class type ()
	(define __new__           new-class0)
	(define __init_subclass__ (lambda x (values)))
	(define ___zub_classes__  (make-weak-key-hash-table))
	(define __subclasses__    subclasses)
        (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 ()
				(define __subclasses__ subclasses)
				(define __weakref__   (lambda (self) self))))

(name-object type)
(name-object object)