7 |
(declaim (optimize (safety 3))) |
(declaim (optimize (safety 3))) |
8 |
|
|
9 |
(defun make-struct-test-name (structure-name n) |
(defun make-struct-test-name (structure-name n) |
10 |
(declare (type (or string symbol character) structure-name) |
;; (declare (type (or string symbol character) structure-name) |
11 |
(type fixnum n)) |
;; (type fixnum n)) |
12 |
|
(assert (typep structure-name '(or string symbol character))) |
13 |
|
(assert (typep n 'fixnum)) |
14 |
(setf structure-name (string structure-name)) |
(setf structure-name (string structure-name)) |
15 |
(intern (concatenate 'string |
(intern (concatenate 'string |
16 |
structure-name |
structure-name |
17 |
"-STRUCT-TEST-" |
"/" |
18 |
(princ-to-string n)) |
(princ-to-string n)))) |
|
:cl-test)) |
|
19 |
|
|
20 |
(defun make-struct-p-fn (structure-name) |
(defun make-struct-p-fn (structure-name) |
21 |
|
(assert (typep structure-name '(or string symbol character))) |
22 |
(setf structure-name (string structure-name)) |
(setf structure-name (string structure-name)) |
23 |
(intern (concatenate 'string |
(intern (concatenate 'string |
24 |
structure-name |
structure-name |
25 |
"-P") |
"-P"))) |
|
:cl-test)) |
|
26 |
|
|
27 |
(defun make-struct-copy-fn (structure-name) |
(defun make-struct-copy-fn (structure-name) |
28 |
(setf structure-name (string structure-name)) |
(assert (typep structure-name '(or string symbol character))) |
29 |
(intern (concatenate 'string |
(setf structure-name (string structure-name)) |
30 |
"COPY-" |
(intern (concatenate 'string |
31 |
structure-name) |
"COPY-" |
32 |
:cl-test)) |
structure-name))) |
33 |
|
|
34 |
(defun make-struct-field-fn (structure-name field-name) |
(defun make-struct-field-fn (conc-name field-name) |
35 |
"Make field accessor for a field in a structure" |
"Make field accessor for a field in a structure" |
36 |
(setf structure-name (string structure-name)) |
(assert (typep conc-name '(or string symbol character))) |
37 |
|
(assert (typep field-name '(or string symbol character))) |
38 |
|
(setf conc-name (string conc-name)) |
39 |
(setf field-name (string field-name)) |
(setf field-name (string field-name)) |
40 |
(intern (concatenate 'string |
(intern (concatenate 'string conc-name field-name))) |
|
structure-name "-" field-name) |
|
|
:cl-test)) |
|
41 |
|
|
42 |
(defun make-struct-make-fn (structure-name) |
(defun make-struct-make-fn (structure-name) |
43 |
"Make the make- function for a structure" |
"Make the make- function for a structure" |
44 |
|
(assert (typep structure-name '(or string symbol character))) |
45 |
(setf structure-name (string structure-name)) |
(setf structure-name (string structure-name)) |
46 |
(intern (concatenate 'string |
(intern (concatenate 'string |
47 |
"MAKE-" structure-name) |
"MAKE-" structure-name))) |
|
:cl-test)) |
|
48 |
|
|
49 |
(defun create-instance-of-type (type) |
(defun create-instance-of-type (type) |
50 |
"Return an instance of a type. Signal an error if |
"Return an instance of a type. Signal an error if |
95 |
(create-instance-of-type (second type))) |
(create-instance-of-type (second type))) |
96 |
(t (error "Cannot generate element for type ~S~%" type)))) |
(t (error "Cannot generate element for type ~S~%" type)))) |
97 |
|
|
98 |
|
(defun find-option (option-list option &optional default) |
99 |
|
(loop for opt in option-list |
100 |
|
when (or (eq opt option) |
101 |
|
(and (consp opt) |
102 |
|
(eq (car opt) option))) |
103 |
|
return opt |
104 |
|
finally (return default))) |
105 |
|
|
106 |
;; |
;; |
107 |
;; There are a number of standardized tests for |
;; There are a number of standardized tests for |
108 |
;; structures. The following macro generates the |
;; structures. The following macro generates the |
113 |
(name-and-options &body slot-descriptions-and-documentation) |
(name-and-options &body slot-descriptions-and-documentation) |
114 |
"Construct standardized tests for a defstruct, and also |
"Construct standardized tests for a defstruct, and also |
115 |
do the defstruct." |
do the defstruct." |
116 |
(let* ((doc-string |
(defstruct-with-tests-fun name-and-options |
117 |
(when (and (consp slot-descriptions-and-documentation) |
slot-descriptions-and-documentation)) |
118 |
(stringp (car slot-descriptions-and-documentation))) |
|
119 |
(car slot-descriptions-and-documentation))) |
(defun defstruct-with-tests-fun (name-and-options |
120 |
|
slot-descriptions-and-documentation) |
121 |
|
;; Function called from macro defstruct-with-tests |
122 |
|
(let* ( |
123 |
|
;; Either NIL or the documentation string for the structure |
124 |
|
(doc-string |
125 |
|
(when (and (consp slot-descriptions-and-documentation) |
126 |
|
(stringp (car slot-descriptions-and-documentation))) |
127 |
|
(car slot-descriptions-and-documentation))) |
128 |
|
|
129 |
|
;; The list of slot descriptions that follows either the |
130 |
|
;; name and options or the doc string |
131 |
(slot-descriptions |
(slot-descriptions |
132 |
(if doc-string (cdr slot-descriptions-and-documentation) |
(if doc-string (cdr slot-descriptions-and-documentation) |
133 |
slot-descriptions-and-documentation)) |
slot-descriptions-and-documentation)) |
134 |
|
|
135 |
|
;; The name of the structure (should be a symbol) |
136 |
(name (if (consp name-and-options) |
(name (if (consp name-and-options) |
137 |
(car name-and-options) |
(car name-and-options) |
138 |
name-and-options)) |
name-and-options)) |
139 |
|
;; The options list, or NIL if there were no options |
140 |
(options (if (consp name-and-options) |
(options (if (consp name-and-options) |
141 |
(cdr name-and-options) |
(cdr name-and-options) |
142 |
nil)) |
nil)) |
143 |
|
|
144 |
|
;; List of symbols that are the names of the slots |
145 |
(slot-names |
(slot-names |
146 |
(loop |
(loop |
147 |
for x in slot-descriptions collect |
for x in slot-descriptions collect |
148 |
(if (consp x) (car x) x))) |
(if (consp x) (car x) x))) |
149 |
|
|
150 |
|
;; Symbol obtained by prepending MAKE- to the name symbol |
151 |
(make-fn (make-struct-make-fn name)) |
(make-fn (make-struct-make-fn name)) |
152 |
(p-fn (make-struct-p-fn name)) |
|
153 |
(copy-fn (make-struct-copy-fn name)) |
;; The :predicate option entry from OPTIONS, or NIL if none |
154 |
|
(predicate-option (find-option options :predicate)) |
155 |
|
|
156 |
|
;; The name of the -P function, either the default or the |
157 |
|
;; one specified in the :predicate option |
158 |
|
(p-fn (cond |
159 |
|
((or (eq predicate-option :predicate) |
160 |
|
(null (cdr predicate-option))) |
161 |
|
(make-struct-p-fn name)) |
162 |
|
((cadr predicate-option) (cadr predicate-option)) |
163 |
|
(t nil))) |
164 |
|
|
165 |
|
;; The :copier option, or NIL if no such option specified |
166 |
|
(copier-option (find-option options :copier)) |
167 |
|
;; The name of the copier function, either the default or |
168 |
|
;; one speciefied in the :copier option |
169 |
|
(copy-fn (cond |
170 |
|
((or (eq copier-option :copier) |
171 |
|
(null (cdr copier-option))) |
172 |
|
(make-struct-copy-fn name)) |
173 |
|
((cadr copier-option) (cadr copier-option)) |
174 |
|
(t nil))) |
175 |
|
|
176 |
|
;; The :conc-name option, or NIL if none specified |
177 |
|
(conc-option (find-option options :conc-name)) |
178 |
|
;; String to be prepended to slot names to get the |
179 |
|
;; slot accessor function |
180 |
|
(conc-prefix (cond |
181 |
|
((null conc-option) |
182 |
|
(concatenate 'string (string name) "-")) |
183 |
|
((or (eq conc-option :conc-name) |
184 |
|
(null (cadr conc-option))) |
185 |
|
"") |
186 |
|
(t (string (cadr conc-option))))) |
187 |
|
|
188 |
;; a list of initial values |
;; a list of initial values |
189 |
(initial-value-alist |
(initial-value-alist |
190 |
(loop |
(loop |
197 |
(cdr slot-desc) |
(cdr slot-desc) |
198 |
nil))) |
nil))) |
199 |
(when (and (consp slot-attrs) |
(when (and (consp slot-attrs) |
200 |
(not (keywordp slot-attrs))) |
(not (keywordp (car slot-attrs)))) |
201 |
(pop slot-attrs)) |
(pop slot-attrs)) |
202 |
(let ((type (getf slot-attrs :type))) |
(let ((type (getf slot-attrs :type))) |
203 |
(if type |
(if type |
204 |
(cons slot-name (create-instance-of-type type)) |
(cons slot-name (create-instance-of-type type)) |
205 |
(cons slot-name (gensym))))))) |
(cons slot-name (gensym))))))) |
206 |
) |
) |
207 |
`(eval-when (compile load eval) |
;; Build the tests in an eval-when form |
208 |
(defstruct ,name-and-options |
`(eval-when (compile load eval) |
209 |
,@slot-descriptions-and-documentation) |
(defstruct ,name-and-options |
210 |
|
,@slot-descriptions-and-documentation) |
211 |
;; Test that structure is of the correct type |
|
212 |
(deftest ,(make-struct-test-name name 1) |
;; Test that structure is of the correct type |
213 |
(not (not (typep (,make-fn) (quote ,name)))) |
(deftest ,(make-struct-test-name name 1) |
214 |
t) |
(and (functionp (function ,make-fn)) |
215 |
|
(symbol-function (quote ,make-fn)) |
216 |
;; Test that the -P predicate exists |
(notnot (typep (,make-fn) (quote ,name)))) |
217 |
(deftest ,(make-struct-test-name name 2) |
t) |
218 |
(not (not (,p-fn (,make-fn)))) |
|
219 |
t) |
;; Test that the predicate exists |
220 |
|
,@(when p-fn |
221 |
;; Test that the elements of *universe* are not |
`((deftest ,(make-struct-test-name name 2) |
222 |
;; of this type |
(and (functionp (function ,p-fn)) |
223 |
(deftest ,(make-struct-test-name name 3) |
(symbol-function (quote ,p-fn)) |
224 |
(count-if (function ,p-fn) *universe*) |
(notnot (,p-fn (,make-fn)))) |
225 |
0) |
t))) |
226 |
|
|
227 |
(deftest ,(make-struct-test-name name 4) |
;; Test that the elements of *universe* are not |
228 |
(count-if (function (lambda (x) (typep x (quote ,name)))) |
;; of this type |
229 |
*universe*) |
(deftest ,(make-struct-test-name name 3) |
230 |
0) |
(count-if (function ,p-fn) *universe*) |
231 |
|
0) |
232 |
;; Check that the fields can be read after being initialized |
|
233 |
(deftest ,(make-struct-test-name name 5) |
(deftest ,(make-struct-test-name name 4) |
234 |
,(let ((inits nil) |
(count-if (function (lambda (x) (typep x (quote ,name)))) |
235 |
(tests nil) |
*universe*) |
236 |
(var (gensym "X"))) |
0) |
237 |
(loop |
|
238 |
for (slot-name . initval) in initial-value-alist |
;; Check that the fields can be read after being initialized |
239 |
do |
(deftest ,(make-struct-test-name name 5) |
240 |
(setf inits |
,(let ((inits nil) |
241 |
(list* (intern (string slot-name) "KEYWORD") |
(tests nil) |
242 |
(list 'quote initval) |
(var (gensym "X"))) |
243 |
inits)) |
(loop |
244 |
(push `(eql (quote ,initval) |
for (slot-name . initval) in initial-value-alist |
245 |
(,(make-struct-field-fn name slot-name) |
do |
246 |
,var)) |
(setf inits |
247 |
tests)) |
(list* (intern (string slot-name) "KEYWORD") |
248 |
`(let ((,var (,(make-struct-make-fn name) . ,inits))) |
(list 'quote initval) |
249 |
(and ,@tests t))) |
inits)) |
250 |
t) |
(push `(eqlt (quote ,initval) |
251 |
|
(,(make-struct-field-fn conc-prefix slot-name) |
252 |
;; Check that two invocations return different structures |
,var)) |
253 |
(deftest ,(make-struct-test-name name 6) |
tests)) |
254 |
,(let ((make-fn (make-struct-make-fn name))) |
`(let ((,var (,make-fn . ,inits))) |
255 |
`(eqt (,make-fn) (,make-fn))) |
(and ,@tests t))) |
256 |
nil) |
t) |
257 |
|
|
258 |
;; Check that we can setf the fields |
;; Check that two invocations return different structures |
259 |
(deftest ,(make-struct-test-name name 7) |
(deftest ,(make-struct-test-name name 6) |
260 |
,(let* ((var (gensym "X")) |
(eqt (,make-fn) (,make-fn)) |
261 |
(var2 (gensym "T")) |
nil) |
262 |
(tests |
|
263 |
(loop |
;; Check that we can setf the fields |
264 |
for (slot-name . initval) in initial-value-alist |
(deftest ,(make-struct-test-name name 7) |
265 |
collect |
,(let* ((var (gensym "X")) |
266 |
(let ((field-fn (make-struct-field-fn name slot-name))) |
(var2 (gensym "T")) |
267 |
`(let ((,var2 (quote ,initval))) |
(tests |
268 |
(setf (,field-fn ,var) ,var2) |
(loop |
269 |
(eql (,field-fn ,var) ,var2)))))) |
for (slot-name . initval) in initial-value-alist |
270 |
`(let ((,var (,(make-struct-make-fn name)))) |
for slot-desc in slot-descriptions |
271 |
(and ,@tests t))) |
unless (and (consp slot-desc) |
272 |
t) |
(getf (cddr slot-desc) :read-only)) |
273 |
|
collect |
274 |
;; Check that the copy function properly copies fields |
(let ((field-fn (make-struct-field-fn conc-prefix |
275 |
(deftest ,(make-struct-test-name name 8) |
slot-name))) |
276 |
,(let* ((var (gensym "X")) |
`(let ((,var2 (quote ,initval))) |
277 |
(var2 (gensym "Y"))) |
(setf (,field-fn ,var) ,var2) |
278 |
`(let ((,var (,(make-struct-make-fn name) |
(eqlt (,field-fn ,var) ,var2)))))) |
279 |
,@(loop |
`(let ((,var (,make-fn))) |
280 |
for (slot-name . initval) in initial-value-alist |
(and ,@tests t))) |
281 |
nconc (list (intern (string slot-name) "KEYWORD") |
t) |
282 |
`(quote ,initval)))))) |
|
283 |
(let ((,var2 (,(make-struct-copy-fn name) ,var))) |
;; Check that the copy function exists |
284 |
(and |
,@(when copy-fn |
285 |
(not (eql ,var ,var2)) |
`((deftest ,(make-struct-test-name name 8) |
286 |
,@(loop |
(and (functionp (function ,copy-fn)) |
287 |
for (slot-name . initval) in initial-value-alist |
(symbol-function (quote ,copy-fn)) |
288 |
collect |
t) |
289 |
(let ((fn (make-struct-field-fn name slot-name))) |
t))) |
290 |
`(eql (,fn ,var) (,fn ,var2)))) |
|
291 |
t)))) |
;; Check that the copy function properly copies fields |
292 |
t) |
,@(when copy-fn |
293 |
))) |
`((deftest ,(make-struct-test-name name 9) |
294 |
|
,(let* ((var (gensym "X")) |
295 |
|
(var2 (gensym "Y"))) |
296 |
|
`(let ((,var (,make-fn |
297 |
|
,@(loop |
298 |
|
for (slot-name . initval) |
299 |
|
in initial-value-alist |
300 |
|
nconc (list (intern (string slot-name) |
301 |
|
"KEYWORD") |
302 |
|
`(quote ,initval)))))) |
303 |
|
(let ((,var2 (,copy-fn ,var))) |
304 |
|
(and |
305 |
|
(not (eqlt ,var ,var2)) |
306 |
|
,@(loop |
307 |
|
for (slot-name . nil) in initial-value-alist |
308 |
|
collect |
309 |
|
(let ((fn (make-struct-field-fn conc-prefix |
310 |
|
slot-name))) |
311 |
|
`(eqlt (,fn ,var) (,fn ,var2)))) |
312 |
|
t)))) |
313 |
|
t))) |
314 |
|
))) |