diff options
Diffstat (limited to 'modules/oop/pf-objects.scm')
| -rw-r--r-- | modules/oop/pf-objects.scm | 71 |
1 files changed, 46 insertions, 25 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 64ad776..9ebce3f 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -39,20 +39,28 @@ explicitly tell it to not update etc. (define (pk-obj o) (pk 'start-pk-obj) (let ((h (slot-ref o 'h))) - (hash-for-each (lambda (k v) (pk k)) h) + (hash-for-each (lambda (k v) + (if (member k '(__name__ __qualname__)) + (pk k v) + (pk k))) h) + (pk 'finished-obj) - (aif cl (hash-ref h '__class__) - (if (is-a? cl <p>) - (if (hash-table? (slot-ref cl 'h)) - (hash-for-each (lambda (k v) - (if (member k '(__name__ __qualname__)) - (pk k v) - (pk k))) - (slot-ref cl 'h)) - (pk 'no-hash-table)) - (pk 'no-class)) - (pk 'false-class))) - (pk 'end-pk-obj)) + + (let lp ((l (ref o '__mro__ '()))) + (if (pair? l) + (let ((cl (car l))) + (if (is-a? cl <p>) + (if (hash-table? (slot-ref cl 'h)) + (hash-for-each (lambda (k v) + (if (member k '(__name__ __qualname__)) + (pk k v) + (pk k))) + (slot-ref cl 'h)) + (pk 'no-hash-table)) + (pk 'no-class)) + (lp (cdr l))))) + + (pk 'end-pk-obj))) (define fail (cons 'fail '())) @@ -200,14 +208,15 @@ explicitly tell it to not update etc. (define (hashforeach a b) (values)) + (define (new-class0 meta name parents dict . kw) + (pk 'new-class0) (let* ((goops (pylist-ref dict '__goops__)) (p (kwclass->class kw meta)) (class (make-p p))) - (pk 'new-class0) (slot-set! class 'procedure (lambda x - (create-object class meta goops x))) + (create-object class x))) (if (hash-table? dict) (hash-for-each @@ -217,7 +226,7 @@ explicitly tell it to not update etc. (lambda (k v) k (set class k v)) dict)) - (let((mro (ref class '__mro__))) + (let ((mro (ref class '__mro__))) (if (pair? mro) (let ((p (car mro))) (aif it (ref p '__zub_classes__) @@ -227,15 +236,18 @@ explicitly tell it to not update etc. (aif it (ref p '__init_subclass__) (apply it class p #f kw) #f)))) - (set class '__mro__ (cons class (ref class '__mro__))) + (set class '__mro__ (cons class (find-in-class-and-parents + class '__mro__ '()))) class)) (define (new-class meta name parents dict kw) + (pk 'new-class) (aif it (and meta (ficap meta '__new__ #f)) (apply it meta name parents dict kw) (apply new-class0 meta name parents dict kw))) (define (type- meta name parents dict keys) + (pk 'type-) (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) @@ -244,11 +256,13 @@ explicitly tell it to not update etc. (define (the-create-object class x) + (pk 'the-create-object) (let* ((meta (ref class '__class__)) (goops (ref class '__goops__)) - (obj (aif it (ficap class '__new__ #f) - (it) + (obj (aif it (pk '__new__ (ficap class '__new__ #f)) + (begin (pk-obj class) (apply it class x)) (make-object class meta goops)))) + (aif it (ref obj '__init__) (apply it x) #f) @@ -261,15 +275,20 @@ explicitly tell it to not update etc. obj)) -(define (create-object class meta goops x) - (with-fluids ((*make-class* #t)) - (aif it (ficap meta '__call__ #f) - (apply it class x) - (the-create-object class x)))) +(define (create-object class x) + (pk 'create-object) + (if (pk 'type? (pytype? class)) + (apply type-call class x) + (let ((meta (find-in-class class '__class__ #f))) + (with-fluids ((*make-class* #t)) + (aif it (ficap meta '__call__ #f) + (apply it class x) + (the-create-object class x)))))) (define type-call (lambda (class . l) - (if (pytype? class) + (pk 'type-call) + (if (pk 'type? (pytype? class)) (apply (case-lambda ((meta obj) (ref obj '__class__ 'None)) @@ -284,6 +303,7 @@ explicitly tell it to not update etc. (make-hash-table))) (define (create-class meta name parents gen-methods keys) + (pk 'create-class) (let ((dict (gen-methods (get-dict meta name parents)))) (aif it (ref meta '__class__) (aif it (find-in-class it '__call__ #f) @@ -292,6 +312,7 @@ explicitly tell it to not update etc. (type- meta name parents dict keys)))) (define (make-object class meta goops) + (pk 'make-object) (let ((obj (make-p goops))) (set obj '__class__ class) obj)) |