~ chicken-core (chicken-5) b5c8d59e83b7c654e6f79dee91476470ac07b882
commit b5c8d59e83b7c654e6f79dee91476470ac07b882
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Mar 16 16:12:04 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Mar 16 16:12:04 2010 +0100
define-record-type allows using setters for modifier; added testcase
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 8e15d715..67258488 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -900,10 +900,13 @@
(##sys#extend-macro-environment
'define-record-type
- `((getter-with-setter . (##sys#primitive-alias 'getter-with-setter)))
+ `((getter-with-setter . ,(##sys#primitive-alias 'getter-with-setter)))
(##sys#er-transformer
(lambda (form r c)
- (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
+ (##sys#check-syntax
+ 'define-record-type
+ form
+ '(_ variable #(variable 1) variable . _))
(let* ((t (cadr form))
(conser (caddr form))
(pred (cadddr form))
@@ -930,21 +933,42 @@
,@(let loop ([slots slots] [i 1])
(if (null? slots)
'()
- (let* ([slot (car slots)]
- (setters (memq #:record-setters ##sys#features))
- (setr? (pair? (cddr slot)))
- (getr `(,%lambda (,x)
- (##core#check (##sys#check-structure ,x (,%quote ,t)))
- (##sys#block-ref ,x ,i) ) ) )
- `(,@(if setr?
- `((,%define (,(caddr slot) ,x ,y)
- (##core#check (##sys#check-structure ,x (,%quote ,t)))
- (##sys#block-set! ,x ,i ,y)) )
- '() )
- (,%define ,(cadr slot)
- ,(if (and setr? setters)
- `(,%getter-with-setter ,getr ,(caddr slot))
- getr) )
+ (let* ((slot (car slots))
+ (settable (pair? (cddr slot)))
+ (setr (and settable (caddr slot)))
+ (ssetter (and (pair? setr)
+ (pair? (cdr setr))
+ (c 'setter (car setr))
+ (cadr setr)))
+ (get `(,%lambda
+ (,x)
+ (##core#check
+ (##sys#check-structure
+ ,x
+ (,%quote ,t)
+ (,%quote ,(cadr slot))))
+ (##sys#block-ref ,x ,i) ) )
+ (set (and settable
+ `(,%lambda
+ (,x ,y)
+ (##core#check
+ (##sys#check-structure
+ ,x
+ (,%quote ,t)
+ (,%quote ,ssetter)))
+ (##sys#block-set! ,x ,i ,y)) )))
+ `((,%define
+ ,(cadr slot)
+ ,(if (and ssetter (c ssetter (cadr slot)))
+ `(,%getter-with-setter ,get ,set)
+ get))
+ ,@(if settable
+ (if ssetter
+ (if (not (c ssetter (cadr slot)))
+ `(((##sys#setter ##sys#setter) ,ssetter ,set))
+ '())
+ `((,%define ,setr ,set)))
+ '())
,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
diff --git a/distribution/manifest b/distribution/manifest
index 3aa8723b..ae8b04f6 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -167,6 +167,7 @@ tests/test.tex
tests/slatex.sty
tests/symbolgc-tests.scm
tests/private-repository-test.scm
+tests/records-and-setters-test.scm
tweaks.scm
utils.scm
apply-hack.x86.S
diff --git a/expand.scm b/expand.scm
index 1df2b394..bd37221c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -57,7 +57,7 @@
(no-procedure-checks)))
(else))
-#;(begin
+(begin
(define-syntax dd (syntax-rules () ((_ . _) (void))))
(define-syntax dm (syntax-rules () ((_ . _) (void))))
(define-syntax dc (syntax-rules () ((_ . _) (void)))) )
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 96db2094..d6df43d2 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -397,6 +397,11 @@ and updated using {{(NAME-SLOTNAME-set!}} {{STRUCT}} {{VALUE)}}.
SRFI-9 record types. For more information see the documentation for
[[http://srfi.schemers.org/srfi-9/srfi-9.html|SRFI-9]].
+As an extension the {{MODIFIER}} may have the form {{(setter PROCEDURE)}},
+which will define a SRFI-17 setter-procedure for the given {{PROCEDURE}}
+that sets the field value. Usually {{PROCEDURE}} has the same name
+is {{ACCESSOR}} (but it doesn't have to).
+
==== define-record-printer
diff --git a/tests/dirty-macros.scm b/tests/dirty-macros.scm
index 80fd6556..d6f9490b 100644
--- a/tests/dirty-macros.scm
+++ b/tests/dirty-macros.scm
@@ -1119,17 +1119,17 @@
((lambda (v) (let* rest . bodies)) i))))
; ((_ . args) (glet* (let let* letrec lambda) . args))))
-;(display (let* ((foo 2)) (list foo (mm "mm"))))
+(display (let* ((foo 2)) (list foo (mm "mm"))))
-; (display
-; (let* ((foo 2)
-; (i 3)
-; (foo 4)
-; (ft (lambda () (mm "mm"))) ; will capture binding of foo to 4
-; (foo 5)
-; (ft1 (lambda (foo) (mm "mm"))) ; will capture the arg of ft1
-; (foo 6))
-; (list foo (mm "mm") (ft) (ft1 7) '(mm "mm"))))
+(display
+ (let* ((foo 2)
+ (i 3)
+ (foo 4)
+ (ft (lambda () (mm "mm"))) ; will capture binding of foo to 4
+ (foo 5)
+ (ft1 (lambda (foo) (mm "mm"))) ; will capture the arg of ft1
+ (foo 6))
+ (list foo (mm "mm") (ft) (ft1 7) '(mm "mm"))))
(newline)
; ==> (6 6 4 7 (mm))
diff --git a/tests/records-and-setters-test.scm b/tests/records-and-setters-test.scm
new file mode 100644
index 00000000..3840d7e3
--- /dev/null
+++ b/tests/records-and-setters-test.scm
@@ -0,0 +1,23 @@
+;;;; records-and-setters-test.scm
+
+
+;;; define-record-type with setters
+
+(define-record-type foo
+ (make-foo x y z t)
+ foo?
+ (x get-x)
+ (y get-y set-y)
+ (z get-z (setter get-z))
+ (t get-t (setter make-foo)))
+
+(let ((f (make-foo 1 2 3 4)))
+ (assert (foo? f))
+ (assert (= 1 (get-x f)))
+ (assert (= 2 (get-y f)))
+ (set-y f 99)
+ (assert (= 99 (get-y f)))
+ (set! (get-z f) 100)
+ (assert (= 100 (get-z f)))
+ (set! (make-foo f) 1000)
+ (assert (= 1000 (get-t f))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index e95fe19a..6edcfd61 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -70,6 +70,9 @@ $compile test-gc-hooks.scm
echo "======================================== library tests ..."
$interpret -s library-tests.scm
+$interpret -s records-and-setters-test.scm
+$compile records-and-setters-test.scm
+./a.out
echo "======================================== syntax tests ..."
$interpret -s syntax-tests.scm
@@ -211,6 +214,9 @@ echo "======================================== locative stress test ..."
$compile locative-stress-test.scm
./a.out
+echo "======================================== syntax-rules stress test ..."
+time $interpret syntax-rule-stress-test.scm
+
echo "======================================== embedding (1) ..."
$compile embedded1.c
./a.out
Trap