* libguile/eval.i.c (type_dispatch, apply_vm_cmethod)
(apply_memoized_cmethod): Tweak the nastiness a bit more so as to deal
with the '(no-method) empty entries. I would like to stop the search if
the cdr isn't a pair, but currently with the inlined memoized bits, the
cdr is a pair. The fix would be to make the memoizer return a procedure
and not the already-inlined bits -- slightly slower but the vm will be
faster anyway.
* libguile/objects.c (scm_mcache_lookup_cmethod): Same fixes here.
* oop/goops/dispatch.scm (cache-hashval, cache-try-hash!): Allow non-list
cmethod tails.
z = SCM_CDR (z);
}
/* Fewer arguments than specifiers => CAR != CLASS */
z = SCM_CDR (z);
}
/* Fewer arguments than specifiers => CAR != CLASS */
- if (!SCM_CLASSP (SCM_CAR (z)))
- goto apply_cmethod;
+ if (!scm_is_pair (z))
+ goto apply_vm_cmethod;
+ else if (!SCM_CLASSP (SCM_CAR (z))
+ && !scm_is_symbol (SCM_CAR (z)))
+ goto apply_memoized_cmethod;
next_method:
hash_value = (hash_value + 1) & mask;
} while (hash_value != cache_end_pos);
next_method:
hash_value = (hash_value + 1) & mask;
} while (hash_value != cache_end_pos);
/* No appropriate method was found in the cache. */
z = scm_memoize_method (x, arg1);
/* No appropriate method was found in the cache. */
z = scm_memoize_method (x, arg1);
- apply_cmethod: /* inputs: z, arg1 */
- {
- if (scm_is_pair (z)) {
- SCM formals = SCM_CMETHOD_FORMALS (z);
- env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_BODY (z);
- goto nontoplevel_begin;
- } else {
- proc = z;
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
- }
+ if (scm_is_pair (z))
+ goto apply_memoized_cmethod;
+
+ apply_vm_cmethod:
+ proc = z;
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+
+ apply_memoized_cmethod: /* inputs: z, arg1 */
+ {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ }
z = SCM_CDR (z);
}
while (j-- && !scm_is_null (ls));
z = SCM_CDR (z);
}
while (j-- && !scm_is_null (ls));
- /* Fewer arguments than specifiers => CAR != CLASS */
- if (!SCM_CLASSP (SCM_CAR (z)))
+ /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
+ if (!scm_is_pair (z)
+ || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
return z;
next_method:
i = (i + 1) & mask;
return z;
next_method:
i = (i + 1) & mask;
(let ((hashset-index (+ hashset-index hashset)))
(do ((sum 0)
(classes entry (cdr classes)))
(let ((hashset-index (+ hashset-index hashset)))
(do ((sum 0)
(classes entry (cdr classes)))
- ((not (struct? (car classes))) sum)
+ ((not (and (pair? classes) (struct? (car classes))))
+ sum)
(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
;;; FIXME: the throw probably is expensive, given that this function
(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
;;; FIXME: the throw probably is expensive, given that this function
((null? ls) max-misses)
(do ((i (logand mask (cache-hashval hashset (car ls)))
(logand mask (+ i 1))))
((null? ls) max-misses)
(do ((i (logand mask (cache-hashval hashset (car ls)))
(logand mask (+ i 1))))
- ((not (struct? (car (vector-ref cache i))))
+ ((and (pair? (vector-ref cache i))
+ (eq? (car (vector-ref cache i)) 'no-method))
(vector-set! cache i (car ls)))
(set! misses (+ 1 misses))
(if (>= misses min-misses)
(vector-set! cache i (car ls)))
(set! misses (+ 1 misses))
(if (>= misses min-misses)