def-p-class mk-p-class make-p-class
define-python-class get-type py-class
object-method class-method static-method
- py-super-mac py-super py-equal?
- *class* *self*
+ py-super-mac py-super py-equal?
+ *class* *self* type pyobject? pytype?
+ type object
))
#|
Python object system is basically syntactic suger otop of a hashmap and one
(hash-set! h '__class__ x)
(slot-set! o 'h h)))
(else #f))
- (values))
+ (values))
-(define-method (get-dict (self <pyf>) name parents)
+(define (get-dict self name parents)
(aif it (ref self '__prepare__)
(it self name parents)
- (make (kwclass->class kw <pyf>))))
-
-(define-method (get-dict (self <py>) name parents)
- (aif it (ref self '__prepare__)
- (it self name parents)
- (make (kwclass->class kw <py>))))
-
-(define-method (get-dict (self <pf>) name parents)
- (aif it (ref self '__prepare__)
- (it self name parents)
- (make (kwclass->class kw <pf>))))
-
-(define-method (get-dict (self <p>) name parents)
- (aif it (ref self '__prepare__)
- (it self name parents)
- (make (kwclass->class kw <p>))))
+ (make-hash-table)))
+(define (hashforeach a b) (values))
(define (new-class meta name parents dict keys)
(aif it (ref self '__new__)
(class (make p)))
(slot-set! class 'procedure
(lambda x
- (create-object class meta goops x)))
- (cond
- ((eq? p <pf>)
- (cond
- ((is-a? dict <pf>)
- (slot-set! class 'h (slot-ref dict 'h))
- (slot-set! class 'n (slot-ref dict 'n))
- (slot-set! class 'size (slot-ref dict 'size)))
- (else
- (error "funtional class creation needs functional dicts"))))
-
- ((eq? p <p>)
- (cond
- ((is-a? dict <pf>)
- (slot-set! class 'h dict))
- ((is-a? dict <p>)
- (slot-set! class 'h (slot-ref dict 'h)))
- (else
- (slot-set! class 'h dict)))))
-
- (let lp ((ps parents))
- (if (pair? ps)
- (let ((p (car ps)))
+ (create-object class meta goops x)))
+ (set class '__class__ meta)
+ (if (hashtable? dict)
+ (hash-for-each
+ (lambda (k v) (set class k v))
+ dict)
+ (hashforeach
+ (lambda (k v) (set class k v))
+ dict))
+ (let((mro (ref class '__mro__)))
+ (if (pair? mro)
+ (let ((p (car mro)))
(aif it (ref p '__init_subclass__)
(apply it class #f keys)
- #f)
- (lp (cdr ps)))))
+ #f))))
class)))
+(define (type- meta name parents dict keys)
+ (let ((class (new-class meta name parents dict keys)))
+ (aif it (ref meta '__init__)
+ (it name parents dict keys)
+ #f)
+ class))
+
(define (create-class meta name parents gen-methods . keys)
(let ((dict (gen-methods (get-dict meta name keys))))
- (aif it (ref (ref meta '__class__) '__call__)
- (apply it name parents dict keys)
- (let ((class (new-class meta name parents dict keys)))
- (aif it (ref meta '__init__)
- (it name parents dict keys)
- #f)
- class))))
+ (aif it (find-in-class (ref meta '__class__) '__call__ #f)
+ (apply (it meta 'object) name parents dict keys)
+ (type- meta name parents dict keys))))
(define (create-object class meta goops x)
(aif it (ref meta '__call__)
(make-p-class name
parents
(lambda (dict)
- (let ((d (make-pf class)))
- (set d 'dname dname) (... ...)
- d))))
+ (hash-set! d 'dname dname) (... ...)))))
+
name)))
#f)))
#f))
+(define (pyobject? x)
+ (and (is-a? x <p>)
+ (if (is-a? x type)
+ #f
+ (if it (ref x '__class__)
+ (if (is-a? it type)
+ #f
+ #t)))
+ #f))
+
+(define (pytype? x)
+ (and (is-a? x <p>)
+ (if (is-a? x type)
+ #t
+ #f)
+ #f))
+
(define-method (py-class (o <p>))
- (ref o '__class__ 'type))
+ (ref o '__class__ type))
(define (mark-fkn tag f)
(set-procedure-property! f 'py-special tag)
(define-method (py-equal? x y) ((@ (guile) equal?) x y))
(define (equal? x y) (or (eq? x y) (py-equal? x y)))
+
+(define type 'type)
+(define-python-class type ()
+ (define __call__
+ (case-lambda
+ ((self obj)
+ (if (is-a? obj type)
+ obj
+ (let ((r (ref obj '__class__)))
+ (if (is-a? r type)
+ r
+ (ref r '__class__)))))
+ ((self name bases dict . keys)
+ (type- meta name parents dict keys)))))
+
+(set type '__class__ type)
+
+(define-python-class object ())