Deprecate C interfaces scm_compute_applicable_methods, scm_find_method
* libguile/deprecated.h: * libguile/deprecated.c (scm_compute_applicable_methods): Deprecate. This was the boot version of compute-applicable-methods, not the full version; the right thing to do is to call scheme. (scm_find_method): Deprecate. Again, the right thing is to do this on the Scheme level. * libguile/goops.c: * libguile/goops.h: Deprecated code moved to deprecated.[ch].
This commit is contained in:
Andy Wingo
parent
c0a56ec78d
commit
e4aa440a2f
4 changed files with 235 additions and 182 deletions
|
|
@ -91,6 +91,235 @@ scm_memory_error (const char *subr)
|
|||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#define BUFFSIZE 32 /* big enough for most uses */
|
||||
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
|
||||
|
||||
static SCM
|
||||
scm_i_vector2list (SCM l, long len)
|
||||
{
|
||||
long j;
|
||||
SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
|
||||
|
||||
for (j = 0; j < len; j++, l = SCM_CDR (l)) {
|
||||
SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
|
||||
}
|
||||
return z;
|
||||
}
|
||||
|
||||
static int
|
||||
applicablep (SCM actual, SCM formal)
|
||||
{
|
||||
/* We already know that the cpl is well formed. */
|
||||
return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
|
||||
}
|
||||
|
||||
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! */
|
||||
}
|
||||
|
||||
static SCM
|
||||
sort_applicable_methods (SCM method_list, long size, SCM const *targs)
|
||||
{
|
||||
long i, j, incr;
|
||||
SCM *v, vector = SCM_EOL;
|
||||
SCM buffer[BUFFSIZE];
|
||||
SCM save = method_list;
|
||||
scm_t_array_handle handle;
|
||||
|
||||
/* For reasonably sized method_lists we can try to avoid all the
|
||||
* consing and reorder the list in place...
|
||||
* This idea is due to David McClain <Dave_McClain@msn.com>
|
||||
*/
|
||||
if (size <= BUFFSIZE)
|
||||
{
|
||||
for (i = 0; i < size; i++)
|
||||
{
|
||||
buffer[i] = SCM_CAR (method_list);
|
||||
method_list = SCM_CDR (method_list);
|
||||
}
|
||||
v = buffer;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Too many elements in method_list to keep everything locally */
|
||||
vector = scm_i_vector2list (save, size);
|
||||
v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
|
||||
}
|
||||
|
||||
/* Use a simple shell sort since it is generally faster than qsort on
|
||||
* small vectors (which is probably mostly the case when we have to
|
||||
* sort a list of applicable methods).
|
||||
*/
|
||||
for (incr = size / 2; incr; incr /= 2)
|
||||
{
|
||||
for (i = incr; i < size; i++)
|
||||
{
|
||||
for (j = i - incr; j >= 0; j -= incr)
|
||||
{
|
||||
if (more_specificp (v[j], v[j+incr], targs))
|
||||
break;
|
||||
else
|
||||
{
|
||||
SCM tmp = v[j + incr];
|
||||
v[j + incr] = v[j];
|
||||
v[j] = tmp;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (size <= BUFFSIZE)
|
||||
{
|
||||
/* We did it in locally, so restore the original list (reordered) in-place */
|
||||
for (i = 0, method_list = save; i < size; i++, v++)
|
||||
{
|
||||
SCM_SETCAR (method_list, *v);
|
||||
method_list = SCM_CDR (method_list);
|
||||
}
|
||||
return save;
|
||||
}
|
||||
|
||||
/* If we are here, that's that we did it the hard way... */
|
||||
scm_array_handle_release (&handle);
|
||||
return scm_vector_to_list (vector);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
|
||||
{
|
||||
register long i;
|
||||
long count = 0;
|
||||
SCM l, fl, applicable = SCM_EOL;
|
||||
SCM save = args;
|
||||
SCM buffer[BUFFSIZE];
|
||||
SCM const *types;
|
||||
SCM *p;
|
||||
SCM tmp = SCM_EOL;
|
||||
scm_t_array_handle handle;
|
||||
|
||||
scm_c_issue_deprecation_warning
|
||||
("scm_compute_applicable_methods is deprecated. Use "
|
||||
"`compute-applicable-methods' from Scheme instead.");
|
||||
|
||||
/* Build the list of arguments types */
|
||||
if (len >= BUFFSIZE)
|
||||
{
|
||||
tmp = scm_c_make_vector (len, SCM_UNDEFINED);
|
||||
types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
|
||||
|
||||
/*
|
||||
note that we don't have to work to reset the generation
|
||||
count. TMP is a new vector anyway, and it is found
|
||||
conservatively.
|
||||
*/
|
||||
}
|
||||
else
|
||||
types = p = buffer;
|
||||
|
||||
for ( ; !scm_is_null (args); args = SCM_CDR (args))
|
||||
*p++ = scm_class_of (SCM_CAR (args));
|
||||
|
||||
/* Build a list of all applicable methods */
|
||||
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
|
||||
{
|
||||
fl = SPEC_OF (SCM_CAR (l));
|
||||
for (i = 0; ; i++, fl = SCM_CDR (fl))
|
||||
{
|
||||
if (SCM_INSTANCEP (fl)
|
||||
/* We have a dotted argument list */
|
||||
|| (i >= len && scm_is_null (fl)))
|
||||
{ /* both list exhausted */
|
||||
applicable = scm_cons (SCM_CAR (l), applicable);
|
||||
count += 1;
|
||||
break;
|
||||
}
|
||||
if (i >= len
|
||||
|| scm_is_null (fl)
|
||||
|| !applicablep (types[i], SCM_CAR (fl)))
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (len >= BUFFSIZE)
|
||||
scm_array_handle_release (&handle);
|
||||
|
||||
if (count == 0)
|
||||
{
|
||||
if (find_method_p)
|
||||
return SCM_BOOL_F;
|
||||
scm_call_2 (scm_no_applicable_method, gf, save);
|
||||
/* if we are here, it's because no-applicable-method hasn't signaled an error */
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
return (count == 1
|
||||
? applicable
|
||||
: sort_applicable_methods (applicable, count, types));
|
||||
}
|
||||
|
||||
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
|
||||
|
||||
SCM
|
||||
scm_find_method (SCM l)
|
||||
#define FUNC_NAME "find-method"
|
||||
{
|
||||
SCM gf;
|
||||
long len = scm_ilength (l);
|
||||
|
||||
if (len == 0)
|
||||
SCM_WRONG_NUM_ARGS ();
|
||||
|
||||
scm_c_issue_deprecation_warning
|
||||
("scm_find_method is deprecated. Use `compute-applicable-methods' "
|
||||
"from Scheme instead.");
|
||||
|
||||
gf = SCM_CAR(l); l = SCM_CDR(l);
|
||||
SCM_VALIDATE_GENERIC (1, gf);
|
||||
if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
|
||||
SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
|
||||
|
||||
return scm_compute_applicable_methods (gf, l, len - 1, 1);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
|
||||
void
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue