diff options
author | Andy Wingo <wingo@pobox.com> | 2011-03-08 09:30:33 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-03-08 20:53:17 +0100 |
commit | 534491d0b7fcd17558751110610bcef971d414a8 (patch) | |
tree | f4b8d2f50f7836ce213611f6cfb8ac6da7e83a34 | |
parent | 0b0e066a26b437f7320abd126ec05a7a7c056dd9 (diff) | |
download | guile-534491d0b7fcd17558751110610bcef971d414a8.tar.gz |
fix scm_setter
* libguile/procs.c (scm_setter): Only get at the setter slot if the pure
generic actually has a setter. Needs test.
* test-suite/tests/goops.test ("defining generics"):
("defining accessors"): Add `setter' tests.
-rw-r--r-- | libguile/procs.c | 3 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 11 |
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)) |