Merge branch 'master' of gitlab.com:python-on-guile/python-on-guile

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)