diff options
Diffstat (limited to 'modules/oop/pf-objects.scm')
| -rw-r--r-- | modules/oop/pf-objects.scm | 102 |
1 files changed, 66 insertions, 36 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 37ed5f0..86f2e2c 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -8,7 +8,7 @@ #: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! + call with copy fset fcall put put! py-get pcall pcall! get fset-x pyclass? def-p-class mk-p-class make-p-class mk-p-class2 define-python-class define-python-class-noname @@ -78,6 +78,12 @@ explicitly tell it to not update etc. it (error "IndexError"))) +(define-method (py-get (o <hashtable>) key . l) + (define -fail (if (pair? l) (car l) #f)) + (kif it (hash-ref o key fail) + it + -fail)) + (define (is-acl? a b) (member a (cons b (class-subclasses b)))) (define-class <p> (<applicable-struct> <object>) h) @@ -121,6 +127,13 @@ explicitly tell it to not update etc. (cdr r) fail))) +(define-method (find-in-class (klass <p>) key -fail) + (let ((h (slot-ref klass 'h))) + (aif dict (hash-ref h '__dict__) + (py-get dict key -fail) + (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)) @@ -221,9 +234,7 @@ explicitly tell it to not update etc. (hash-for-each (lambda (k v) k (set class k v)) dict) - (hashforeach - (lambda (k v) k (set class k v)) - dict)) + (set class '__dict__ dict)) (let ((mro (ref class '__mro__))) (if (pair? mro) @@ -249,18 +260,18 @@ 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) - (pk 'res class))) + class)) (define (the-create-object class x) - (let* ((meta (ref class '__class__)) - (goops (ref class '__goops__)) + (let* ((meta (ficap class '__class__ #f)) + (goops (ficap class '__goops__ #f)) (obj (aif it (ficap class '__new__ #f) (apply it class x) (make-object class meta goops)))) - (aif it (ref obj '__init__) - (apply it x) + (aif it (ficap class '__init__ #f) + (apply it obj x) #f) (slot-set! obj 'procedure @@ -380,9 +391,6 @@ explicitly tell it to not update etc. r)) (end))) (end))))) - -(define-method (find-in-class (klass <p>) key fail) - (hash-ref (slot-ref klass 'h) key fail)) (define-syntax-rule (mrefx klass key l) (let () @@ -400,17 +408,16 @@ explicitly tell it to not update etc. (define not-implemented (cons 'not 'implemeneted)) -(define-syntax-rule (mrefx-py x key l) +(define-inlinable (mrefx-py x key l) (let ((xx x)) - (let* ((f (aif it (or (mrefx xx '__getattribute__ '()) - (mrefx xx '__getattr__ '())) + (let* ((f (aif it (mrefx xx '__getattribute__ '()) (gox xx it) #f))) (if (or (not f) (eq? f not-implemented)) (gox xx (mrefx xx key l)) (catch #t - (lambda () (gox xx (f xx key))) - (lambda z (if (pair? l) (car l) #f))))))) + (lambda () (f key)) + (lambda z (pk z) (if (pair? l) (car l) #f))))))) (define-syntax-rule (mref x key l) (let ((xx x)) @@ -856,7 +863,6 @@ explicitly tell it to not update etc. (let ((cl (with-fluids ((*make-class* #t)) (create-class meta name parents gen-methods kw)))) - (pk 'got cl) (aif it (ref meta '__init_subclass__) (let lp ((ps cparents)) (if (pair? ps) @@ -864,7 +870,6 @@ explicitly tell it to not update etc. (it cl super) (lp (cdr ps))))) #f) - (pk 'return) cl)))) @@ -931,7 +936,7 @@ explicitly tell it to not update etc. ... ret))) - (module-define! (current-module) 'nname (ref name '__goops__)) + (module-define! (current-module) 'nname (rawref name '__goops__)) (name-object nname) (name-object name) name)))))) @@ -961,12 +966,14 @@ explicitly tell it to not update etc. (symbol->string (syntax->datum #'name)) "-goops-class"))))) - (%add-to-warn-list (syntax->datum #'nname)) + + (%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)) ...) + + #'(let () + (define name + (letruc ((dname (make-up dval)) ...) body (let ((ret (make-p-class 'name doc @@ -980,7 +987,7 @@ explicitly tell it to not update etc. (name-object ddname)) ... ret))) - (module-define! (current-module) 'nname (ref name '__goops__)) + (module-define! (current-module) 'nname (rawref name '__goops__)) (name-object nname) (name-object name) name)))))) @@ -1113,12 +1120,10 @@ explicitly tell it to not update etc. (o (make-p <py>))) (set c '__class__ type) (set c '__mro__ (cons c parents)) - (set c '__getattribute__ (lambda (self key . l) - (aif it (ficap c key #f) - (if (procedure? it) - (gokx obj cl it) - it) - (error "no attribute")))) + (set c '__getattribute__ + (object-method + (lambda (self key . l) + (ficap c key #f)))) (set c '__name__ "**super**") (set o '__class__ c) o)))) @@ -1291,6 +1296,30 @@ explicitly tell it to not update etc. (hash-fold (lambda (k v s) (cons k s)) '() h)) '())) +(define __getattribute__ + (case-lambda + ((self key) + (aif class (find-in-class self '__class__ #f) + (kif it1 (find-in-class-and-parents self key fail) + (aif dd1 (ref it1 '__get__) + (if (ref it1 '__set__) + (dd1 self class) + (kif it2 (find-in-class self key fail) + it2 + (it1 self class))) + (kif it2 (find-in-class self key fail) + it2 + it1)) + (kif it2 (find-in-class self key fail) + it2 + (aif it (ref self '__getattr__) + (it key) + (error "AttributeError" key)))) + (error "AttributeError" "could not find class" key))) + (l (error "AttributeError" "wrong arguments BUG" l)))) + +(define attr __getattribute__) + (set! type (make-python-class type () (define __new__ new-class0) @@ -1302,10 +1331,12 @@ explicitly tell it to not update etc. (set type '__class__ type) -(set! object (make-python-class object () - (define __init__ (lambda x (values))) - (define __subclasses__ subclasses) - (define __weakref__ (lambda (self) self)))) +(set! object + (make-python-class object () + (define __init__ (lambda x (values))) + (define __subclasses__ subclasses) + (define __getattribute__ (object-method attr)) + (define __weakref__ (lambda (self) self)))) (name-object type) @@ -1326,4 +1357,3 @@ explicitly tell it to not update etc. (define __new__ (lambda x 'None))) - |