guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 03/87: Rewrite %method-more-specific? to be in Scheme


From: Andy Wingo
Subject: [Guile-commits] 03/87: Rewrite %method-more-specific? to be in Scheme
Date: Thu, 22 Jan 2015 17:29:40 +0000

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit d5671db5e194eb75fc08a1ba9850cc69e66f2fcc
Author: Andy Wingo <address@hidden>
Date:   Thu Dec 18 21:57:24 2014 +0100

    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.
---
 libguile/goops.c     |   83 --------------------------------------------------
 libguile/goops.h     |    1 -
 module/oop/goops.scm |   43 ++++++++++++++++++++++++++
 3 files changed, 43 insertions(+), 84 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 4028456..c9d6c44 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -58,8 +58,6 @@
 #include "libguile/validate.h"
 #include "libguile/goops.h"
 
-#define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)
-
 /* Port classes */
 #define SCM_IN_PCLASS_INDEX       0
 #define SCM_OUT_PCLASS_INDEX      SCM_I_MAX_PORT_TYPE_COUNT
@@ -1919,45 +1917,6 @@ scm_wta_dispatch_n (SCM gf, SCM args, int pos, const 
char *subr)
  *
  
******************************************************************************/
 
-static int
-more_specificp (SCM m1, SCM m2, SCM const *targs)
-{
-  register SCM s1, s2;
-  register long i;
-  /*
-   * Note:
-   *   m1 and m2 can have != length (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.
-   *
-   * BTW, targs is an array of types. We don't need it's size since
-   * we already know that m1 and m2 are applicable (no risk to go past
-   * the end of this array).
-   *
-   */
-  for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), 
s2=SCM_CDR(s2)) {
-    if (scm_is_null(s1)) return 1;
-    if (scm_is_null(s2)) return 0;
-    if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
-      register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
-
-      for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
-       if (scm_is_eq (cs1, SCM_CAR (l)))
-         return 1;
-       if (scm_is_eq (cs2, SCM_CAR (l)))
-         return 0;
-      }
-      return 0;/* should not occur! */
-    }
-  }
-  return 0; /* should not occur! */
-}
-
 /******************************************************************************
  *
  * A simple make (which will be redefined later in Scheme)
@@ -2084,48 +2043,6 @@ SCM_DEFINE (scm_make, "make",  0, 0, 1,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
-           (SCM m1, SCM m2, SCM targs),
-           "Return true if method @var{m1} is more specific than @var{m2} "
-           "given the argument types (classes) listed in @var{targs}.")
-#define FUNC_NAME s_scm_sys_method_more_specific_p
-{
-  SCM l, v, result;
-  SCM *v_elts;
-  long i, len, m1_specs, m2_specs;
-  scm_t_array_handle handle;
-
-  SCM_VALIDATE_METHOD (1, m1);
-  SCM_VALIDATE_METHOD (2, m2);
-
-  len = scm_ilength (targs);
-  m1_specs = scm_ilength (SPEC_OF (m1));
-  m2_specs = scm_ilength (SPEC_OF (m2));
-  SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
-             targs, SCM_ARG3, FUNC_NAME);
-
-  /* Verify that all the arguments of TARGS are classes and place them
-     in a vector.  */
-
-  v = scm_c_make_vector (len, SCM_EOL);
-  v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
-
-  for (i = 0, l = targs;
-       i < len && scm_is_pair (l);
-       i++, l = SCM_CDR (l))
-    {
-      SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
-      v_elts[i] = SCM_CAR (l);
-    }
-  result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
-
-  scm_array_handle_release (&handle);
-
-  return result;
-}
-#undef FUNC_NAME
-
-
 
 /******************************************************************************
  *
diff --git a/libguile/goops.h b/libguile/goops.h
index 44d89be..881bd2f 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -291,7 +291,6 @@ SCM_API SCM scm_primitive_generic_generic (SCM subr);
 SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
 SCM_API SCM stklos_version (void);
 SCM_API SCM scm_make (SCM args);
-SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
 SCM_API void scm_change_object_class (SCM, SCM, SCM);
 
 /* These procedures are for dispatching to a generic when a primitive
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a0c6119..ebc47eb 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))))
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]