-/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
- * formats:
- *
- * Format #1:
- * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
- * #((TYPE1 ... . CMETHOD) ...)
- * GF)
- *
- * Format #2:
- * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
- * #((TYPE1 ... CMETHOD) ...)
- * GF)
- *
- * ARGS is either a list of expressions, in which case they
- * are interpreted as the arguments of an application, or
- * a non-pair, which is interpreted as a single expression
- * yielding all arguments.
- *
- * SCM_IM_DISPATCH expressions in generic functions always
- * have ARGS = the symbol `args' or the iloc #@0-0.
- *
- * We should probably not complicate this mechanism by
- * introducing "optimizations" for getters and setters or
- * primitive methods. Getters and setter will normally be
- * compiled into @slot-[ref|set!] or a procedure call.
- * They rely on the dispatch performed before executing
- * the code which contains them.
- *
- * We might want to use a more efficient representation of
- * this form in the future, perhaps after we have introduced
- * low-level support for syntax-case macros.
- */
-
-SCM
-scm_mcache_lookup_cmethod (SCM cache, SCM args)
-{
- unsigned long i, mask, n, end;
- SCM ls, methods, z = SCM_CDDR (cache);
- n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
- methods = SCM_CADR (z);
-
- if (scm_is_simple_vector (methods))
- {
- /* cache format #1: prepare for linear search */
- mask = -1;
- i = 0;
- end = SCM_SIMPLE_VECTOR_LENGTH (methods);
- }
- else
- {
- /* cache format #2: compute a hash value */
- unsigned long hashset = scm_to_ulong (methods);
- long j = n;
- z = SCM_CDDR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- methods = SCM_CADR (z);
- i = 0;
- ls = args;
- if (!scm_is_null (ls))
- do
- {
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
- [scm_si_hashsets + hashset];
- ls = SCM_CDR (ls);
- }
- while (j-- && !scm_is_null (ls));
- i &= mask;
- end = i;
- }
-
- /* Search for match */
- do
- {
- long j = n;
- z = SCM_SIMPLE_VECTOR_REF (methods, i);
- ls = args; /* list of arguments */
- /* More arguments than specifiers => z = CMETHOD, not a pair.
- * Fewer arguments than specifiers => CAR != CLASS or `no-method'. */
- if (!scm_is_null (ls) && scm_is_pair (z))
- do
- {
- if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
- goto next_method;
- ls = SCM_CDR (ls);
- z = SCM_CDR (z);
- }
- while (j-- && !scm_is_null (ls) && scm_is_pair (z));
- if (!scm_is_pair (z))
- return z;
- next_method:
- i = (i + 1) & mask;
- } while (i != end);
- return SCM_BOOL_F;
-}
-
-SCM
-scm_mcache_compute_cmethod (SCM cache, SCM args)
-{
- SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
- if (scm_is_false (cmethod))
- /* No match - memoize */
- return scm_memoize_method (cache, args);
- return cmethod;
-}
-
-SCM
-scm_apply_generic (SCM gf, SCM args)
-{
- SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args);
- if (SCM_PROGRAM_P (cmethod))
- return scm_vm_apply (scm_the_vm (), cmethod, args);
- else if (scm_is_pair (cmethod))
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
- else
- return scm_apply (cmethod, args, SCM_EOL);
-}
-
-SCM
-scm_call_generic_0 (SCM gf)
-{
- return scm_apply_generic (gf, SCM_EOL);
-}
-
-SCM
-scm_call_generic_1 (SCM gf, SCM a1)
-{
- return scm_apply_generic (gf, scm_list_1 (a1));
-}
-
-SCM
-scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
-{
- return scm_apply_generic (gf, scm_list_2 (a1, a2));
-}
-
-SCM
-scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
-{
- return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
-}
-
-SCM
-scm_make_method_cache (SCM gf)