Rewrite %method-more-specific? to be in Scheme

* libguile/goops.h:
* libguile/goops.c (more_specificp, scm_sys_method_more_specific_p):
* module/oop/goops.scm (%method-more-specific?): Rewrite in Scheme.  We
  remove the scm_sys_method_more_specific_p interface as it is a private
  interface and it's not extensible.

1 files changed, 43 insertions, 0 deletions

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a0c6119dc..ebc47eb30 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -508,6 +508,49 @@
 ;;; {Methods}
 ;;;
 
+;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
+;; element longer than the other when we have a dotted parameter
+;; list). For instance, with the call
+;;
+;;   (M 1)
+;;
+;; with
+;;
+;;   (define-method M (a . l) ....)
+;;   (define-method M (a) ....)
+;; 
+;; we consider that the second method is more specific.
+;; 
+;; Precondition: `a' and `b' are methods and are applicable to `types'.
+(define (%method-more-specific? a b types)
+  (let lp ((a-specializers (method-specializers a))
+           (b-specializers (method-specializers b))
+           (types types))
+    (cond
+     ;; (a) less specific than (a b ...) or (a . b)
+     ((null? a-specializers) #t)
+     ;; (a b ...) or (a . b) less specific than (a)
+     ((null? b-specializers) #f)
+     ;; (a . b) less specific than (a b ...)
+     ((not (pair? a-specializers)) #f)
+     ;; (a b ...) more specific than (a . b)
+     ((not (pair? b-specializers)) #t)
+     (else
+      (let ((a-specializer (car a-specializers))
+            (b-specializer (car b-specializers))
+            (a-specializers (cdr a-specializers))
+            (b-specializers (cdr b-specializers))
+            (type (car types))
+            (types (cdr types)))
+        (if (eq? a-specializer b-specializer)
+            (lp a-specializers b-specializers types)
+            (let lp ((cpl (class-precedence-list type)))
+              (let ((elt (car cpl)))
+                (cond
+                 ((eq? a-specializer elt) #t)
+                 ((eq? b-specializer elt) #f)
+                 (else (lp (cdr cpl))))))))))))
+
 (define (%sort-applicable-methods methods types)
   (sort methods (lambda (a b) (%method-more-specific? a b types))))