1 ;;; r6rs-records-procedural.test --- Test suite for R6RS
2 ;;; (rnrs records procedural)
4 ;; Copyright (C) 2010 Free Software Foundation, Inc.
6 ;; This library is free software; you can redistribute it and/or
7 ;; modify it under the terms of the GNU Lesser General Public
8 ;; License as published by the Free Software Foundation; either
9 ;; version 3 of the License, or (at your option) any later version.
11 ;; This library is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; Lesser General Public License for more details.
16 ;; You should have received a copy of the GNU Lesser General Public
17 ;; License along with this library; if not, write to the Free Software
18 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 (define-module (test-suite test-rnrs-records-procedural)
22 :use-module ((rnrs conditions) :version (6))
23 :use-module ((rnrs exceptions) :version (6))
24 :use-module ((rnrs records procedural) :version (6))
25 :use-module (test-suite lib))
27 (define :point (make-record-type-descriptor
28 'point #f #f #f #f '#((mutable x) (mutable y))))
29 (define :point-cd (make-record-constructor-descriptor :point #f #f))
31 (define :voxel (make-record-type-descriptor
32 'voxel :point #f #f #f '#((mutable z))))
33 (define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))
35 (with-test-prefix "make-record-type-descriptor"
37 (let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
38 (make-point (record-constructor :point-cd))
39 (point? (record-predicate :point))
40 (point-x (record-accessor :point 0))
41 (point-y (record-accessor :point 1))
42 (point-x-set! (record-mutator :point 0))
43 (point-y-set! (record-mutator :point 1))
44 (p1 (make-point 1 2)))
48 (unspecified? (point-x-set! p1 5))
49 (eqv? (point-x p1) 5)))
51 (pass-if "sealed records cannot be subtyped"
52 (let* ((:sealed-point (make-record-type-descriptor
53 'sealed-point #f #f #t #f '#((mutable x)
57 (lambda (continuation)
58 (with-exception-handler
60 (set! success (assertion-violation? condition))
62 (lambda () (make-record-type-descriptor
63 'sealed-point-subtype :sealed-point #f #f #f
67 (pass-if "non-generative records with same uid are eq"
68 (let* ((:rtd-1 (make-record-type-descriptor
69 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
70 (:rtd-2 (make-record-type-descriptor
71 'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
74 (pass-if "&assertion raised on conflicting non-generative types"
75 (let* ((:rtd-1 (make-record-type-descriptor
76 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
81 (lambda (continuation)
82 (with-exception-handler
84 (if (assertion-violation? condition)
85 (set! success (+ success 1)))
90 (make-record-type-descriptor
91 'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
94 (make-record-type-descriptor
95 'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
98 (make-record-type-descriptor
99 'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
102 (make-record-type-descriptor
103 'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
105 (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
108 (make-record-type-descriptor
109 'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
112 (make-record-type-descriptor
113 'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
116 (with-test-prefix "make-record-constructor-descriptor"
117 (pass-if "simple protocol"
118 (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
119 (:point-protocol-cd (make-record-constructor-descriptor
120 :point #f :point-protocol))
121 (make-point (record-constructor :point-protocol-cd))
122 (point-x (record-accessor :point 0))
123 (point-y (record-accessor :point 1))
124 (point (make-point 1 2)))
125 (and (eqv? (point-x point) 2)
126 (eqv? (point-y point) 3))))
128 (pass-if "protocol delegates to parent with protocol"
129 (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
130 (:point-protocol-cd (make-record-constructor-descriptor
131 :point #f :point-protocol))
132 (:voxel-protocol (lambda (n)
134 (let ((p (n x y))) (p (+ z 100))))))
135 (:voxel-protocol-cd (make-record-constructor-descriptor
136 :voxel :point-protocol-cd :voxel-protocol))
137 (make-voxel (record-constructor :voxel-protocol-cd))
138 (point-x (record-accessor :point 0))
139 (point-y (record-accessor :point 1))
140 (voxel-z (record-accessor :voxel 0))
141 (voxel (make-voxel 1 2 3)))
142 (and (eqv? (point-x voxel) 2)
143 (eqv? (point-y voxel) 3)
144 (eqv? (voxel-z voxel) 103)))))
146 (with-test-prefix "record-type-descriptor?"
148 (record-type-descriptor?
149 (make-record-type-descriptor 'test #f #f #f #f '#()))))
151 (with-test-prefix "record-constructor"
153 (let* ((make-point (record-constructor :point-cd))
154 (point? (record-predicate :point))
155 (point-x (record-accessor :point 0))
156 (point-y (record-accessor :point 1))
157 (point (make-point 1 2)))
159 (eqv? (point-x point) 1)
160 (eqv? (point-y point) 2))))
162 (pass-if "construct record subtype"
163 (let* ((make-voxel (record-constructor :voxel-cd))
164 (voxel? (record-predicate :voxel))
165 (voxel-z (record-accessor :voxel 0))
166 (voxel (make-voxel 1 2 3)))
168 (eqv? (voxel-z voxel) 3)))))
170 (with-test-prefix "record-predicate"
172 (let* ((make-point (record-constructor :point-cd))
173 (point (make-point 1 2))
174 (point? (record-predicate :point)))
177 (pass-if "predicate returns true on subtype"
178 (let* ((make-voxel (record-constructor :voxel-cd))
179 (voxel (make-voxel 1 2 3))
180 (point? (record-predicate :point)))
183 (pass-if "predicate returns false on supertype"
184 (let* ((make-point (record-constructor :point-cd))
185 (point (make-point 1 2))
186 (voxel? (record-predicate :voxel)))
187 (not (voxel? point)))))
189 (with-test-prefix "record-accessor"
191 (let* ((make-point (record-constructor :point-cd))
192 (point (make-point 1 2))
193 (point-x (record-accessor :point 0))
194 (point-y (record-accessor :point 1)))
195 (and (eqv? (point-x point) 1)
196 (eqv? (point-y point) 2))))
198 (pass-if "accessor for supertype applied to subtype"
199 (let* ((make-voxel (record-constructor :voxel-cd))
200 (voxel (make-voxel 1 2 3))
201 (point-x (record-accessor :point 0))
202 (point-y (record-accessor :point 1)))
203 (and (eqv? (point-x voxel) 1)
204 (eqv? (point-y voxel) 2)))))
206 (with-test-prefix "record-mutator"
208 (let* ((make-point (record-constructor :point-cd))
209 (point (make-point 1 2))
210 (point-set-x! (record-mutator :point 0))
211 (point-set-y! (record-mutator :point 1))
212 (point-x (record-accessor :point 0))
213 (point-y (record-accessor :point 1)))
214 (point-set-x! point 3)
215 (point-set-y! point 4)
216 (and (eqv? (point-x point) 3)
217 (eqv? (point-y point) 4))))
219 (pass-if "&assertion raised on request for immutable field"
220 (let* ((:immutable-point (make-record-type-descriptor
221 'point #f #f #f #f '#((immutable x)
225 (lambda (continuation)
226 (with-exception-handler
228 (set! success (assertion-violation? condition))
230 (lambda () (record-mutator :immutable-point 0)))))
233 (pass-if "mutator for supertype applied to subtype"
234 (let* ((make-voxel (record-constructor :voxel-cd))
235 (voxel (make-voxel 1 2 3))
236 (point-set-x! (record-mutator :point 0))
237 (point-set-y! (record-mutator :point 1))
238 (point-x (record-accessor :point 0))
239 (point-y (record-accessor :point 1)))
240 (point-set-x! voxel 3)
241 (point-set-y! voxel 4)
242 (and (eqv? (point-x voxel) 3)
243 (eqv? (point-y voxel) 4)))))