1;;; r6rs-records-procedural.test --- Test suite for R6RS
2;;; (rnrs records procedural)
3
4;;      Copyright (C) 2010 Free Software Foundation, Inc.
5;;
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.
10;;
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.
15;;
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
19
20
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))
26
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))
30
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))
34
35(with-test-prefix "make-record-type-descriptor"
36  (pass-if "simple"
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)))
45      (point? p1)
46      (eqv? (point-x p1) 1)
47      (eqv? (point-y p1) 2)
48      (unspecified? (point-x-set! p1 5))
49      (eqv? (point-x p1) 5)))
50
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)
54							(mutable y))))
55	   (success #f))
56      (call/cc
57       (lambda (continuation)
58	 (with-exception-handler
59	  (lambda (condition)
60            ;; FIXME: While R6RS specifies an assertion violation, by
61            ;; building on core Guile records we just see a Guile
62            ;; condition, which is just &serious.
63	    (set! success (serious-condition? condition))
64	    (continuation))
65	  (lambda () (make-record-type-descriptor
66		      'sealed-point-subtype :sealed-point #f #f #f
67		      '#((mutable z)))))))
68      success))
69
70  (pass-if "non-generative records with same uid are eq"
71    (let* ((:rtd-1 (make-record-type-descriptor
72		    'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
73	   (:rtd-2 (make-record-type-descriptor
74		    'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
75       (eq? :rtd-1 :rtd-2)))
76
77  (pass-if "&assertion raised on conflicting non-generative types"
78    (let* ((:rtd-1 (make-record-type-descriptor
79		    'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
80	   (success 0)
81	   (check-definition
82	    (lambda (thunk)
83	      (call/cc
84	       (lambda (continuation)
85		 (with-exception-handler
86		  (lambda (condition)
87                    ;; FIXME: While R6RS specifies an assertion
88                    ;; violation, by building on core Guile records we
89                    ;; just see a Guile condition, which is just
90                    ;; &serious.
91		    (if (serious-condition? condition)
92			(set! success (+ success 1)))
93		    (continuation))
94		  thunk))))))
95      (check-definition
96       (lambda ()
97	 (make-record-type-descriptor
98	  'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
99      (check-definition
100       (lambda ()
101	 (make-record-type-descriptor
102	  'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
103      (check-definition
104       (lambda ()
105	 (make-record-type-descriptor
106	  'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
107      (check-definition
108       (lambda ()
109	 (make-record-type-descriptor
110	  'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
111      (check-definition
112       (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
113      (check-definition
114       (lambda ()
115	 (make-record-type-descriptor
116	  'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
117      (check-definition
118       (lambda ()
119	 (make-record-type-descriptor
120	  'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
121      (eqv? success 7))))
122
123(with-test-prefix "make-record-constructor-descriptor"
124  (pass-if "simple protocol"
125    (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
126	   (:point-protocol-cd (make-record-constructor-descriptor
127				:point #f :point-protocol))
128	   (make-point (record-constructor :point-protocol-cd))
129	   (point-x (record-accessor :point 0))
130	   (point-y (record-accessor :point 1))
131	   (point (make-point 1 2)))
132      (and (eqv? (point-x point) 2)
133	   (eqv? (point-y point) 3))))
134
135  (pass-if "protocol delegates to parent with protocol"
136    (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
137	   (:point-protocol-cd (make-record-constructor-descriptor
138				:point #f :point-protocol))
139	   (:voxel-protocol (lambda (n)
140			      (lambda (x y z)
141				(let ((p (n x y))) (p (+ z 100))))))
142	   (:voxel-protocol-cd (make-record-constructor-descriptor
143				:voxel :point-protocol-cd :voxel-protocol))
144	   (make-voxel (record-constructor :voxel-protocol-cd))
145	   (point-x (record-accessor :point 0))
146	   (point-y (record-accessor :point 1))
147	   (voxel-z (record-accessor :voxel 0))
148	   (voxel (make-voxel 1 2 3)))
149      (and (eqv? (point-x voxel) 2)
150	   (eqv? (point-y voxel) 3)
151	   (eqv? (voxel-z voxel) 103)))))
152
153(with-test-prefix "record-type-descriptor?"
154  (pass-if "simple"
155    (record-type-descriptor?
156     (make-record-type-descriptor 'test #f #f #f #f '#()))))
157
158(with-test-prefix "record-constructor"
159  (pass-if "simple"
160    (let* ((make-point (record-constructor :point-cd))
161	   (point? (record-predicate :point))
162	   (point-x (record-accessor :point 0))
163	   (point-y (record-accessor :point 1))
164	   (point (make-point 1 2)))
165      (and (point? point)
166	   (eqv? (point-x point) 1)
167	   (eqv? (point-y point) 2))))
168
169  (pass-if "construct record subtype"
170    (let* ((make-voxel (record-constructor :voxel-cd))
171	   (voxel? (record-predicate :voxel))
172	   (voxel-z (record-accessor :voxel 0))
173	   (voxel (make-voxel 1 2 3)))
174      (and (voxel? voxel)
175	   (eqv? (voxel-z voxel) 3)))))
176
177(with-test-prefix "record-predicate"
178  (pass-if "simple"
179    (let* ((make-point (record-constructor :point-cd))
180	   (point (make-point 1 2))
181	   (point? (record-predicate :point)))
182      (point? point)))
183
184  (pass-if "predicate returns true on subtype"
185    (let* ((make-voxel (record-constructor :voxel-cd))
186	   (voxel (make-voxel 1 2 3))
187	   (point? (record-predicate :point)))
188      (point? voxel)))
189
190  (pass-if "predicate returns false on supertype"
191    (let* ((make-point (record-constructor :point-cd))
192	   (point (make-point 1 2))
193	   (voxel? (record-predicate :voxel)))
194      (not (voxel? point)))))
195
196(with-test-prefix "record-accessor"
197  (pass-if "simple"
198    (let* ((make-point (record-constructor :point-cd))
199	   (point (make-point 1 2))
200	   (point-x (record-accessor :point 0))
201	   (point-y (record-accessor :point 1)))
202      (and (eqv? (point-x point) 1)
203	   (eqv? (point-y point) 2))))
204
205  (pass-if "accessor for supertype applied to subtype"
206    (let* ((make-voxel (record-constructor :voxel-cd))
207	   (voxel (make-voxel 1 2 3))
208	   (point-x (record-accessor :point 0))
209	   (point-y (record-accessor :point 1)))
210      (and (eqv? (point-x voxel) 1)
211	   (eqv? (point-y voxel) 2)))))
212
213(with-test-prefix "record-mutator"
214  (pass-if "simple"
215    (let* ((make-point (record-constructor :point-cd))
216	   (point (make-point 1 2))
217	   (point-set-x! (record-mutator :point 0))
218	   (point-set-y! (record-mutator :point 1))
219	   (point-x (record-accessor :point 0))
220	   (point-y (record-accessor :point 1)))
221      (point-set-x! point 3)
222      (point-set-y! point 4)
223      (and (eqv? (point-x point) 3)
224	   (eqv? (point-y point) 4))))
225
226  (pass-if "&assertion raised on request for immutable field"
227    (let* ((:immutable-point (make-record-type-descriptor
228			      'point #f #f #f #f '#((immutable x)
229						    (immutable y))))
230	   (success #f))
231      (call/cc
232       (lambda (continuation)
233	 (with-exception-handler
234	  (lambda (condition)
235	    (set! success (assertion-violation? condition))
236	    (continuation))
237	  (lambda () (record-mutator :immutable-point 0)))))
238      success))
239
240  (pass-if "mutator for supertype applied to subtype"
241    (let* ((make-voxel (record-constructor :voxel-cd))
242	   (voxel (make-voxel 1 2 3))
243	   (point-set-x! (record-mutator :point 0))
244	   (point-set-y! (record-mutator :point 1))
245	   (point-x (record-accessor :point 0))
246	   (point-y (record-accessor :point 1)))
247      (point-set-x! voxel 3)
248      (point-set-y! voxel 4)
249      (and (eqv? (point-x voxel) 3)
250	   (eqv? (point-y voxel) 4)))))
251
252