diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-03-06 19:53:13 +0100 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2018-03-06 19:53:13 +0100 |
commit | de1ebe88610f35371f50aa7d6699e2b3b34e79ec (patch) | |
tree | 9447c0fce3d4b87dd4db10ca9471a50f3bfb8d91 /modules/oop | |
parent | 251c4964e9c80cdce0363e0902d0fd3e65b3ca96 (diff) | |
parent | dc79c0ac58f5bcc1f75a96307256dc4cce441f9f (diff) |
Merge branch 'master' of gitlab.com:python-on-guile/python-on-guile
Diffstat (limited to 'modules/oop')
-rw-r--r-- | modules/oop/pf-objects.scm | 46 |
1 files changed, 44 insertions, 2 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 15aad1f..f80a2d2 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -13,7 +13,9 @@ py-super-mac py-super py-equal? *class* *self* pyobject? pytype? type object pylist-set! pylist-ref tr + resolve-method )) + #| Python object system is basically syntactic suger otop of a hashmap and one this project is inspired by the python object system and what it measn when @@ -62,6 +64,47 @@ explicitly tell it to not update etc. (name-object <pyf>) (name-object <property>) +(define (resolve-method-g g pattern) + (define (mmatch p pp) + (if (eq? pp '_) + '() + (match (cons p pp) + (((p . ps) . (pp . pps)) + (if (eq? pp '_) + (mmatch ps pps) + (if (is-a? p pp) + (cons p (mmatch ps pps)) + #f))) + ((() . ()) + '()) + (_ + #f)))) + + (define (q< x y) + (let lp ((x x) (y y)) + (match (cons x y) + (((x . xs) . (y . ys)) + (and (is-a? x y) + (lp xs ys))) + (_ #t)))) + + (let ((l + (let lp ((ms (generic-function-methods g))) + (if (pair? ms) + (let* ((m (car ms)) + (p (method-specializers m)) + (f (method-generic-function m))) + (aif it (mmatch p pattern) + (cons (cons it f) (lp (cdr ms))) + (lp (cdr ms)))) + '())))) + + + (cdr (car (sort l q<))))) + +(define (resolve-method-o o pattern) + (resolve-method-g (class-of o) pattern)) + (define (get-dict self name parents) (aif it (ref self '__prepare__) (it self name parents) @@ -609,8 +652,7 @@ explicitly tell it to not update etc. (define goopses (map (lambda (sups) (aif it (ref sups '__goops__ #f) it - sups) - sups) + sups)) supers)) (define parents (let ((p (filter-parents supers))) (if (null? p) |