~ chicken-core (chicken-5) fad240593129b82ce3f8f3ad3382f1fcf3f32f55

commit fad240593129b82ce3f8f3ad3382f1fcf3f32f55
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Nov 8 20:46:31 2010 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Nov 8 20:46:31 2010 +0100

    `getter-with-setter' was modifying the getter instead of creating a new
    closure when the getter already had a setter slot - the bugger.

diff --git a/library.scm b/library.scm
index 8b3fe0e8..2be137a5 100644
--- a/library.scm
+++ b/library.scm
@@ -1980,6 +1980,8 @@ EOF
 
 
 ;;; Decorate procedure with arbitrary data
+;
+; warning: may modify proc, if it already has a suitable decoration!
 
 (define (##sys#decorate-lambda proc pred decorator)
   (let ((len (##sys#size proc)))
@@ -2078,7 +2080,7 @@ EOF
 		       (##sys#make-lambda-info info))
 		      (else (##sys#lambda-info get))))
 	(p1 (##sys#decorate-lambda
-	     get
+	     (##sys#copy-closure get)
 	     setter?
 	     (lambda (proc i)
 	       (##sys#setslot proc i (cons setter-tag set))
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 69e21ec4..a41dc61f 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -146,3 +146,27 @@
 (assert (equal? '#${ab c} '#${ab0c}))
 (assert (equal? '#${abc} '#${ab0c}))
 (assert (equal? '#${a b c} '#${0a0b0c}))
+
+
+;;; getter-with-setter
+
+(define foo
+  (let ((m 2))
+    (getter-with-setter
+     (lambda (x) (* x m))
+     (lambda (x) 
+       (set! m x)))))
+
+(assert (= 6 (foo 3)))
+(set! (foo) 4)
+(assert (= 20 (foo 5)))
+
+(define bar
+  (getter-with-setter
+   foo
+   (lambda (x)
+     (+ x 99))))
+
+(assert (= 12 (bar 3)))
+(assert (= 100 (set! (bar) 1)))
+(assert (= 12 (foo 3)))