~ chicken-core (chicken-5) 1831914f6d98daec95bcbf138f872061f3545532

commit 1831914f6d98daec95bcbf138f872061f3545532
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Oct 18 09:01:56 2010 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Oct 18 09:01:56 2010 -0400

    optional slot-setter for define-record

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 4c049424..fe7ff62c 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -57,48 +57,67 @@
  'define-record '()
  (##sys#er-transformer
   (lambda (x r c)
-    (##sys#check-syntax 'define-record x '(_ symbol . #(symbol 0)))
+    (##sys#check-syntax 'define-record x '(_ symbol . _))
     (let* ((name (cadr x))
 	   (slots (cddr x))
 	   (prefix (symbol->string name))
-	   (setters (memq #:record-setters ##sys#features))
 	   (%define (r 'define))
-	   (%getter-with-setter (r 'getter-with-setter)))
+	   (%setter (r 'setter))
+	   (%getter-with-setter (r 'getter-with-setter))
+	   (slotnames
+	    (map (lambda (slot)
+		   (cond ((symbol? slot) slot)
+			 ((and (pair? slot)
+			       (c (car slot) %setter) 
+			       (pair? (cdr slot))
+			       (symbol? (cadr slot))
+			       (null? (cddr slot)))
+			  (cadr slot))
+			 (else
+			  (syntax-error 
+			   'define-record "invalid slot specification" slot))))
+		 slots)))
       `(##core#begin
-	  (,%define 
-	   ,(string->symbol (string-append "make-" prefix))
-	   (##core#lambda ,slots (##sys#make-structure (##core#quote ,name) ,@slots)) )
-	  (,%define
-	   ,(string->symbol (string-append prefix "?"))
-	   (##core#lambda (x) (##sys#structure? x ',name)) )
-	  ,@(let mapslots ((slots slots) (i 1))
-	      (if (eq? slots '())
-		  slots
-		  (let* ((slotname (symbol->string (##sys#slot slots 0)))
-			 (setr (string->symbol (string-append prefix "-" slotname "-set!")))
-			 (getr (string->symbol (string-append prefix "-" slotname)) ) )
-		    (cons
-		     `(##core#begin
-			(,%define
-			 ,setr
-			 (##core#lambda 
+	(,%define 
+	 ,(string->symbol (string-append "make-" prefix))
+	 (##core#lambda 
+	  ,slotnames
+	  (##sys#make-structure (##core#quote ,name) ,@slotnames)))
+	(,%define
+	 ,(string->symbol (string-append prefix "?"))
+	 (##core#lambda (x) (##sys#structure? x ',name)) )
+	,@(let mapslots ((slots slots) (i 1))
+	    (if (eq? slots '())
+		slots
+		(let* ((a (car slots))
+		       (has-setter (not (symbol? a)))
+		       (slotname (symbol->string (if has-setter (cadr a) a)))
+		       (setr (string->symbol (string-append prefix "-" slotname "-set!")))
+		       (getr (string->symbol (string-append prefix "-" slotname)))
+		       (setrcode
+			`(##core#lambda 
 			  (x val)
 			  (##core#check (##sys#check-structure x (##core#quote ,name)))
-			  (##sys#block-set! x ,i val) ) )
-			(,%define
-			 ,getr
-			 ,(if setters
-			      `(,%getter-with-setter
-				(##core#lambda
-				 (x) 
-				 (##core#check (##sys#check-structure x (##core#quote ,name)))
-				 (##sys#block-ref x ,i) )
-				,setr)
-			      `(##core#lambda 
-				(x)
-				(##core#check (##sys#check-structure x (##core#quote ,name)))
-				(##sys#block-ref x ,i) ) ) ) )
-		     (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
+			  (##sys#block-set! x ,i val) ) ))
+		  (cons
+		   `(##core#begin
+		     ,@(if has-setter
+			   '()
+			   `((,%define ,setr ,setrcode)))
+		     (,%define
+		      ,getr
+		      ,(if has-setter
+			   `(,%getter-with-setter
+			     (##core#lambda
+			      (x) 
+			      (##core#check (##sys#check-structure x (##core#quote ,name)))
+			      (##sys#block-ref x ,i) )
+			     ,setrcode)
+			   `(##core#lambda 
+			     (x)
+			     (##core#check (##sys#check-structure x (##core#quote ,name)))
+			     (##sys#block-ref x ,i) ) ) ) )
+		   (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
 
 (##sys#extend-macro-environment
  'receive
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 1eca9831..4d4e4923 100644
--- a/manual/Non-standard macros and special forms	
+++ b/manual/Non-standard macros and special forms	
@@ -392,6 +392,14 @@ and updated using {{(NAME-SLOTNAME-set!}} {{STRUCT}} {{VALUE)}}.
 (point-y p1)                     ==> 99
 </enscript>
 
+{{SLOTNAME}} may alternatively also be of the form
+
+  (setter SLOTNAME)
+
+In this case the slot can be read with {{(NAME-SLOTNAME STRUCT)}}
+and written with {{(set! (NAME-SLOTNAME STRUCT) VALUE)}} (the slot-accessor
+has an associated SRFI-17 "setter" procedure).
+
 ==== define-record-type
 
 <macro>(define-record-type NAME (CONSTRUCTOR TAG ...) PREDICATE (FIELD ACCESSOR [MODIFIER]) ...)</macro>
diff --git a/tests/records-and-setters-test.scm b/tests/records-and-setters-test.scm
index 3840d7e3..a8761229 100644
--- a/tests/records-and-setters-test.scm
+++ b/tests/records-and-setters-test.scm
@@ -21,3 +21,15 @@
   (assert (= 100 (get-z f)))
   (set! (make-foo f) 1000)
   (assert (= 1000 (get-t f))))
+
+(define-record bar
+  a
+  (setter b))
+
+(let ((b (make-bar 1 2)))
+  (assert (bar? b))
+  (bar-a-set! b 3)
+  (assert (= 3 (bar-a b)))
+  (setter bar-b)
+  (set! (bar-b b) 4)
+  (assert (= (bar-b b) 4)))