[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/88: Deprecate C interfaces scm_compute_applicable_met
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/88: Deprecate C interfaces scm_compute_applicable_methods, scm_find_method |
Date: |
Fri, 23 Jan 2015 15:25:19 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit e4aa440a2f6cb341ea187c63dc4fe310f4f148af
Author: Andy Wingo <address@hidden>
Date: Thu Dec 18 21:31:18 2014 +0100
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].
---
libguile/deprecated.c | 229 +++++++++++++++++++++++++++++++++++++++++++++++++
libguile/deprecated.h | 5 +
libguile/goops.c | 179 --------------------------------------
libguile/goops.h | 4 +-
4 files changed, 235 insertions(+), 182 deletions(-)
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index bbfba10..8989d30 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 <address@hidden>
+ */
+ 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 ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index d642b79..122687a 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 6fde1bf..4028456 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1920,13 +1920,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)
{
register SCM s1, s2;
@@ -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 <address@hidden>
- */
- 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 f28bc63..44d89be 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);
- [Guile-commits] branch master updated (4247d8e -> 4bde3f0), Andy Wingo, 2015/01/23
- [Guile-commits] 01/88: Fix the assembler for unexpected source properties, Andy Wingo, 2015/01/23
- [Guile-commits] 02/88: Mark two coverage tests as XFAIL, Andy Wingo, 2015/01/23
- [Guile-commits] 03/88: %compute-applicable-methods in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 07/88: More useless goops.c code removal, Andy Wingo, 2015/01/23
- [Guile-commits] 05/88: Rewrite %method-more-specific? to be in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 06/88: Remove unused macros in goops.c, Andy Wingo, 2015/01/23
- [Guile-commits] 04/88: Deprecate C interfaces scm_compute_applicable_methods, scm_find_method,
Andy Wingo <=
- [Guile-commits] 09/88: %init-goops-builtins is an extension, not a global, Andy Wingo, 2015/01/23
- [Guile-commits] 10/88: Preparation for more GOOPS refactorings, Andy Wingo, 2015/01/23
- [Guile-commits] 08/88: compute-cpl implementation only in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 14/88: Deprecate scm_basic_make_class, Andy Wingo, 2015/01/23
- [Guile-commits] 16/88: define-generic, define-extended-generic are hygienic syntax, Andy Wingo, 2015/01/23
- [Guile-commits] 12/88: Remove declarations without definitions, Andy Wingo, 2015/01/23
- [Guile-commits] 17/88: Remove unused *goops-module* definition., Andy Wingo, 2015/01/23
- [Guile-commits] 20/88: Deprecate scm_no_applicable_method C export, Andy Wingo, 2015/01/23
- [Guile-commits] 23/88: Remove unused `default-slot-definition-class' <class> slot, Andy Wingo, 2015/01/23
- [Guile-commits] 24/88: Remove unused CPP defines naming <method> slots, Andy Wingo, 2015/01/23