X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/856d318a9f543d8a61fcf61caae7d07102586802..e4aa440a2f6cb341ea187c63dc4fe310f4f148af:/libguile/goops.c diff --git a/libguile/goops.c b/libguile/goops.c index 450ae0d55..4028456ba 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -264,6 +264,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_dynamic_state; case scm_tc7_frame: return class_frame; + case scm_tc7_keyword: + return scm_class_keyword; case scm_tc7_vm_cont: return class_vm_cont; case scm_tc7_bytevector: @@ -1917,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) { @@ -1963,179 +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)); -} - -#if 0 -SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods); -#endif - -static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods"; - -SCM -scm_sys_compute_applicable_methods (SCM gf, SCM args) -#define FUNC_NAME s_sys_compute_applicable_methods -{ - long n; - SCM_VALIDATE_GENERIC (1, gf); - n = scm_ilength (args); - SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME); - return scm_compute_applicable_methods (gf, args, n, 1); -} -#undef FUNC_NAME - -SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods"); -SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", - scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, - scm_sys_compute_applicable_methods)); - /****************************************************************************** * * A simple make (which will be redefined later in Scheme) @@ -2262,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} " @@ -2659,8 +2461,6 @@ create_smob_classes (void) for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i) scm_smob_class[i] = SCM_BOOL_F; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; - for (i = 0; i < scm_numsmob; ++i) if (scm_is_false (scm_smob_class[i])) scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i), @@ -2789,8 +2589,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, #define FUNC_NAME s_scm_sys_goops_loaded { goops_loaded_p = 1; - var_compute_applicable_methods = - scm_module_variable (scm_module_goops, sym_compute_applicable_methods); var_slot_unbound = scm_module_variable (scm_module_goops, sym_slot_unbound); var_slot_missing =