SCM
scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
{
scm_c_issue_deprecation_warning
("scm_immutable_cell is deprecated. Use scm_cell instead.");
return scm_cell (car, cdr);
}
SCM
scm_get_keyword (SCM kw, SCM initargs, SCM default_value)
{
scm_c_issue_deprecation_warning
("scm_get_keyword is deprecated. Use `kw-arg-ref' from Scheme instead.");
return scm_call_3 (scm_variable_ref (var_get_keyword),
kw, initargs, default_value);
}
void
scm_memory_error (const char *subr)
{
scm_c_issue_deprecation_warning
("scm_memory_error is deprecated. Use scm_report_out_of_memory to raise "
"an exception, or abort() to cause the program to exit.");
fprintf (stderr, "FATAL: memory error in %s\n", subr);
abort ();
}
SCM
scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
{
scm_c_issue_deprecation_warning
("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
"or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
"in Scheme.");
return scm_make_standard_class (meta, name, dsupers, dslots);
}
void
scm_c_issue_deprecation_warning_fmt (const char *msg, ...)
{
va_list ap;
char buf[512];
va_start (ap, msg);
vsnprintf (buf, 511, msg, ap);
va_end (ap);
buf[511] = '\0';
scm_c_issue_deprecation_warning (buf);
}
SCM
scm_internal_dynamic_wind (scm_t_guard before,
scm_t_inner inner,
scm_t_guard after,
void *inner_data,
void *guard_data)
{
SCM ans;
scm_c_issue_deprecation_warning
("`scm_internal_dynamic_wind' is deprecated. "
"Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
ans = inner (inner_data);
scm_dynwind_end ();
return ans;
}
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_ref (gf, scm_from_latin1_symbol ("methods"))))
SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
return scm_compute_applicable_methods (gf, l, len - 1, 1);
}
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));
}
