From 05b37c17ff8e7099d047ae8265766fbb084cb1c3 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 30 Oct 2008 15:50:48 +0100
Subject: [PATCH] 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.
---
 libguile/eval.i.c      | 35 ++++++++++++++++++++---------------
 libguile/objects.c     |  5 +++--
 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)
-- 
2.20.1