diff options
| -rw-r--r-- | modules/language/python/property.scm | 35 | ||||
| -rw-r--r-- | modules/language/python/set.scm | 2 | ||||
| -rw-r--r-- | modules/oop/pf-objects.scm | 45 |
3 files changed, 49 insertions, 33 deletions
diff --git a/modules/language/python/property.scm b/modules/language/python/property.scm new file mode 100644 index 0000000..eaefc74 --- /dev/null +++ b/modules/language/python/property.scm @@ -0,0 +1,35 @@ +(define-module (language python property) + #:use-module (oop pf-objects) + #:use-module (oop goops) + #:use-module (language python def) + #:use-module (language python exceptions) + #:export (property)) + +(define-python-class property (<property>) + (define __init__ + (lam (o (= getx None) (= setx None) (= delx None)) + (slot-set! o 'get getx) + (slot-set! o 'set setx) + (slot-set! o 'del delx) + o)) + + (define setter + (lambda (self f) + (slot-set! self 'set f) + self)) + + (define getter + (lambda (self f) + (slot-set! self 'get f) + self)) + + (define deleter + (lambda (self f) + (slot-set! self 'del f) + self)) + + (define fget (lambda (self) (slot-ref self 'get))) + (define fset (lambda (self) (slot-ref self 'set))) + (define fdel (lambda (self) (slot-ref self 'del)))) + + diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm index cd12586..f0e2956 100644 --- a/modules/language/python/set.scm +++ b/modules/language/python/set.scm @@ -12,7 +12,7 @@ (define-class <set> () dict) (define miss (list 'miss)) - + (define-python-class set (<set>) (define __init__ (case-lambda diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 3508d16..ebaa3b7 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -144,7 +144,7 @@ explicitly tell it to not update etc. (if (pair? parents) (let ((parent (car parents))) (let* ((h (slot-ref parent 'h)) - (r (hash-ref class-h key fail))) + (r (hash-ref h key fail))) (if (eq? r fail) (lpp (cdr parents)) r))) @@ -722,12 +722,13 @@ explicitly tell it to not update etc. (define *super* (list 'super)) +(define (not-a-super) 'not-a-super) (define (py-super class obj) (define (make cl parents) (let ((c (make-p)) (o (make-p))) (set c '__super__ #t) - (set c '__parents__ parents) + (set c '__mro__ parents) (set c '__getattribute__ (lambda (self key . l) (aif it (ref c key) (if (procedure? it) @@ -744,31 +745,15 @@ explicitly tell it to not update etc. (call-with-values (lambda () - (let lp ((c (ref obj '__class__))) - (if (eq? class c) - (let ((p (ref c '__parents__))) - (if (pair? p) - (values (car p) p) - (values #t #t))) - (let lp2 ((p (ref c 'parents))) - (if (pair? p) - (call-with-values (lambda () (lp (car p))) - (lambda (c ps) - (cond - ((eq? c #t) - (if (pair? p) - (let ((x (car p))) - (values - x - (append - (ref x '__parents__) - (cdr p)))) - (values #t #t))) - (c - (values c (append ps (cdr p)))) - (else - (lp2 (cdr p)))))) - (values #f #f)))))) + (let lp ((l (ref (ref obj '__class__) '__mro__ '()))) + (if (pair? l) + (if (eq? class (car l)) + (let ((r (cdr l))) + (if (pair? r) + (values (car r) r) + (values #f #f))) + (lp (cdr l))) + (values #f #f)))) make)) @@ -870,11 +855,7 @@ explicitly tell it to not update etc. (if tree (let ((x (tree-ref tree)) (n (nxt tree))) - (if (pk 'find (find-tree x n)) + (if (find-tree x n) (lp n r) (lp n (cons x r)))) (reverse r)))) - - - - |