summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-06 10:27:19 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-26 00:25:07 +0100
commitab455d1f1b14347e1445161eeafec919235af92e (patch)
tree5b32056bfa0860d3fa53090fc9687d282475852f
parenta9a90a8820e6f6a36d0f17cdca5f8ba0d7ca735b (diff)
downloadguile-ab455d1f1b14347e1445161eeafec919235af92e.tar.gz
eqv? not a generic, equal? dispatches to generic only for objects
* libguile/eq.c (scm_eqv_p): Not a generic any more. Since eqv? is used by e.g. `case', which should be able to compile into dispatch tables, it really doesn't make sense to dispatch out to a generic. (scm_equal_p): So it was always the case that (equal? 'foo "foo") => #f. But (equal? 'foo 'bar) could actually be extended by a generic. This was a bug, if you follow the other logic of the code. Changed so that generic functions can only extend the domain of equal? when operating on goops objects. * oop/goops.scm: No more eqv? generic. * test-suite/tests/goops.test: Remove eqv? tests.
-rw-r--r--libguile/eq.c26
-rw-r--r--module/oop/goops.scm1
-rw-r--r--test-suite/tests/goops.test12
3 files changed, 15 insertions, 24 deletions
diff --git a/libguile/eq.c b/libguile/eq.c
index 2db4ac022..6cb9bc275 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -104,7 +104,7 @@ real_eqv (double x, double y)
}
#include <stdio.h>
-SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
+SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
"for characters and numbers the same value.\n"
@@ -173,10 +173,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
SCM_COMPLEX_IMAG (y)));
}
}
- if (SCM_UNPACK (g_scm_eqv_p))
- return scm_call_generic_2 (g_scm_eqv_p, x, y);
- else
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -294,13 +291,20 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
case scm_tc7_wvect:
return scm_i_vector_equal_p (x, y);
}
+ /* Check equality between structs of equal type (see cell-type test above). */
+ if (SCM_STRUCTP (x))
+ {
+ if (SCM_INSTANCEP (x))
+ goto generic_equal;
+ else
+ return scm_i_struct_equalp (x, y);
+ }
- /* Check equality between structs of equal type (see cell-type test above)
- that are not GOOPS instances. GOOPS instances are treated via the
- generic function. */
- if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
- return scm_i_struct_equalp (x, y);
-
+ /* Otherwise just return false. Dispatching to the generic is the wrong thing
+ here, as we can hit this case for any two objects of the same type that we
+ think are distinct, like different symbols. */
+ return SCM_BOOL_F;
+
generic_equal:
if (SCM_UNPACK (g_scm_equal_p))
return scm_call_generic_2 (g_scm_equal_p, x, y);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index b67c4d4b0..a1af66654 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -713,7 +713,6 @@
;;; Methods to compare objects
;;;
-(define-method (eqv? x y) #f)
(define-method (equal? x y) (eqv? x y))
;;;
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 18b2122be..8a06ad99a 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -408,18 +408,6 @@
(define o4 (make <c> #:x '(4) #:y '(3)))
(not (eqv? o1 o2)))
(current-module)))
- (pass-if "eqv?"
- (eval '(begin
- (define-method (eqv? (a <c>) (b <c>))
- (equal? (x a) (x b)))
- (eqv? o1 o2))
- (current-module)))
- (pass-if "not eqv?"
- (eval '(not (eqv? o2 o3))
- (current-module)))
- (pass-if "transfer eqv? => equal?"
- (eval '(equal? o1 o2)
- (current-module)))
(pass-if "equal?"
(eval '(begin
(define-method (equal? (a <c>) (b <c>))