[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/42: Rewrite %method-more-specific? to be in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/42: Rewrite %method-more-specific? to be in Scheme |
Date: |
Sat, 10 Jan 2015 00:03:03 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit f3dac8a89f2a5245ddc9843f77ff32beada61176
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 | 37 ++++++++++++++++++++++
3 files changed, 37 insertions(+), 84 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index 8f58cba..59f9c2a 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
@@ -1917,45 +1915,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)
@@ -2082,48 +2041,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 06c07e4..e30824e 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -507,6 +507,43 @@
;;; {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
+ ((null? a-specializers) #t)
+ ((null? b-specializers) #f)
+ (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))))
- [Guile-commits] branch wip-goops-refactor created (now f86e587), Andy Wingo, 2015/01/09
- [Guile-commits] 01/42: %compute-applicable-methods in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 05/42: More useless goops.c code removal, Andy Wingo, 2015/01/09
- [Guile-commits] 03/42: Rewrite %method-more-specific? to be in Scheme,
Andy Wingo <=
- [Guile-commits] 04/42: Remove unused macros in goops.c, Andy Wingo, 2015/01/09
- [Guile-commits] 10/42: Remove declarations without definitions, Andy Wingo, 2015/01/09
- [Guile-commits] 08/42: Preparation for more GOOPS refactorings, Andy Wingo, 2015/01/09
- [Guile-commits] 06/42: compute-cpl implementation only in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 09/42: Remove unused %fast-slot-ref / %fast-slot-set! from GOOPS, Andy Wingo, 2015/01/09
- [Guile-commits] 12/42: Deprecate scm_basic_make_class, Andy Wingo, 2015/01/09
- [Guile-commits] 14/42: define-generic, define-extended-generic are hygienic syntax, Andy Wingo, 2015/01/09
- [Guile-commits] 07/42: %init-goops-builtins is an extension, not a global, Andy Wingo, 2015/01/09
- [Guile-commits] 13/42: `class' is a hygienic macro, Andy Wingo, 2015/01/09
- [Guile-commits] 16/42: Further GOOPS simplifications, Andy Wingo, 2015/01/09