summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/procs.c3
-rw-r--r--test-suite/tests/goops.test11
2 files changed, 11 insertions, 3 deletions
diff --git a/libguile/procs.c b/libguile/procs.c
index 2b7225efe..a096591df 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -149,7 +149,8 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
if (SCM_STRUCT_SETTER_P (proc))
return SCM_STRUCT_SETTER (proc);
- if (SCM_PUREGENERICP (proc))
+ if (SCM_PUREGENERICP (proc)
+ && SCM_IS_A_P (proc, scm_class_generic_with_setter))
/* FIXME: might not be an accessor */
return SCM_GENERIC_SETTER (proc);
SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 908d1e7ae..2bf7d698b 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -234,7 +234,11 @@
(eval '(define-generic foo) (current-module))
(eval '(and (is-a? foo <generic>)
(null? (generic-function-methods foo)))
- (current-module)))))
+ (current-module)))
+
+ (pass-if-exception "getters do not have setters"
+ exception:wrong-type-arg
+ (eval '(setter foo) (current-module)))))
(with-test-prefix "defining methods"
@@ -294,6 +298,9 @@
(null? (generic-function-methods foo-1)))
(current-module)))
+ (pass-if "accessors have setters"
+ (procedure? (eval '(setter foo-1) (current-module))))
+
(pass-if "overwriting a top-level binding to a non-accessor"
(eval '(define (foo) #f) (current-module))
(eval '(define-accessor foo) (current-module))