From 9f63ce021c567056c02b81d96742ff91416b886f Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 8 Nov 2009 11:49:06 +0100
Subject: [PATCH] make sure that when equal? is extended, that the generic has
 a method

* libguile/goops.h:
* libguile/goops.c (scm_set_primitive_generic_x): New function, for now
  local to the goops module.

* module/oop/goops.scm (equal?): Make sure that when equal? is extended,
  that the generic already has a default method.
---
 libguile/goops.c     | 13 +++++++++++++
 libguile/goops.h     |  1 +
 module/oop/goops.scm | 10 +++++++++-
 3 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index c2705f554..88408f686 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1915,6 +1915,19 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
+	    (SCM subr, SCM generic),
+	    "")
+#define FUNC_NAME s_scm_set_primitive_generic_x
+{
+  SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
+              subr, SCM_ARG1, FUNC_NAME);
+  SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
+  *SCM_SUBR_GENERIC (subr) = generic;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
 	    (SCM subr),
 	    "")
diff --git a/libguile/goops.h b/libguile/goops.h
index 72fe45e8f..e77bbd995 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -305,6 +305,7 @@ SCM_API SCM scm_make_method_cache (SCM gf);
 SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
 SCM_API SCM scm_generic_capability_p (SCM proc);
 SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
+SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
 SCM_API SCM scm_primitive_generic_generic (SCM subr);
 SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
 SCM_API SCM stklos_version (void);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index d06f62f6c..c8a183bcf 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -716,7 +716,15 @@
 ;;; Methods to compare objects
 ;;;
 
-(define-method (equal? x y) (eqv? x y))
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f)) 
+(set-primitive-generic! equal? g-equal?)
 
 ;;;
 ;;; methods to display/write an object