Commit | Line | Data |
---|---|---|
55684b5e JG |
1 | ;;; r6rs-control.test --- Test suite for R6RS (rnrs control) |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (define-module (test-suite test-rnrs-records-procedural) | |
21 | :use-module ((rnrs conditions) :version (6)) | |
22 | :use-module ((rnrs exceptions) :version (6)) | |
23 | :use-module ((rnrs records inspection) :version (6)) | |
24 | :use-module ((rnrs records procedural) :version (6)) | |
25 | :use-module (test-suite lib)) | |
26 | ||
27 | (with-test-prefix "record?" | |
28 | (pass-if "record? recognizes non-opaque records" | |
29 | (let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#())) | |
30 | (make-rec (record-constructor | |
31 | (make-record-constructor-descriptor rec #f #f)))) | |
32 | (record? (make-rec)))) | |
33 | ||
34 | (pass-if "record? doesn't recognize opaque records" | |
35 | (let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#())) | |
36 | (make-rec (record-constructor | |
37 | (make-record-constructor-descriptor rec #f #f)))) | |
38 | (not (record? (make-rec))))) | |
39 | ||
40 | (pass-if "record? doesn't recognize non-records" (not (record? 'foo)))) | |
41 | ||
42 | (with-test-prefix "record-rtd" | |
43 | (pass-if "simple" | |
44 | (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#())) | |
45 | (make-rec (record-constructor | |
46 | (make-record-constructor-descriptor rtd #f #f)))) | |
47 | (eq? (record-rtd (make-rec)) rtd))) | |
48 | ||
49 | (pass-if "&assertion on opaque record" | |
50 | (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#())) | |
51 | (make-rec (record-constructor | |
52 | (make-record-constructor-descriptor rtd #f #f))) | |
53 | (success #f)) | |
54 | (call/cc | |
55 | (lambda (continuation) | |
56 | (with-exception-handler | |
57 | (lambda (condition) | |
58 | (set! success (assertion-violation? condition)) | |
59 | (continuation)) | |
60 | (lambda () (record-rtd (make-rec)))))) | |
61 | success))) | |
62 | ||
63 | (with-test-prefix "record-type-name" | |
64 | (pass-if "simple" | |
65 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) | |
66 | (eq? (record-type-name rtd) 'foo)))) | |
67 | ||
68 | (with-test-prefix "record-type-parent" | |
69 | (pass-if "eq? to parent" | |
70 | (let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#())) | |
71 | (rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#()))) | |
72 | (eq? (record-type-parent rtd) rtd-parent))) | |
73 | ||
74 | (pass-if "#f when parent not present" | |
75 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) | |
76 | (not (record-type-parent rtd))))) | |
77 | ||
78 | (with-test-prefix "record-type-uid" | |
79 | (pass-if "eq? to uid" | |
80 | (let* ((uid (gensym)) | |
81 | (rtd (make-record-type-descriptor uid #f uid #f #f '#()))) | |
82 | (eq? (record-type-uid rtd) uid))) | |
83 | ||
84 | (pass-if "#f when uid not present" | |
85 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) | |
86 | (not (record-type-uid rtd))))) | |
87 | ||
88 | (with-test-prefix "record-type-generative?" | |
f797da47 | 89 | (pass-if "#f when uid is not #f" |
55684b5e JG |
90 | (let* ((uid (gensym)) |
91 | (rtd (make-record-type-descriptor uid #f uid #f #f '#()))) | |
f797da47 | 92 | (not (record-type-generative? rtd)))) |
55684b5e | 93 | |
f797da47 | 94 | (pass-if "#t when uid is #f" |
55684b5e | 95 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) |
f797da47 | 96 | (record-type-generative? rtd)))) |
55684b5e JG |
97 | |
98 | (with-test-prefix "record-type-sealed?" | |
99 | (pass-if "#t when sealed? is #t" | |
100 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#()))) | |
101 | (record-type-sealed? rtd))) | |
102 | ||
103 | (pass-if "#f when sealed? is #f" | |
104 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) | |
105 | (not (record-type-sealed? rtd))))) | |
106 | ||
107 | (with-test-prefix "record-type-opaque?" | |
108 | (pass-if "#t when opaque? is #t" | |
109 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))) | |
110 | (record-type-opaque? rtd))) | |
111 | ||
112 | (pass-if "#f when opaque? is #f" | |
113 | (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#()))) | |
114 | (not (record-type-opaque? rtd)))) | |
115 | ||
116 | (pass-if "#t when parent is opaque" | |
117 | (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#())) | |
118 | (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#()))) | |
119 | (record-type-opaque? rtd)))) | |
120 | ||
121 | (with-test-prefix "record-type-field-names" | |
122 | (pass-if "simple" | |
123 | (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f | |
124 | '#((immutable foo) | |
125 | (mutable bar))))) | |
126 | (equal? (record-type-field-names rtd) '#(foo bar)))) | |
127 | ||
128 | (pass-if "parent fields not included" | |
129 | (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f | |
130 | '#((mutable foo)))) | |
131 | (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f | |
132 | '#((immutable bar))))) | |
133 | (equal? (record-type-field-names rtd) '#(bar)))) | |
134 | ||
135 | (pass-if "subtype fields not included" | |
136 | (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f | |
137 | '#((mutable foo)))) | |
138 | (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f | |
139 | '#((immutable bar))))) | |
140 | (equal? (record-type-field-names parent-rtd) '#(foo))))) | |
141 | ||
142 | (with-test-prefix "record-field-mutable?" | |
143 | (pass-if "simple" | |
144 | (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f | |
145 | '#((mutable foo) | |
146 | (immutable bar))))) | |
147 | (and (record-field-mutable? rtd 0) | |
148 | (not (record-field-mutable? rtd 1)))))) |