dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Deprecate C interfaces scm_compute_applicable_methods, scm_find_method

Browse source 
* 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 2014-12-18 21:31:18 +01:00
commit e4aa440a2f
4 changed files with 235 additions and 182 deletions
Download patch file Download diff file Expand all files Collapse all files

179
libguile/goops.c
View file

@ -1919,13 +1919,6 @@ scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
*
******************************************************************************/
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)
{
@ -1965,158 +1958,6 @@ more_specificp (SCM m1, SCM m2, SCM const *targs)
return 0; /* should not occur! */
}
#define BUFFSIZE 32 /* big enough for most uses */
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 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;
/* 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_VARIABLE_REF (var_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");
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
@ -2243,26 +2084,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
}
#undef FUNC_NAME
SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
(SCM l),
"")
#define FUNC_NAME s_scm_find_method
{
SCM gf;
long len = scm_ilength (l);
if (len == 0)
SCM_WRONG_NUM_ARGS ();
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
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} "