[Guile-commits] 02/87: Deprecate C interfaces scm_compute_applicable_methods, scm_find_method

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit b5bfbac28d6d2b2976b105483ba3d7a62f964b27
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);