diff options
| -rw-r--r-- | modules/language/python/dir.scm | 48 | ||||
| -rw-r--r-- | modules/language/python/module.scm | 123 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 80 |
3 files changed, 196 insertions, 55 deletions
diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm index da07642..e41e235 100644 --- a/modules/language/python/dir.scm +++ b/modules/language/python/dir.scm @@ -17,15 +17,15 @@ (define (chash-for-each f c) (let ((h (slot-ref c 'h))) - (if (is-a? c <pf>) - (let ((hh (make-hash-table))) - (vhash-fold - (lambda (k v s) - (when (not (hash-ref hh k)) - (hash-set! hh k #t) - (f k v)) - s) #f h)) - (hash-for-each f h)))) + (if (is-a? c <pf>) + (let ((hh (make-hash-table))) + (vhash-fold + (lambda (k v s) + (when (not (hash-ref hh k)) + (hash-set! hh k #t) + (f k v)) + s) #f h)) + (hash-for-each f h)))) (define (get-from-class c f) (let lp ((pl (ref c '__mro__))) @@ -38,20 +38,22 @@ (if (not (pyclass? o)) (aif it (ref o '__dir__) (it) - (aif it (ref o '__dict__) - (let ((l (pylist))) - (for ((k v : it)) () - (pylist-append! l k)) - (pylist-sort! l) - l) - (let* ((h (make-hash-table)) - (c (ref o '__class__)) - (l '()) - (f (lambda (k v) (set! l (cons k l))))) - (chash-for-each f o) - (get-from-class c f) - (hash-for-each (lambda (k v) (pylist-append! l k)) h) - (to-pylist (map symbol->string (sort l <)))))) + (begin + (let ((l1 (aif it (ref o '__dict__) + (let ((l (pylist))) + (for ((k v : it)) () + (pylist-append! l k)) + (pylist-sort! l) + l) + (pylist)))) + (let* ((h (make-hash-table)) + (c (ref o '__class__)) + (l '()) + (f (lambda (k v) (set! l (cons k l))))) + (chash-for-each f o) + (get-from-class c f) + (hash-for-each (lambda (k v) (pylist-append! l k)) h) + (+ (pylist (map symbol->string (sort l <))) l1))))) (let* ((h (make-hash-table)) (c o) (l '()) diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm new file mode 100644 index 0000000..615d163 --- /dev/null +++ b/modules/language/python/module.scm @@ -0,0 +1,123 @@ +(define-module (language python module) + #:use-module (oop pf-objects) + #:use-module (ice-9 match) + #:use-module (language python exceptions) + #:use-module (language python yield) + #:use-module (language python try) + #:use-module (language python dir) + #:export (Module)) + +(define e (list 'e)) + +(define _k + (lambda (k) + (if (string? k) + (string->symbol k) + k))) + +(define _m + (lambda (self) + (if (rawref self '_private) + (rawref self '_module) + (rawref self '_export)))) + +(define-python-class Module () + (define __setprivate__ + (lambda (self p) + (set self '_isprivate p))) + + (define __init__ + (case-lambda + ((self pre l nm) + (match l + ((name) + (_make self (cons name pre) (cons name nm))) + ((name . (and l (name2 . _))) + (set self name2 (Module (cons name pre) l (cons name nm))) + (_make self (cons name pre) (cons name nm))))) + + ((self l) + (if (pair? l) + (if (and (> (length l) 3) + (equal? (list (list-ref l 0) + (list-ref l 1) + (list-ref l 2)) + '(language python module))) + (__init__ self (reverse '(language python module)) (cdddr l) '()) + (_make self l l)) + (__init__ self + (map string->symbol + (string-split l #\.))))))) + (define _make + (lambda (self l nm) + (begin + (set self '_private #f) + (set self '__dict__ self) + (set self '__name__ (string-join (map symbol->string (reverse nm)) ".")) + (let ((_module (resolve-module (reverse l)))) + (set self '_export (module-public-interface _module)) + (set self '_module _module))))) + + (define __getattribute__ + (lambda (self k . l) + (define (fail) + (if (pair? l) + (car l) + (raise KeyError "getattr in Module"))) + (if (rawref self '_module) + (let ((k (_k k)) + (m (_m self))) + (let ((x (module-ref m k e))) + (if (eq? e x) + (fail) + x))) + (fail)))) + + (define __setattr__ + (lambda (self k v) + (let ((k (_k k)) + (fail (lambda () (raise KeyError "getattr in Module")))) + (if (rawref self k) + (fail) + (if (rawref self '_module) + (let ((m (_m self))) + (catch #t + (lambda () + (if (module-defined? m k) + (module-set! m k v) + (module-define! m k v))) + (lambda x (pk 'fail x)))) + (fail)))))) + + (define __delattr__ + (lambda (self k) + (define (fail) (raise KeyError "getattr in Module")) + (if (rawref self '_module) + (let ((m (_m self)) + (k (_k k))) + (if (module-defined? m k) + (module-remove! m k) + (raise KeyError "delattr of missing key in Module"))) + (fail)))) + + (define __repr__ + (lambda (self) (ref self '__name__))) + + (define __getitem__ + (lambda (self k) + (define k (if (string? k) (string->symbol k) k)) + (__getattr__ self k))) + + (define __iter__ + (lambda (self) + (define m (_m self)) + ((make-generator () + (lambda (yield) + (define l '()) + (define (f k v) (set! l (cons (list (symbol->string k) v) l))) + (module-for-each f m) + (let lp ((l l)) + (if (pair? l) + (begin + (apply yield (car l)) + (lp (cdr l))))))))))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index f80a2d2..5b78063 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -13,7 +13,7 @@ py-super-mac py-super py-equal? *class* *self* pyobject? pytype? type object pylist-set! pylist-ref tr - resolve-method + resolve-method rawref )) #| @@ -153,7 +153,8 @@ explicitly tell it to not update etc. (type- meta name parents dict keys)))) (define (create-object class meta goops x) - (aif it #f ;(ref meta '__call__) + (with-fluids ((*make-class* #t)) + (aif it #f ;(ref meta '__call__) (apply it x) (let ((obj (aif it (find-in-class class '__new__ #f) ((it class 'object)) @@ -166,7 +167,7 @@ explicitly tell it to not update etc. (aif it (ref obj '__call__) (apply it x) (error "not a callable object")))) - obj))) + obj)))) (define (make-object class meta goops) (let ((obj (make-p goops))) @@ -288,16 +289,20 @@ explicitly tell it to not update etc. (if (eq? g #t) (aif it (mrefx xx '__getattribute__ '()) (begin - (set xx '__fget__ it) + (mset xx '__fget__ it it) it) (begin - (set xx '__fget__ it) + (if (mc?) + (mset xx '__fget__ it it)) #f)) g) #f))) (if (or (not f) (eq? f not-implemented)) (mrefx xx key l) - (apply f xx key l)))))) + (catch #t + (lambda () ((f xx (fluid-ref *refkind*)) key)) + (lambda x + (mrefx xx key l)))))))) (define-syntax-rule (mref x key l) @@ -320,6 +325,10 @@ explicitly tell it to not update etc. (define-method (ref (x <pyf>) key . l) (mref-py x key l)) (define-method (ref (x <py> ) key . l) (mref-py x key l)) +(define-method (rawref (x <pf> ) key . l) (mref x key l)) +(define-method (rawref (x <p> ) key . l) (mref x key l)) + + (define-method (set (f <procedure>) key val) (set-procedure-property! f key val)) @@ -351,7 +360,7 @@ explicitly tell it to not update etc. (values))) ;; on object x add a binding that key -> val -(define-method (mset (x <pf>) key val) +(define-method (mset (x <pf>) key rval val) (let ((h (slot-ref x 'h)) (s (slot-ref x 'size)) (n (slot-ref x 'n))) @@ -366,33 +375,39 @@ explicitly tell it to not update etc. (define (pkh h) (hash-for-each (lambda x (pk x)) h) h) -(define-method (mset (x <p>) key val) +(define-method (mset (x <p>) key rval val) (begin (hash-set! (slot-ref x 'h) key val) (values))) -(define-syntax-rule (mset-py x key val) - (let* ((v (mref x key (list fail)))) - (if (or (eq? v fail) (not (and (is-a? v <property>) (not (pyclass? x))))) - (let* ((g (mrefx x '__fset__ '(#t))) +(define *make-class* (make-fluid #f)) +(define (mc?) (not (fluid-ref *make-class*))) + +(define-syntax-rule (mset-py x key rval val) + (let* ((xx x) + (v (mref xx key (list fail)))) + (if (or (eq? v fail) + (not (and (is-a? v <property>) + (not (pyclass? xx))))) + (let* ((g (mrefx xx '__fset__ '(#t))) (f (if g (if (eq? g #t) - (let ((class (aif it (mref x '__class__ '()) - it - x))) - (aif it (mrefx x '__setattr__ '()) - (begin - (mset class '__fset__ it) - it) - (begin - (mset class '__fset__ it) - #f))) + (aif it (mrefx xx '__setattr__ '()) + (begin + (mset xx '__fset__ it it) + it) + (begin + (if (mc?) + (mset xx '__fset__ it it)) + #f)) g) #f))) (if (or (eq? f not-implemented) (not f)) - (mset x key val) - (f key val))) - ((slot-ref v 'set) x val)))) + (mset xx key val val) + (catch #t + (lambda () ((f xx (fluid-ref *refkind*)) key rval)) + (lambda x (mset xx key val val))))) + ((slot-ref v 'set) xx val)))) (define-syntax-rule (mklam (mset a ...) val) (if (and (procedure? val) @@ -402,9 +417,9 @@ explicitly tell it to not update etc. (ref val '__call__) #t)) (if (procedure-property val 'py-special) - (mset a ... val) - (mset a ... (object-method val))) - (mset a ... val))) + (mset a ... val val) + (mset a ... val (object-method val))) + (mset a ... val val))) (define-method (set (x <pf>) key val) (mklam (mset x key) val)) (define-method (set (x <p>) key val) (mklam (mset x key) val)) @@ -489,12 +504,12 @@ explicitly tell it to not update etc. ;; x untouched (define-method (fset (x <pf>) key val) (let ((x (mcopy x))) - (mset x key val) + (mset x key val val) x)) (define-method (fset (x <p>) key val) (let ((x (mcopy- x))) - (mset x key val) + (mset x key val val) x)) (define (fset-x obj l val) @@ -702,8 +717,9 @@ explicitly tell it to not update etc. (pylist-set! dict '__class__ meta) (pylist-set! dict '__mro__ (get-mro parents)) dict) - - (create-class meta name parents gen-methods kw)) + + (with-fluids ((*make-class* #t)) + (create-class meta name parents gen-methods kw))) ;; Let's make an object essentially just move a reference |