mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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
|
||||
|
|
|
|||
|
|
@ -150,6 +150,11 @@ SCM_DEPRECATED void scm_memory_error (const char *subr) SCM_NORETURN;
|
|||
|
||||
|
||||
|
||||
SCM_DEPRECATED SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int scm_find_method);
|
||||
SCM_DEPRECATED SCM scm_find_method (SCM l);
|
||||
|
||||
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
||||
#endif
|
||||
|
|
|
|||
179
libguile/goops.c
179
libguile/goops.c
|
|
@ -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} "
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_GOOPS_H
|
||||
#define SCM_GOOPS_H
|
||||
|
||||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011, 2014 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -247,7 +247,6 @@ SCM_API SCM scm_sys_set_object_setter_x (SCM obj, SCM setter);
|
|||
SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
|
||||
SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
|
||||
|
||||
SCM_API SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int scm_find_method);
|
||||
#ifdef GUILE_DEBUG
|
||||
SCM_API SCM scm_pure_generic_p (SCM obj);
|
||||
#endif
|
||||
|
|
@ -292,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_find_method (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);
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue