diff options
Diffstat (limited to 'modules/oop/pf-objects.scm')
| -rw-r--r-- | modules/oop/pf-objects.scm | 370 |
1 files changed, 217 insertions, 153 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 6ee2c58..361e6ee 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -18,6 +18,7 @@ *class* *self* pyobject? pytype? type object pylist-set! pylist-ref tr resolve-method-g rawref rawset py-dict + ref-class )) #| @@ -34,6 +35,9 @@ The datastructure is functional but the objects mutate. So one need to explicitly tell it to not update etc. |# +;; this is mutated by the dict class +(define dictNs '(dictNs)) + #; (define (pkk . l) (let* ((r (reverse l)) @@ -41,6 +45,8 @@ explicitly tell it to not update etc. (z (car r))) (apply pk x) z)) + + (define (pkk . l) (car (reverse l))) @@ -115,6 +121,16 @@ explicitly tell it to not update etc. (name-object <pyf>) (name-object <property>) +(define-method (pylist-set! (o <p>) key val) + (aif it (ref o '__setitem__) + (it key val) + (next-method))) + +(define-method (pylist-ref (o <p>) key) + (aif it (ref o '__getitem__) + (it key) + (next-method))) + (define-method (ref (o <procedure>) key . l) (aif it (procedure-property o key) it @@ -147,12 +163,30 @@ explicitly tell it to not update etc. (aif dict (hash-ref h '__dict__) (kif it (py-get dict key fail) it - (hash-ref h key -fail)) + (kif it (py-get dict (symbol->string key) fail) + it + (hash-ref h key -fail))) (hash-ref h key -fail)))) +(define-method (find-in-class x key fail) fail) + +(define-method (find-in-class-raw (klass <pf>) key fail) + (let ((r (vhash-assoc key (slot-ref klass 'h)))) + (if r + (cdr r) + fail))) + +(define-method (find-in-class-raw (klass <p>) key -fail) + (let ((h (slot-ref klass 'h))) + (hash-ref h key -fail))) + + (define-syntax-rule (find-in-class-and-parents klass key fail-) - (aif parents (find-in-class klass '__mro__ #f) - (let lp ((parents parents)) + (aif parents (let ((x (find-in-class-raw klass '__mro__ #f))) + (if (null? x) + #f + x)) + (let lp ((parents parents)) (if (pair? parents) (kif r (find-in-class (car parents) key fail) r @@ -162,20 +196,35 @@ explicitly tell it to not update etc. r fail-))) -(define-inlinable - (ficap klass key fail) (find-in-class-and-parents klass key fail)) +(define-syntax-rule (find-in-class-and-parents-raw klass key fail-) + (aif parents (find-in-class-raw klass '__mro__ #f) + (let lp ((parents parents)) + (if (pair? parents) + (kif r (find-in-class-raw (car parents) key fail) + r + (lp (cdr parents))) + fail-)) + (kif r (find-in-class-raw klass key fail) + r + fail-))) + +(define-inlinable (ficap klass key fail) + (find-in-class-and-parents klass key fail)) + +(define-inlinable (ficap-raw klass key fail) + (find-in-class-and-parents-raw klass key fail)) (define (mk-getter-object f) (lambda (obj cls) - (pkk 'obj-name (find-in-class obj '__name__ #f)) - (pkk 'cls-name (find-in-class cls '__name__ #f)) - (if (pkk 'type-obj (pytype? obj)) + (find-in-class obj '__name__ #f) + (find-in-class cls '__name__ #f) + (if (pytype? obj) f - (if (pkk 'class-obj (pyclass? obj)) - (if (pkk 'type-cls (pytype? cls)) + (if (pyclass? obj) + (if (pytype? cls) (lambda x (apply f obj x)) f) - (if (pkk 'class-cls (pyclass? cls)) + (if (pyclass? cls) (lambda x (apply f obj x)) f))))) @@ -225,7 +274,7 @@ explicitly tell it to not update etc. (if (pair? ms) (let* ((m (car ms)) (p (method-specializers m)) - (f (method-generic-function m))) + (f (method-procedure m))) (aif it (mmatch p pattern) (cons (cons it f) (lp (cdr ms))) (lp (cdr ms)))) @@ -258,66 +307,47 @@ explicitly tell it to not update etc. (list c type) (list c object)) (cons c l)))) - + +(define hash-for-each* hash-for-each) + (define (new-class0 meta name parents dict . kw) - (let* ((goops (pkk 'new-class0 name (pylist-ref dict '__goops__))) + (let* ((goops (pylist-ref dict '__goops__)) (p (kwclass->class kw meta)) (class (make-p p))) (slot-set! class 'procedure (lambda x (create-object class x))) - - (if (hash-table? dict) - (hash-for-each - (lambda (k v) k (set class k v)) - dict) - (begin (set class '__dict__ dict))) - - (let lp ((mro (find-in-class class '__mro__ #f))) - (if (pair? mro) - (let ((p (car mro))) - (aif it (find-in-class p '__zub_classes__ #f) - (hash-set! it class #t) - #f) - - (aif it (find-in-class p '__init_subclass__ #f) - (apply it class p #f kw) - #f) - - (lp (cdr mro))))) (when class - (rawset class '__class__ meta) - (rawset class '__goops__ goops) - (rawset class '__name__ (pylist-ref dict '__name__)) - (rawset class '__bases__ (pylist-ref dict '__bases__)) - - (rawset class '__mro__ - (add-default - class - (find-in-class-and-parents - class '__mro__ '()))) + (let lp ((mro (pylist-ref dict '__mro__))) + (if (pair? mro) + (let ((p (car mro))) + (aif it (find-in-class p '__zub_classes__ #f) + (hash-set! it class #t) + #f) + + (aif it (find-in-class p '__init_subclass__ #f) + (apply it class p #f kw) + #f) + + (lp (cdr mro))))) - (if (not (ficap class '__getattribute__ #f)) - (rawset class '__getattribute__ attr)) - (aif it (py-get dict '__getattribute__ #f) - (rawset class '__getattribute__ it) - #f) - - (aif it (py-get dict '__getattr__) - (rawset class '__getattr__ it) - #f) + (hash-for-each* + (lambda (k v) + (let ((k (if (string? k) (string->symbol k) k))) + (rawset class k v))) + dict) - (aif it (py-get dict '__setattr__ #f) - (rawset class '__setattr__ it) - #f) - - (aif it (py-get dict '__delattr__ #f) - (rawset class '__delattr__ it) - #f)) - + (rawset class '__goops__ goops) + + (let ((mro (add-default class (pylist-ref dict '__mro__)))) + (rawset class '__mro__ mro)) + + (if (not (ficap-raw class '__getattribute__ #f)) + (rawset class '__getattribute__ attr))) + class)) (define (new-class meta name parents dict kw) @@ -330,11 +360,12 @@ explicitly tell it to not update etc. (aif it (and meta (find-in-class-and-parents meta '__init__ #f)) (it class name parents dict keys) #f) + class)) (define (the-create-object class x) - (let* ((meta (and class (find-in-class class '__class__ #f))) + (let* ((meta (and class (find-in-class-raw class '__class__ #f))) (goops (find-in-class class '__goops__ #f)) (obj (aif it (ficap class '__new__ #f) (apply it class x) @@ -355,7 +386,7 @@ explicitly tell it to not update etc. (define (create-object class x) (if (pytype? class) (apply type-call class x) - (let ((meta (and class (find-in-class class '__class__ #f)))) + (let ((meta (and class (find-in-class-raw class '__class__ #f)))) (with-fluids ((*make-class* #t)) (aif it (ficap meta '__call__ #f) (apply it class x) @@ -366,7 +397,7 @@ explicitly tell it to not update etc. (if (pytype? class) (apply (case-lambda ((meta obj) - (and obj (find-in-class obj '__class__ 'None))) + (and obj (find-in-class-raw obj '__class__ 'None))) ((meta name bases dict . keys) (type- meta name bases dict keys))) class l) @@ -374,13 +405,13 @@ explicitly tell it to not update etc. (define (get-dict self name parents) (aif it (and self (ficap self '__prepare__ #f)) - (it self name parents) + (dictNs (it self name parents)) (make-hash-table))) (define (create-class meta name parents gen-methods keys) (let ((dict (gen-methods (get-dict meta name parents)))) - (aif it (and meta (find-in-class meta '__class__ #f)) - (aif it (find-in-class it '__call__ #f) + (aif it (and meta (find-in-class-raw meta '__class__ #f)) + (aif it (ficap-raw it '__call__ #f) (apply it meta name parents dict keys) (type- meta name parents dict keys)) (type- meta name parents dict keys)))) @@ -468,7 +499,7 @@ explicitly tell it to not update etc. (fluid-set! *location* klass) (kif it (find-in-class-and-parents klass key fail) it - (aif klass (and klass (find-in-class klass '__class__ #f)) + (aif klass (and klass (find-in-class-raw klass '__class__ #f)) (begin (fluid-set! *location* klass) (kif it (find-in-class-and-parents klass key fail) @@ -481,8 +512,8 @@ explicitly tell it to not update etc. (define (mrefx-py x key l) (let ((xx x)) (define (exit) (if (pair? l) (car l) #f)) - (aif class (find-in-class xx '__class__ #f) - (aif f (find-in-class-and-parents class '__getattribute__ #f) + (aif class (find-in-class-raw xx '__class__ #f) + (aif f (ficap-raw class '__getattribute__ #f) (kif it (if (eq? f __getattribute__) (f xx key) (catch #t @@ -580,17 +611,21 @@ explicitly tell it to not update etc. (define (mc?) (not (fluid-ref *make-class*))) (define __setattr__ - (lambda (self key val) - (kif desc (ref self key fail) - (aif it (ref desc '__set__) - (it self val) - (mset self key val)) - (mset self key val)))) + (lambda (self key1 val) + (define key (if (string? key1) (string->symbol key1) key1)) + (let ((h (aif dict (rawref self '__dict__) + dict + (slot-ref self 'h)))) + (kif desc (py-get h key fail) + (aif it (rawref desc '__set__ #f) + (it self val) + (pylist-set! h key val)) + (pylist-set! h key val))))) (define (mset-py x key val) (let* ((xx x)) - (aif class (find-in-class xx '__class__ #f) - (aif f (find-in-class-and-parents class '__setattr__ #f) + (aif class (find-in-class-raw xx '__class__ #f) + (aif f (find-in-class-and-parents-raw class '__setattr__ #f) (if (eq? f __setattr__) (f xx key val) (f xx (symbol->string key) val)) @@ -866,14 +901,14 @@ explicitly tell it to not update etc. (if (null? cparents) type (let* ((p (car cparents)) - (m (ref p '__class__)) + (m (rawref p '__class__)) (mro (reverse (ref m '__mro__ '())))) (let lp ((l (cdr cparents)) (max mro) (min mro)) (if (pair? l) (let* ((p (car l)) - (meta (ref p '__class__)) + (meta (rawref p '__class__)) (mro (ref meta '__mro__ '()))) (let lp2 ((max max) (mr (reverse mro))) (if (and (pair? max) (pair? mr)) @@ -886,10 +921,24 @@ explicitly tell it to not update etc. (lp (cdr l) max mro) (lp (cdr l) max min)) (lp (cdr l) mro min))))) - (car (reverse min)))))))) + (if (null? min) + type + (car (reverse min))))))))) + (define (unique l) + (define t (make-hash-table)) + (let lp ((l l)) + (if (pair? l) + (let ((c (car l))) + (if (hashq-ref t c) + (lp (cdr l)) + (begin + (hashq-set! t c #t) + (cons c (lp (cdr l)))))) + '()))) - (define goops (make-class (append goopses - (list (kw->class kw meta))) + (define goops (make-class (unique + (append goopses + (list (kw->class kw meta)))) '() #:name name)) (define (make-module) @@ -912,21 +961,17 @@ explicitly tell it to not update etc. (cons y (lp (cdr x))) (lp (cdr x)))) '()))) - + (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__ (filt-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 cparents)) (pylist-set! dict '__doc__ doc) + (pylist-set! dict '__class__ meta) dict) (let ((cl (with-fluids ((*make-class* #t)) @@ -1047,10 +1092,9 @@ explicitly tell it to not update etc. (make-p-class 'name doc parents (lambda (dict) - (begin - (pylist-set! dict 'dname dname)) + (pylist-set! dict 'dname dname) ... - (values))))) + dict)))) (begin (module-define! (current-module) 'ddname dname) (name-object ddname)) @@ -1101,24 +1145,36 @@ explicitly tell it to not update etc. (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 (print o l z) + (begin + (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) + z + #f)) + (format + #f "~a(~a)<~a>" + p (get-type o) (it)) + (format + #f "~a(~a)<~a>" + p (get-type o) (aif it (find-in-class-raw + o '__name__ 'Annonymous) + it + (ref + o '__name__ 'Annonymous))))))) + +(define-method (write (o <p>) . l) + (aif it (ref o '__repr__) + (print o l it) + (print o l #f))) + +(define-method (display (o <p>) . l) + (aif it (ref o '__repr__) + (print o l it) + (print o l #f))) (define (arglist->pkw l) (let lp ((l l) (r '())) @@ -1152,7 +1208,7 @@ explicitly tell it to not update etc. (define type-goops #f) (define (kind x) - (if (not type-goops) (set! type-goops (ref type '__goops__))) + (if (not type-goops) (set! type-goops (rawref type '__goops__))) (and (is-a? x <p>) (aif it (find-in-class x '__goops__ #f) (if (or @@ -1181,7 +1237,6 @@ explicitly tell it to not update etc. (define (not-a-super) 'not-a-super) (define (py-super class obj) (define (make cl parents) - (pk 'parents cl parents) (if (not cl) #f (let ((c (make-p <py>)) @@ -1191,21 +1246,18 @@ explicitly tell it to not update etc. (rawset c '__getattribute__ (lambda (self key) (set! key (if (string? key) (string->symbol key) key)) - (pk 'key key) - (pk key (kif it (pk 'it (ficap c key fail)) - (aif dt (pk '__get__ (ref it '__get__)) - (dt obj cl) - it) - fail)))) + (kif it (ficap c key fail) + (aif dt (ref it '__get__) + (dt obj cl) + it) + fail))) (rawset c '__name__ "**super**") (rawset o '__class__ c) o))) - (pk 'super class (ref obj '__name__)) - (call-with-values (lambda () - (let ((ll (pk 'l class (ref (ref obj '__class__) '__mro__ '())))) + (let ((ll (ref (ref obj '__class__) '__mro__ '()))) (if (pair? ll) (let lp ((l ll)) (if (pair? l) @@ -1378,40 +1430,45 @@ explicitly tell it to not update etc. (hash-fold (lambda (k v s) (cons k s)) '() h)) '())) +(define ref-class + (lambda (self key fail) + (aif class (find-in-class-raw self '__class__ #f) + (kif it1 (ficap class key fail) + (aif dd1 (rawref it1 '__get__) + (dd1 self class) + it1) + fail) + fail))) + (define __getattribute__ - (case-lambda - ((self key) - (define (-fail class) - (if (eq? key 'mro) - (find-in-class self '__mro__ fail) - fail)) - - (aif class (pkk 'class (find-in-class self '__class__ #f)) - (kif it1 (pkk 'c (find-in-class-and-parents class key fail)) - (aif dd1 (pkk 'get (rawref it1 '__get__)) - (if (pkk 'set (rawref it1 '__set__)) - (pkk 'desc key (dd1 self class)) - (kif it2 (find-in-class-and-parents self key fail) - (pkk 'object key it2) - (pkk 'gox key (dd1 self class)))) - (kif it2 (pkk 'o (find-in-class-and-parents self key fail)) - (pkk 'object key it2) - (pkk 'class key it1))) - (kif it2 (pkk 'o2 (find-in-class-and-parents self key fail)) - (pkk 'object key it2) - (aif it (pkk 'getattr - (find-in-class-and-parents class '__getattr__ #f)) - (kif it1 (catch #t - (lambda () (it self (symbol->string key))) + (lambda (self key-) + (define key (if (string? key-) (string->symbol key-) key-)) + (aif class (find-in-class-raw self '__class__ #f) + (kif it1 (ficap class key fail) + (aif dd1 (rawref it1 '__get__) + (if (rawref it1 '__set__) + (dd1 self class) + (kif it2 (ficap self key fail) + it2 + (dd1 self class))) + (kif it2 (ficap self key fail) + it2 + it1)) + (kif it2 (ficap self key fail) + it2 + (aif it (ficap-raw class '__getattr__ #f) + (kif it1 (catch #t + (lambda () + (it self (symbol->string key))) (lambda x fail)) - (aif dd1 (rawref it1 '__get__) - (pkk 'getattr-gox key (dd1 self class)) - (pkk 'getattr key it1)) - (pkk 'fail1 (-fail class))) - (pkk 'fail2 (-fail class))))) - (pkk 'classfail fail))))) - + (aif dd1 (rawref it1 '__get__) + (dd1 self class) + it1) + fail) + fail))) + fail))) + (define attr __getattribute__) (define (*str* self) @@ -1434,6 +1491,7 @@ explicitly tell it to not update etc. (define mro (lambda (self) (ref self '__mro__))))) (set type '__class__ type) +(rawset type '__mro__ (list type)) (define _mro (object-method (lambda (self) (ref self '__mro__)))) @@ -1441,6 +1499,11 @@ explicitly tell it to not update etc. (set! object (make-python-class object () + (define __new__ (lambda (class . a) + (make-object + class + (find-in-class-raw class '__class__ #f) + (find-in-class-raw class '__goops__ #f)))) (define __init__ (lambda x (values))) (define __subclasses__ subclasses) (define __getattribute__ attr) @@ -1449,7 +1512,8 @@ explicitly tell it to not update etc. (define __format__ (lambda (self x) (*str* self))) (define __reduce_ex__ (lambda x (error "not implemented"))) (define __weakref__ (lambda (self) self)))) - + +(rawset object '__mro__ (list object)) (name-object type) (name-object object) @@ -1467,7 +1531,7 @@ explicitly tell it to not update etc. (if (eq? x 'None) (py-dict NoneObj) (make-hash-table))) - + (define-method (py-dict (o <p>)) (aif it (ref o '__dict__) it |