summaryrefslogtreecommitdiff
path: root/libguile/deprecated.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-12-18 21:31:18 +0100
committerAndy Wingo <wingo@pobox.com>2015-01-23 16:15:59 +0100
commite4aa440a2f6cb341ea187c63dc4fe310f4f148af (patch)
tree55bb54a9d8417d2567c9c6c19e77e5f9cf92f842 /libguile/deprecated.c
parentc0a56ec78ddf9df65f591104a1d7bbcada099477 (diff)
downloadguile-e4aa440a2f6cb341ea187c63dc4fe310f4f148af.tar.gz
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].
Diffstat (limited to 'libguile/deprecated.c')
-rw-r--r--libguile/deprecated.c229
1 files changed, 229 insertions, 0 deletions
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index bbfba10d3..8989d301d 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -93,6 +93,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
scm_i_init_deprecated ()
{