diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-30 15:50:48 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-30 15:50:48 +0100 |
commit | 05b37c17ff8e7099d047ae8265766fbb084cb1c3 (patch) | |
tree | 889dc813ecaf6fb29bf25dda259214c2c0d270ae | |
parent | 5487977b1bf4a120cc3604f649cc51ea39b533d9 (diff) | |
download | guile-05b37c17ff8e7099d047ae8265766fbb084cb1c3.tar.gz |
fix up some assumptions that cmethods were lists
* 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.
-rw-r--r-- | libguile/eval.i.c | 35 | ||||
-rw-r--r-- | libguile/objects.c | 5 | ||||
-rw-r--r-- | oop/goops/dispatch.scm | 6 |
3 files changed, 27 insertions, 19 deletions
diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 407a64281..b208f01b0 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -856,8 +856,11 @@ dispatch: 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); @@ -865,19 +868,21 @@ dispatch: /* 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; + } } } diff --git a/libguile/objects.c b/libguile/objects.c index f3c9731a4..e4a3d2a3a 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -138,8 +138,9 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) 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; diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index d8b97b6d1..62daec55e 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -176,7 +176,8 @@ (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 @@ -191,7 +192,8 @@ ((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) |