summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog4
-rw-r--r--libguile/eq.c7
-rw-r--r--oop/ChangeLog2
-rw-r--r--oop/goops.scm3
-rw-r--r--test-suite/ChangeLog3
-rw-r--r--test-suite/tests/goops.test87
6 files changed, 92 insertions, 14 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 5095ff433..839e5aa42 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,7 @@
+2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * eq.c (scm_eqv_p): Turned into a primitive generic.
+
2003-04-16 Rob Browning <rlb@defaultvalue.org>
* gc_os_dep.c: Added patch for UnixWare and OpenUNIX support.
diff --git a/libguile/eq.c b/libguile/eq.c
index 5b144beef..67abdc96e 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -61,7 +61,7 @@ real_eqv (double x, double y)
return !memcmp (&x, &y, sizeof(double));
}
-SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
+SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
(SCM x, SCM y),
"The @code{eqv?} procedure defines a useful equivalence relation on objects.\n"
"Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be\n"
@@ -108,7 +108,10 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
SCM_COMPLEX_IMAG (y)));
}
}
- return SCM_BOOL_F;
+ if (SCM_UNPACK (g_scm_eqv_p))
+ return scm_call_generic_2 (g_scm_eqv_p, x, y);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
diff --git a/oop/ChangeLog b/oop/ChangeLog
index ba475b03a..3bbae6e20 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,6 +1,8 @@
2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (compute-getters-n-setters): Check for bad init-thunk.
+ (eqv?): Added default method.
+ (equal?): New default method which uses eqv?.
2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
diff --git a/oop/goops.scm b/oop/goops.scm
index 08ce58c52..2d53cb94a 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -739,7 +739,8 @@
;;; Methods to compare objects
;;;
-(define-method (equal? x y) #f)
+(define-method (eqv? x y) #f)
+(define-method (equal? x y) (eqv? x y))
;;; These following two methods are for backward compatibility only.
;;; They are not called by the Guile interpreter.
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 216860a3e..d842af7a3 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,7 +1,8 @@
2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* tests/goops.test: Added tests for correctness of class
- precedence list in all basic classes and tests for equal?.
+ precedence list in all basic classes and tests for eqv? and
+ equal?.
2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index f6cc91832..a664000d6 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -136,7 +136,18 @@
(pass-if "overwriting a binding to a non-class"
(eval '(define <foo> #f) (current-module))
(eval '(define-class <foo> ()) (current-module))
- (eval '(is-a? <foo> <class>) (current-module)))))
+ (eval '(is-a? <foo> <class>) (current-module)))
+
+ (expect-fail "bad init-thunk"
+ (catch #t
+ (lambda ()
+ (eval '(define-class <foo> ()
+ (x #:init-thunk (lambda (x) 1)))
+ (current-module))
+ #t)
+ (lambda args
+ #f)))
+ ))
(with-test-prefix "defining generics"
@@ -210,22 +221,50 @@
(current-module))
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
-(with-test-prefix "equal?"
- (pass-if "equal"
+(with-test-prefix "object comparison"
+ (pass-if "default method"
(eval '(begin
(define-class <c> ()
(x #:accessor x #:init-keyword #:x)
(y #:accessor y #:init-keyword #:y))
+ (define o1 (make <c> #:x '(1) #:y '(2)))
+ (define o2 (make <c> #:x '(1) #:y '(3)))
+ (define o3 (make <c> #:x '(4) #:y '(3)))
+ (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>))
(equal? (y a) (y b)))
- (define o1 (make <c> #:x '(1) #:y '(3)))
- (define o2 (make <c> #:x '(2) #:y '(3)))
- (define o3 (make <c> #:x '(2) #:y '(4)))
- (equal? o1 o2))
+ (equal? o2 o3))
(current-module)))
- (pass-if "not equal"
- (eval '(not (equal? o2 o3))
- (current-module))))
+ (pass-if "not equal?"
+ (eval '(not (equal? o1 o2))
+ (current-module)))
+ (pass-if "="
+ (eval '(begin
+ (define-method (= (a <c>) (b <c>))
+ (and (equal? (x a) (x b))
+ (equal? (y a) (y b))))
+ (= o3 o4))
+ (current-module)))
+ (pass-if "not ="
+ (eval '(not (= o1 o2))
+ (current-module)))
+ )
(use-modules (oop goops active-slot))
@@ -260,3 +299,31 @@
before-set! 2 before-ref after-ref after-set! 2 2)))
(current-module))))
+(use-modules (oop goops composite-slot))
+
+(with-test-prefix "composite-slot"
+ (pass-if "creating instance with propagated slot"
+ (eval '(begin
+ (define-class <a> ()
+ (x #:accessor x #:init-keyword #:x)
+ (y #:accessor y #:init-keyword #:y))
+ (define-class <c> ()
+ (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
+ (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
+ (x #:accessor x
+ #:allocation #:propagated
+ #:propagate-to '(o1 (o2 y)))
+ #:metaclass <composite-class>)
+ (define o (make <c>))
+ (is-a? o <c>))
+ (current-module)))
+ (pass-if "reading propagated slot"
+ (eval '(= (x o) 1) (current-module)))
+ (pass-if "writing propagated slot"
+ (eval '(begin
+ (set! (x o) 5)
+ (and (= (x (o1 o)) 5)
+ (= (y (o1 o)) 2)
+ (= (x (o2 o)) 3)
+ (= (y (o2 o)) 5)))
+ (current-module))))