diff --git a/libguile/deprecated.c b/libguile/deprecated.c index bbfba10d3..8989d301d 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -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 + */ + 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 diff --git a/libguile/deprecated.h b/libguile/deprecated.h index d642b7951..122687a16 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -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 diff --git a/libguile/goops.c b/libguile/goops.c index 6fde1bf1b..4028456ba 100644 --- a/libguile/goops.c +++ b/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 - */ - 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} " diff --git a/libguile/goops.h b/libguile/goops.h index f28bc6352..44d89be45 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -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);