mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-12-18 21:57:24 +01:00
parent e4aa440a2f
commit 3a0d141233
3 changed files with 43 additions and 84 deletions
Download patch file Download diff file Expand all files Collapse all files

83
libguile/goops.c
View file

@ -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
/******************************************************************************
*

1
libguile/goops.h
View file

@ -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

43
module/oop/goops.scm
View file

@ -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))))