(create-object class meta goops x)))
(if (hash-table? dict)
(hash-for-each
- (lambda (k v) (set class k v))
+ (lambda (k v) k (set class k v))
dict)
(hashforeach
- (lambda (k v) (set class k v))
+ (lambda (k v) k (set class k v))
dict))
(let((mro (ref class '__mro__)))
(if (pair? mro)
(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 'object) name parents dict keys)
+ (apply (it meta 'class) name parents dict keys)
(type- meta name parents dict keys))
(type- meta name parents dict keys))))
(apply it x)
(let ((obj (aif it (find-in-class class '__new__ #f)
((it class 'object))
- (make-object class meta goops))))
+ (make-object class meta goops))))
(aif it (ref obj '__init__)
(apply it x)
#f)
(let ((xx x))
(let ((res (mrefx xx key l)))
(if (and (not (struct? res)) (procedure? res))
- (res xx)
+ (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)
+ (res xx (fluid-ref *refkind*))
res))))
(define-method (ref x key . l) (if (pair? l) (car l) #f))
(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))
(lp (cdr l) mro min)))))
(car (reverse min))))))))
- (define goops (make-class (append goopses (list (kw->class kw meta)))
- '() #:name name))
+ (define goops (make-class (append goopses (list (kw->class kw meta)))
+ '() #:name name))
(define (gen-methods dict)
- (method dict)
+ (methods dict)
(pylist-set! dict '__goops__ goops)
(pylist-set! dict '__class__ meta)
(pylist-set! dict '__fget__ #t)
(pylist-set! dict '__class__ meta)
(pylist-set! dict '__mro__ (get-mro parents))
dict)
+
(create-class meta name parents gen-methods kw))
(if (keyword? x)
(cons (reverse r) l)
(lp (cdr l) (cons x r))))
- (cons (reverse l) '()))))
+ (cons (reverse r) '()))))
(define-syntax-rule (define-python-class name (parents ...) code ...)
(define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))